diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Eval.hs | 55 | ||||
| -rw-r--r-- | src/Helper.hs | 38 | ||||
| -rw-r--r-- | src/Parser.hs | 52 |
3 files changed, 86 insertions, 59 deletions
diff --git a/src/Eval.hs b/src/Eval.hs index fdaa2cb..eea56a8 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -55,14 +55,17 @@ loadFile path conf = do (conf { isRepl = False, evalPaths = (path : (evalPaths conf)) }) ) -evalVar :: String -> Environment -> Program (Failable Expression) -evalVar var (Environment sub) = state $ \env@(Environment e) -> +evalIdent :: String -> Environment -> Program (Failable Expression) +evalIdent ident (Environment sub) = state $ \env@(Environment e) -> let lookup' name env' = case lookup name env' of - Nothing -> Left $ UndeclaredFunction var + Nothing -> Left $ UndeclaredIdentifier name Just x -> Right x - in case lookup' var (map fst sub) of -- search in sub env + in case lookup' ident (map fst sub) of -- search in sub env s@(Right _) -> (s, env) - _ -> (lookup' var (map fst e), env) -- search in global env + _ -> (lookup' ident (map fst e), env) -- search in global env + +evalFun :: Identifier -> Environment -> Program (Failable Expression) +evalFun = evalIdent . functionName evalAbs :: Expression -> Environment -> Program (Failable Expression) evalAbs e sub = evalExp e sub >>= pure . fmap Abstraction @@ -78,28 +81,27 @@ evalApp f g sub = evalInfix :: Expression - -> String + -> Identifier -> Expression -> Environment -> Program (Failable Expression) -evalInfix le i re = - evalExp $ Application (Application (Variable $ "(" ++ i ++ ")") le) re +evalInfix le i re = evalExp $ Application (Application (Function i) le) re evalPrefix - :: String -> Expression -> Environment -> Program (Failable Expression) -evalPrefix p e = evalExp $ Application (Variable $ p ++ "(") e + :: Identifier -> Expression -> Environment -> Program (Failable Expression) +evalPrefix p e = evalExp $ Application (Function p) e evalExp :: Expression -> Environment -> Program (Failable Expression) evalExp idx@(Bruijn _ ) = const $ pure $ Right idx -evalExp ( Variable var) = evalVar var +evalExp ( Function fun) = evalFun fun evalExp ( Abstraction e ) = evalAbs e evalExp ( Application f g) = evalApp f g evalExp ( Infix le i re ) = evalInfix le i re evalExp ( Prefix p e ) = evalPrefix p e evalDefine - :: String -> Expression -> Environment -> Program (Failable Expression) -evalDefine name e sub = + :: Identifier -> Expression -> Environment -> Program (Failable Expression) +evalDefine i e sub = evalExp e sub >>= (\case Left e' -> pure $ Left e' @@ -110,6 +112,7 @@ evalDefine name e sub = ) >> pure (Right f) ) + where name = functionName i evalTest :: Expression -> Expression -> Environment -> Program (Failable Instruction) @@ -136,14 +139,14 @@ evalInstruction :: Instruction -> EnvState -> (EnvState -> IO EnvState) -> IO EnvState evalInstruction (ContextualInstruction instr inp) s@(EnvState env conf) rec = case instr of - Define name e sub -> do + Define i e sub -> do EnvState subEnv _ <- evalSubEnv sub s - (res, env') <- pure $ evalDefine name e subEnv `runState` env + (res, env') <- pure $ evalDefine i e subEnv `runState` env case res of Left err -> print (ContextualError err $ Context inp $ nicePath conf) >> pure s -- don't continue Right _ - | isRepl conf -> (putStrLn $ name <> " = " <> show e) + | isRepl conf -> (putStrLn $ show i <> " = " <> show e) >> return (EnvState env' conf) | otherwise -> rec $ EnvState env' conf Input path -> do @@ -186,9 +189,9 @@ evalInstruction (ContextualInstruction instr inp) s@(EnvState env conf) rec = <> (show e') <> "\n*> " <> (show reduced) - <> " " + <> "\n?> " <> (humanifyExpression reduced) - <> " " + <> "\n#> " <> (matchingFunctions reduced env) where reduced = reduce e' ) @@ -242,7 +245,7 @@ evalFileConf path wr conv conf = do arg <- encodeStdin case evalMainFunc env arg of Nothing -> - print $ ContextualError (UndeclaredFunction "main") (Context "" path) + print $ ContextualError (UndeclaredIdentifier "main") (Context "" path) Just e -> wr $ conv e defaultConf :: String -> EvalConf @@ -253,12 +256,12 @@ defaultConf path = EvalConf { isRepl = False , evalPaths = [] } -reduceFile :: String -> (a -> IO ()) -> (Expression -> a) -> IO () -reduceFile path wr conv = do +dumpFile :: String -> (a -> IO ()) -> (Expression -> a) -> IO () +dumpFile path wr conv = do EnvState (Environment env) _ <- loadFile path (defaultConf path) case lookup "main" (map fst env) of Nothing -> - print $ ContextualError (UndeclaredFunction "main") (Context "" path) + print $ ContextualError (UndeclaredIdentifier "main") (Context "" path) Just e -> wr $ conv e evalFile :: String -> (a -> IO ()) -> (Expression -> a) -> IO () @@ -345,10 +348,10 @@ evalMain = do args <- getArgs case args of [] -> runRepl - ["-b", path] -> reduceFile path - (Byte.putStr . Bit.realizeBitStringStrict) - (toBitString . toBinary) - ["-B", path] -> reduceFile path putStrLn toBinary + ["-b", path] -> dumpFile path + (Byte.putStr . Bit.realizeBitStringStrict) + (toBitString . toBinary) + ["-B", path] -> dumpFile path putStrLn toBinary ["-e", path] -> exec path (try . Byte.readFile) (fromBitString . Bit.bitString) ["-E", path] -> exec path (try . readFile) id diff --git a/src/Helper.hs b/src/Helper.hs index 418735e..d7064c1 100644 --- a/src/Helper.hs +++ b/src/Helper.hs @@ -34,13 +34,13 @@ printContext (Context inp path) = p $ lines inp errPrefix :: String errPrefix = "\ESC[41mERROR\ESC[0m " -data Error = SyntaxError String | UndeclaredFunction String | InvalidIndex Int | FailedTest Expression Expression Expression Expression | ContextualError Error Context | ImportError String +data Error = SyntaxError String | UndeclaredIdentifier String | InvalidIndex Int | FailedTest Expression Expression Expression Expression | ContextualError Error Context | ImportError String instance Show Error where show (ContextualError err ctx) = show err <> "\n" <> (printContext ctx) show (SyntaxError err) = errPrefix <> "invalid syntax\n\ESC[45mnear\ESC[0m " <> err - show (UndeclaredFunction func) = - errPrefix <> "undeclared function " <> show func + show (UndeclaredIdentifier ident) = + errPrefix <> "undeclared identifier " <> ident show (InvalidIndex err) = errPrefix <> "invalid index " <> show err show (FailedTest exp1 exp2 red1 red2) = errPrefix @@ -89,19 +89,35 @@ printBundle ParseErrorBundle {..} = <> pointer <> "\n" -data Expression = Bruijn Int | Variable String | Abstraction Expression | Application Expression Expression | Infix Expression String Expression | Prefix String Expression +data Identifier = NormalFunction String | InfixFunction String | PrefixFunction String | NamespacedFunction String Identifier deriving (Ord, Eq) -data Instruction = Define String Expression [Instruction] | Evaluate Expression | Comment | Input String | Import String String | Test Expression Expression | ContextualInstruction Instruction String +functionName :: Identifier -> String +functionName = \case + NormalFunction f -> f + InfixFunction i -> "(" <> i <> ")" + PrefixFunction p -> p <> "(" + NamespacedFunction n f -> n <> functionName f +instance Show Identifier where + show ident = "\ESC[95m" <> functionName ident <> "\ESC[0m" +data Expression = Bruijn Int | Function Identifier | Abstraction Expression | Application Expression Expression | Infix Expression Identifier Expression | Prefix Identifier Expression + deriving (Ord, Eq) +data Instruction = Define Identifier Expression [Instruction] | Evaluate Expression | Comment | Input String | Import String String | Test Expression Expression | ContextualInstruction Instruction String deriving (Show) instance Show Expression where - show (Bruijn x ) = "\ESC[91m" <> show x <> "\ESC[0m" - show (Variable var) = "\ESC[95m" <> var <> "\ESC[0m" - show (Abstraction e ) = "\ESC[36m[\ESC[0m" <> show e <> "\ESC[36m]\ESC[0m" + show (Bruijn x ) = "\ESC[91m" <> show x <> "\ESC[0m" + show (Function ident) = "\ESC[95m" <> show ident <> "\ESC[0m" + show (Abstraction e ) = "\ESC[36m[\ESC[0m" <> show e <> "\ESC[36m]\ESC[0m" show (Application exp1 exp2) = "\ESC[33m(\ESC[0m" <> show exp1 <> " " <> show exp2 <> "\ESC[33m)\ESC[0m" show (Infix le i re) = - show le <> " \ESC[95m(" <> i <> ")" <> "\ESC[0m " <> show re - show (Prefix p e) = "\ESC[95m" <> p <> show e <> "\ESC[0m" + "\ESC[33m(\ESC[0m" + <> show i + <> " " + <> show le + <> " " + <> show re + <> "\ESC[33m)\ESC[0m" + show (Prefix p e) = show p <> " " <> show e type EnvDef = (String, Expression) data EvalConf = EvalConf @@ -193,7 +209,7 @@ maybeHumanifyExpression e = ternaryToDecimal e <|> decodeStdout e humanifyExpression :: Expression -> String humanifyExpression e = case maybeHumanifyExpression e of - Nothing -> "" + Nothing -> show e Just h -> h --- diff --git a/src/Parser.hs b/src/Parser.hs index c23130d..a27c6a2 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -17,36 +17,44 @@ type Parser = Parsec Void String sc :: Parser () sc = void $ char ' ' +-- "'" can't be in special chars because of 'c' char notation and prefixation specialChar :: Parser Char specialChar = oneOf "!?*@.:;+-_#$%^&<>/\\|~=" +-- lower or upper +greekLetter :: Parser Char +greekLetter = satisfy isGreek + where isGreek c = ('Α' <= c && c <= 'Ω') || ('α' <= c && c <= 'ω') + infixOperator :: Parser String -infixOperator = some specialChar +infixOperator = + some specialChar <|> ((++) <$> dottedNamespace <*> infixOperator) prefixOperator :: Parser String -prefixOperator = some specialChar +prefixOperator = infixOperator --- def identifier disallows the import prefix dots -defIdentifier :: Parser String +defIdentifier :: Parser Identifier defIdentifier = - ((:) <$> letterChar <*> many (alphaNumChar <|> specialChar <|> char '\'')) - <|> ((\l i r -> [l] ++ i ++ [r]) <$> char '(' <*> infixOperator <*> char ')' + ( NormalFunction + <$> ((:) <$> (lowerChar <|> greekLetter) <*> many + (alphaNumChar <|> specialChar <|> char '\'') ) - <|> ((\p i -> p ++ [i]) <$> prefixOperator <*> char '(') + ) + <|> (InfixFunction <$> (char '(' *> infixOperator <* char ')')) + <|> (PrefixFunction <$> (prefixOperator <* char '(')) <?> "defining identifier" --- TODO: write as extension to defIdentifier -identifier :: Parser String +identifier :: Parser Identifier identifier = - ((:) <$> letterChar <*> many (alphaNumChar <|> specialChar <|> oneOf ".\'")) - <|> ((\l i r -> [l] ++ i ++ [r]) <$> char '(' <*> infixOperator <*> char ')' - ) - <|> ((\p i -> p ++ [i]) <$> prefixOperator <*> char '(') + try (NamespacedFunction <$> dottedNamespace <*> defIdentifier) + <|> defIdentifier <?> "identifier" namespace :: Parser String -namespace = - ((:) <$> upperChar <*> many letterChar) <|> string "." <?> "namespace" +namespace = (:) <$> upperChar <*> many letterChar <?> "namespace" + +dottedNamespace :: Parser String +dottedNamespace = (\n d -> n ++ [d]) <$> namespace <*> char '.' parens :: Parser a -> Parser a parens = between (string "(") (string ")") @@ -107,10 +115,10 @@ parseChar = do <?> "quoted char" pure $ charToExpression ch -parseVariable :: Parser Expression -parseVariable = do +parseFunction :: Parser Expression +parseFunction = do var <- identifier - pure $ Variable var + pure $ Function var parseInfix :: Parser Expression parseInfix = do @@ -119,13 +127,13 @@ parseInfix = do i <- infixOperator sc e2 <- parseSingleton - pure $ Infix e1 i e2 + pure $ Infix e1 (InfixFunction i) e2 parsePrefix :: Parser Expression parsePrefix = do p <- prefixOperator e <- parseSingleton - pure $ Prefix p e + pure $ Prefix (PrefixFunction p) e parseSingleton :: Parser Expression parseSingleton = @@ -134,7 +142,7 @@ parseSingleton = <|> parseString <|> parseChar <|> parseAbstraction - <|> try parseVariable + <|> try parseFunction <|> try (parens parseInfix <?> "enclosed infix expr") <|> (parens parseApplication <?> "enclosed application") <|> parsePrefix @@ -180,7 +188,7 @@ parseImport = do inp <- getInput _ <- string ":import " <?> "import instruction" path <- importPath - ns <- (try $ sc *> namespace) <|> (eof >> return "") + ns <- (try $ (sc *> (namespace <|> string "."))) <|> (eof >> return "") pure $ ContextualInstruction (Import (path ++ ".bruijn") ns) inp parseInput :: Parser Instruction |