Trying a new syntax

Let's see
author: Marvin Borner 2022-07-24 00:14:54 +0200
committer: Marvin Borner 2022-07-24 00:14:54 +0200
commit: e2eddf3edc1dfd49194bbb69eca518dcee70385f (patch)
tree: db95499c9dddbf864adc760d6d25d650aa4c6fdd /src
parent: 6c833c1e5fad32bf6262af226b25a0e0b61c4d0b (diff)
3 files changed, 136 insertions, 67 deletions
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 "<aborted>" >> 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
author	Marvin Borner	2022-07-24 00:14:54 +0200
committer	Marvin Borner	2022-07-24 00:14:54 +0200
commit	e2eddf3edc1dfd49194bbb69eca518dcee70385f (patch)
tree	db95499c9dddbf864adc760d6d25d650aa4c6fdd /src
parent	6c833c1e5fad32bf6262af226b25a0e0b61c4d0b (diff)