diff options
| -rw-r--r-- | README.md | 6 | ||||
| -rw-r--r-- | bruijn.cabal | 2 | ||||
| -rw-r--r-- | package.yaml | 1 | ||||
| -rw-r--r-- | src/Eval.hs | 63 | ||||
| -rw-r--r-- | src/Helper.hs | 31 | ||||
| -rw-r--r-- | src/Parser.hs | 109 | ||||
| -rw-r--r-- | std/Number.bruijn | 48 | ||||
| -rw-r--r-- | std/Option.bruijn | 4 |
8 files changed, 167 insertions, 97 deletions
@@ -152,11 +152,11 @@ Using standard library: :test snd love = you # options - :test map succ (some +1) = some +2 - :test apply (some +1) [some (succ 0)] = some +2 + :test map inc (some +1) = some +2 + :test apply (some +1) [some (inc 0)] = some +2 # numerical operations - five pred (sub (add +8 -4) -2) + five dec (sub (add +8 -4) -2) not-five? [if (eq? 0 +5) F T] :test not-five? five = F diff --git a/bruijn.cabal b/bruijn.cabal index c7eafe5..d2d7449 100644 --- a/bruijn.cabal +++ b/bruijn.cabal @@ -65,7 +65,7 @@ executable bruijn app default-extensions: LambdaCase - ghc-options: -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 , binary diff --git a/package.yaml b/package.yaml index 03b080e..120d0e4 100644 --- a/package.yaml +++ b/package.yaml @@ -45,6 +45,7 @@ executables: main: Main.hs source-dirs: app ghc-options: + - -Wall - -threaded - -rtsopts - -with-rtsopts=-N 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 diff --git a/std/Number.bruijn b/std/Number.bruijn index b8232dc..58a0da9 100644 --- a/std/Number.bruijn +++ b/std/Number.bruijn @@ -98,35 +98,35 @@ strip [fst (0 _strip-z _strip-neg _strip-pos _strip-zero)] :test strip +42 = +42 # I believe Mogensen's Paper has an error in its succ/pred definitions. -# They use 3 abstractions in the _succ* functions, also we use switched +/0 +# They use 3 abstractions in the _inc* functions, also we use switched +/0 # in comparison to their implementation, yet the order of neg/pos/zero is # the same. Something's weird. # adds +1 to a balanced ternary number (can introduce leading 0s) -_succ-z pair +0 +1 -_succ-neg [0 [[pair (up-neg 1) (up-zero 1)]]] -_succ-zero [0 [[pair (up-zero 1) (up-pos 1)]]] -_succ-pos [0 [[pair (up-pos 1) (up-neg 0)]]] -succ [snd (0 _succ-z _succ-neg _succ-pos _succ-zero)] -ssucc [strip (succ 0)] -:test eq? (succ -42) -41 = T -:test eq? (succ -1) +0 = T -:test eq? (succ +0) +1 = T -:test eq? (succ (succ (succ (succ (succ +0))))) +5 = T -:test eq? (succ +42) +43 = T +_inc-z pair +0 +1 +_inc-neg [0 [[pair (up-neg 1) (up-zero 1)]]] +_inc-zero [0 [[pair (up-zero 1) (up-pos 1)]]] +_inc-pos [0 [[pair (up-pos 1) (up-neg 0)]]] +inc [snd (0 _inc-z _inc-neg _inc-pos _inc-zero)] +sinc [strip (inc 0)] +:test eq? (inc -42) -41 = T +:test eq? (inc -1) +0 = T +:test eq? (inc +0) +1 = T +:test eq? (inc (inc (inc (inc (inc +0))))) +5 = T +:test eq? (inc +42) +43 = T # subs +1 from a balanced ternary number (can introduce leading 0s) -_pred-z pair +0 -1 -_pred-neg [0 [[pair (up-neg 1) (up-pos 0)]]] -_pred-zero [0 [[pair (up-zero 1) (up-neg 1)]]] -_pred-pos [0 [[pair (up-pos 1) (up-zero 1)]]] -pred [snd (0 _pred-z _pred-neg _pred-pos _pred-zero)] -spred [strip (pred 0)] -:test pred -42 = -43 -:test pred +0 = -1 -:test spred (pred (pred (pred (pred +5)))) = +0 -:test spred +1 = +0 -:test pred +42 = +41 +_dec-z pair +0 -1 +_dec-neg [0 [[pair (up-neg 1) (up-pos 0)]]] +_dec-zero [0 [[pair (up-zero 1) (up-neg 1)]]] +_dec-pos [0 [[pair (up-pos 1) (up-zero 1)]]] +dec [snd (0 _dec-z _dec-neg _dec-pos _dec-zero)] +sdec [strip (dec 0)] +:test dec -42 = -43 +:test dec +0 = -1 +:test sdec (dec (dec (dec (dec +5)))) = +0 +:test sdec +1 = +0 +:test dec +42 = +41 # adds two balanced ternary numbers (can introduce leading 0s) _add-c [[1 0 trit-zero]] @@ -138,7 +138,7 @@ _add-b-pos2 [1 (up-pos (3 0 trit-zero)) (up-zero (3 0 trit-pos)) (up-neg (3 0 tr _add-a-neg [[[1 (_add-b-neg 1) _add-b-neg2 _add-b-zero _add-b-neg]]] _add-a-pos [[[1 (_add-b-pos 1) _add-b-zero _add-b-pos2 _add-b-pos]]] _add-a-zero [[[1 (_add-b-zero 1) _add-b-neg _add-b-pos _add-b-zero]]] -_add-z [[0 (pred (normalize 1)) (succ (normalize 1)) (normalize 1)]] +_add-z [[0 (dec (normalize 1)) (inc (normalize 1)) (normalize 1)]] _add-abs [_add-c (0 _add-z _add-a-neg _add-a-pos _add-a-zero)] add [[_add-abs 1 (abstractify 0)]] sadd [[strip (add 1 0)]] diff --git a/std/Option.bruijn b/std/Option.bruijn index e33cbb5..a2c1b88 100644 --- a/std/Option.bruijn +++ b/std/Option.bruijn @@ -18,12 +18,12 @@ some? [0 F [T]] :test some? none = F :test some? (some [[0]]) = T -# applies a function to the value in a option +# applies a function to the value in option map [[0 none [some (2 0)]]] :test map [[1]] (some [[0]]) = some [[[0]]] :test map [[1]] none = none -# applies a function to the value in a option or returns first arg if none +# applies a function to the value in option or returns first arg if none map-or [[[0 2 1]]] :test map-or [[[2]]] [[1]] (some [[0]]) = [[[0]]] :test map-or [[[2]]] [[1]] none = [[[2]]] |