From e2eddf3edc1dfd49194bbb69eca518dcee70385f Mon Sep 17 00:00:00 2001 From: Marvin Borner Date: Sun, 24 Jul 2022 00:14:54 +0200 Subject: Trying a new syntax Let's see --- src/Eval.hs | 63 ++++++++++++++++++++------------- src/Helper.hs | 31 +++++++++++++++-- src/Parser.hs | 109 ++++++++++++++++++++++++++++++++++++---------------------- 3 files changed, 136 insertions(+), 67 deletions(-) (limited to 'src') diff --git a/src/Eval.hs b/src/Eval.hs index 0b7632a..23c388e 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -30,17 +30,27 @@ data EnvState = EnvState } type M = StrictState.StateT EnvState IO +-- why isn't this in Prelude?? +split :: (Eq a) => [a] -> [a] -> [[a]] +split _ [] = [] +split [] x = map (: []) x +split a@(d : ds) b@(c : cs) + | Just suffix <- a `stripPrefix` b = [] : split a suffix + | otherwise = if null rest then [[c]] else (c : head rest) : tail rest + where rest = split a $ tail b + -- TODO: Force naming convention for namespaces/files loadFile :: String -> IO EnvState loadFile path = do file <- try $ readFile path :: IO (Either IOError String) case file of Left exception -> print (exception :: IOError) >> pure (EnvState []) - Right file -> eval (filter (not . null) $ lines file) (EnvState []) False + Right file -> + eval (filter (not . null) $ split "\n\n" file) (EnvState []) False evalVar :: String -> Program (Failable Expression) evalVar var = state $ \e -> - ( case lookup var e of + ( case lookup var (map fst e) of Nothing -> Left $ UndeclaredFunction var Just x -> Right x , e @@ -60,12 +70,12 @@ evalExp ( Variable var) = evalVar var evalExp ( Abstraction exp) = evalExp exp >>= pure . fmap Abstraction evalExp ( Application f g) = evalApp f g -evalDefine :: String -> Expression -> Program (Failable Expression) -evalDefine name exp = +evalDefine :: String -> Expression -> [EnvDef] -> Program (Failable Expression) +evalDefine name exp sub = evalExp exp >>= (\case Left e -> pure $ Left e - Right f -> modify ((name, f) :) >> pure (Right f) + Right f -> modify (((name, f), sub) :) >> pure (Right f) ) evalTest :: Expression -> Expression -> Program (Failable Instruction) @@ -79,20 +89,21 @@ evalTest exp1 exp2 = eval :: [String] -> EnvState -> Bool -> IO EnvState eval [] state _ = return state eval [""] state _ = return state -eval (line : ls) state@(EnvState env) isRepl = +eval (block : bs) state@(EnvState env) isRepl = handleInterrupt (putStrLn "" >> return state) - $ case parse lineParser "" line of - Left err -> putStrLn (errorBundlePretty err) >> eval ls state isRepl + $ case parse blockParser "" block of + Left err -> putStrLn (errorBundlePretty err) >> eval bs state isRepl Right instr -> case instr of - Define name exp -> - let (res, env') = evalDefine name exp `runState` env + Define name exp sub -> + -- TODO: sub: [Instruction] -> [EnvDef] (rec-mapping or sth?) + let (res, env') = evalDefine name exp [] `runState` env in case res of Left err -> - putStrLn (show err) >> eval ls (EnvState env') isRepl + putStrLn (show err) >> eval bs (EnvState env') isRepl Right _ -> if isRepl then (putStrLn $ name <> " = " <> show exp) >> return (EnvState env') - else eval ls (EnvState env') isRepl + else eval bs (EnvState env') isRepl -- TODO: Import loop detection -- TODO: Don't import subimports into main env Import path namespace -> do @@ -102,8 +113,8 @@ eval (line : ls) state@(EnvState env) isRepl = let prefix | null namespace = takeBaseName path ++ "." | namespace == "." = "" | otherwise = namespace ++ "." - env' <- pure $ map (\(n, e) -> (prefix ++ n, e)) env' - eval ls (EnvState $ env <> env') isRepl + env' <- pure $ map (\((n, e), s) -> ((prefix ++ n, e), s)) env' + eval bs (EnvState $ env <> env') False -- import => isRepl = False Evaluate exp -> let (res, env') = evalExp exp `runState` env in @@ -122,7 +133,7 @@ eval (line : ls) state@(EnvState env) isRepl = ) where reduced = reduce exp ) - >> eval ls state isRepl + >> eval bs state isRepl Test exp1 exp2 -> let (res, _) = evalTest exp1 exp2 `runState` env in case res of @@ -136,19 +147,25 @@ eval (line : ls) state@(EnvState env) isRepl = <> " != " <> (show exp2) ) - >> eval ls state isRepl - _ -> eval ls state isRepl - where lineParser = if isRepl then parseReplLine else parseLine + >> eval bs state isRepl + _ -> eval bs state isRepl + where blockParser = if isRepl then parseReplLine else parseBlock 0 evalFunc :: String -> Environment -> Maybe Expression evalFunc func env = do - exp <- lookup func env + exp <- lookup func $ map fst env pure $ reduce exp +evalMainFunc :: Environment -> Expression -> Maybe Expression +evalMainFunc env arg = do + exp <- lookup "main" $ map fst env + pure $ reduce $ Application exp arg + evalFile :: String -> (a -> IO ()) -> (Expression -> a) -> IO () evalFile path write conv = do EnvState env <- loadFile path - case evalFunc "main" env of + arg <- encodeStdin + case evalMainFunc env arg of Nothing -> putStrLn $ "ERROR: main function not found" Just exp -> write $ conv exp @@ -175,8 +192,8 @@ repl state = lookupCompletion :: String -> M [Completion] lookupCompletion str = do (EnvState env) <- StrictState.get - return $ map (\(s, _) -> Completion s s False) $ filter - (\(s, _) -> str `isPrefixOf` s) + return $ map (\((s, _), _) -> Completion s s False) $ filter + (\((s, _), _) -> str `isPrefixOf` s) env completionSettings :: String -> Settings M @@ -193,7 +210,7 @@ runRepl = do prefs <- readPrefs config let looper = runInputTWithPrefs prefs (completionSettings history) - (withInterrupt $ repl (EnvState [])) + (withInterrupt $ repl $ EnvState []) code <- StrictState.evalStateT looper (EnvState []) return code diff --git a/src/Helper.hs b/src/Helper.hs index 5c31aba..ee4b162 100644 --- a/src/Helper.hs +++ b/src/Helper.hs @@ -1,6 +1,8 @@ module Helper where import Control.Monad.State +import qualified Data.BitString as Bit +import qualified Data.ByteString as Byte data Error = UndeclaredFunction String | DuplicateFunction String | InvalidIndex Int | FatalError String instance Show Error where @@ -12,7 +14,7 @@ type Failable = Either Error data Expression = Bruijn Int | Variable String | Abstraction Expression | Application Expression Expression deriving (Ord, Eq) -data Instruction = Define String Expression | Evaluate Expression | Comment String | Import String String | Test Expression Expression +data Instruction = Define String Expression [Instruction] | Evaluate Expression | Comment String | Import String String | Test Expression Expression deriving (Show) instance Show Expression where show (Bruijn x ) = "\ESC[31m" <> show x <> "\ESC[0m" @@ -21,9 +23,34 @@ instance Show Expression where show (Application exp1 exp2) = "\ESC[33m(\ESC[0m" <> show exp1 <> " " <> show exp2 <> "\ESC[33m)\ESC[0m" -type Environment = [(String, Expression)] +type EnvDef = (String, Expression) +type Environment = [(EnvDef, [EnvDef])] type Program = State Environment +--- + +listify :: [Expression] -> Expression +listify [] = Abstraction (Abstraction (Bruijn 0)) +listify (fst : rst) = + Abstraction (Application (Application (Bruijn 0) fst) (listify rst)) + +encodeByte :: Bit.BitString -> Expression +encodeByte bits = listify (map encodeBit (Bit.toList bits)) + where + encodeBit False = Abstraction (Abstraction (Bruijn 0)) + encodeBit True = Abstraction (Abstraction (Bruijn 1)) + +encodeBytes :: Byte.ByteString -> Expression +encodeBytes bytes = + listify (map (encodeByte . Bit.from01List . (: [])) (Byte.unpack bytes)) + +encodeStdin :: IO Expression +encodeStdin = do + bytes <- Byte.getContents + pure $ encodeBytes bytes + +--- + likeTernary :: Expression -> Bool likeTernary (Abstraction (Abstraction (Abstraction (Abstraction _)))) = True likeTernary _ = False diff --git a/src/Parser.hs b/src/Parser.hs index f4afb69..6fbfc10 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -1,9 +1,11 @@ module Parser - ( parseLine + ( parseBlock , parseReplLine ) where -import Control.Monad ( ap ) +import Control.Monad ( ap + , void + ) import Data.Functor.Identity import Data.Void import Helper @@ -13,30 +15,45 @@ import qualified Text.Megaparsec.Char.Lexer as L type Parser = Parsec Void String +-- exactly one space +-- TODO: replace many scs with sc sc :: Parser () -sc = L.space space1 empty empty +sc = void $ char ' ' + +-- zero or more spaces +scs :: Parser () +scs = void $ takeWhileP (Just "white space") (== ' ') lexeme :: Parser a -> Parser a -lexeme = L.lexeme sc +lexeme = L.lexeme scs symbol :: String -> Parser String -symbol = L.symbol sc +symbol = L.symbol scs -- def identifier disallows the import prefix dots defIdentifier :: Parser String -defIdentifier = lexeme - ((:) <$> (letterChar <|> char '_') <*> many (alphaNumChar <|> oneOf "?!'_-")) +defIdentifier = + lexeme + ((:) <$> (letterChar <|> char '_') <*> many + (alphaNumChar <|> oneOf "?!'_-") + ) + "defining identifier" -- TODO: write as extension to defIdentifier identifier :: Parser String -identifier = lexeme - ((:) <$> (letterChar <|> char '_') <*> many (alphaNumChar <|> oneOf "?!'_-.")) +identifier = + lexeme + ((:) <$> (letterChar <|> char '_') <*> many + (alphaNumChar <|> oneOf "?!'_-.") + ) + "identifier" namespace :: Parser String namespace = lexeme ((:) <$> upperChar <*> many letterChar) <|> string "." - <|> (space >> return "") + <|> (scs >> return "") + "namespace" parens :: Parser a -> Parser a parens = between (symbol "(") (symbol ")") @@ -50,26 +67,26 @@ importPath = some $ oneOf "./_+-" <|> letterChar <|> digitChar parseAbstraction :: Parser Expression parseAbstraction = do - symbol "[" + symbol "[" "opening abstraction" exp <- parseExpression - symbol "]" + symbol "]" "closing abstraction" pure $ Abstraction exp parseApplication :: Parser Expression parseApplication = do - s <- sepBy1 parseSingleton space + s <- sepBy1 parseSingleton scs pure $ foldl1 Application s parseBruijn :: Parser Expression parseBruijn = do idx <- digitChar - space + scs pure $ Bruijn $ (read . pure) idx parseNumeral :: Parser Expression parseNumeral = do - num <- number - space + num <- number "signed number" + scs pure $ decimalToTernary num where sign :: Parser (Integer -> Integer) @@ -82,7 +99,7 @@ parseNumeral = do parseVariable :: Parser Expression parseVariable = do var <- identifier - space + scs pure $ Variable var parseSingleton :: Parser Expression @@ -90,67 +107,75 @@ parseSingleton = parseBruijn <|> parseNumeral <|> parseAbstraction - <|> parens parseApplication + <|> (parens parseApplication "enclosed application") <|> parseVariable parseExpression :: Parser Expression parseExpression = do - space + scs expr <- parseApplication <|> parseSingleton - space - pure expr + scs + pure expr "expression" parseEvaluate :: Parser Instruction parseEvaluate = Evaluate <$> parseExpression -parseDefine :: Parser Instruction -parseDefine = do +parseDefine :: Int -> Parser Instruction +parseDefine lvl = do var <- defIdentifier - space - Define var <$> parseExpression + scs + exp <- parseExpression + -- TODO: Fix >1 sub-defs + subs <- + (try $ newline *> (sepEndBy (parseBlock (lvl + 1)) newline)) + <|> (try eof >> return []) + pure $ Define var exp subs parseReplDefine :: Parser Instruction parseReplDefine = do var <- defIdentifier - space + scs symbol "=" - space - Define var <$> parseExpression + scs + exp <- parseExpression + pure $ Define var exp [] parseComment :: Parser Instruction -parseComment = string "#" >> Comment <$> almostAnything +parseComment = string "#" >> Comment <$> almostAnything "comment" parseImport :: Parser Instruction parseImport = do - string ":import " - space + string ":import " "import" + scs path <- importPath - space + scs ns <- namespace - space + scs pure $ Import (path ++ ".bruijn") ns parsePrint :: Parser Instruction parsePrint = do - string ":print " - space + string ":print " "print" + scs exp <- parseExpression - space + scs pure $ Evaluate exp parseTest :: Parser Instruction parseTest = do - string ":test " + string ":test " "test" exp1 <- parseExpression - space + scs symbol "=" - space + scs exp2 <- parseExpression pure $ Test exp1 exp2 -parseLine :: Parser Instruction -parseLine = - try parseDefine +-- TODO: Add comment/test [Instruction] parser and combine with (this) def block +parseBlock :: Int -> Parser Instruction +parseBlock lvl = + string (replicate lvl '\t') + *> try (parseDefine lvl) <|> try parseComment <|> try parsePrint <|> try parseImport -- cgit v1.2.3