diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Eval.hs | 113 | ||||
| -rw-r--r-- | src/Helper.hs | 53 | ||||
| -rw-r--r-- | src/Parser.hs | 64 |
3 files changed, 123 insertions, 107 deletions
diff --git a/src/Eval.hs b/src/Eval.hs index fe8dbe8..c457889 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -13,6 +13,7 @@ import Data.List import qualified Data.Map as M import Data.Maybe import Helper +-- import Inet ( reduce ) import Parser import Paths_bruijn import Reducer @@ -65,20 +66,20 @@ loadFile path conf cache = do evalFun :: Identifier -> Environment -> EvalState (Failable Expression) evalFun fun (Environment sub) = state $ \env@(Environment e) -> - let lookup' name env' = case M.lookup fun env' of - Nothing -> Left $ UndefinedIdentifier name + let lookup' env' = case M.lookup fun env' of + Nothing -> Left $ UndefinedIdentifier fun Just (EnvDef { _exp = x }) -> Right x matching n - | length e == 0 = "<no idea>" + | null e = "<no idea>" | otherwise = snd $ minimumBy (compare `on` fst) $ map (\f -> (levenshtein (functionName f) n, show f)) (M.keys e) suggest (Left u@(UndefinedIdentifier n)) = Left $ SuggestSolution u (matching $ functionName n) suggest x = x - in case lookup' fun sub of -- search in sub env + in case lookup' sub of -- search in sub env s@(Right _) -> (s, env) - _ -> (suggest $ lookup' fun e, env) -- search in global env + _ -> (suggest $ lookup' e, env) -- search in global env evalAbs :: Expression -> Environment -> EvalState (Failable Expression) evalAbs e sub = evalExp e sub >>= pure . fmap Abstraction @@ -89,14 +90,22 @@ evalApp f g sub = evalExp f sub >>= \case Left e -> pure $ Left e Right f' -> fmap (Application f') <$> evalExp g sub - -evalInfix - :: Expression - -> Identifier - -> Expression - -> Environment - -> EvalState (Failable Expression) -evalInfix le i re = evalExp $ Application (Application (Function i) le) re +evalMixfix :: [Mixfix] -> Environment -> EvalState (Failable Expression) +evalMixfix m sub = resolve (mixfixKind m) mixfixArgs + where + -- longestMatching [] _ = error "invalid" + -- longestMatching x xs = evalFun (MixfixFunction x) sub >>= \case + -- Left _ -> longestMatching (init x) ((last x) : xs) + -- Right f -> (f, Function $ MixfixFunction xs) + resolve f args + | null [ s | s@(MixfixSome _) <- f ] = evalExp (foldl1 Application args) sub + | otherwise = evalExp + (foldl1 Application ((Function $ MixfixFunction f) : args)) + sub + mixfixArgs = [ a | (MixfixExpression a) <- m ] + mixfixKind = map $ \case + MixfixOperator i -> MixfixSome $ functionName i + _ -> MixfixNone evalPrefix :: Identifier -> Expression -> Environment -> EvalState (Failable Expression) @@ -107,7 +116,7 @@ evalExp idx@(Bruijn _ ) = const $ pure $ Right idx 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 ( MixfixChain es ) = evalMixfix es evalExp ( Prefix p e ) = evalPrefix p e evalDefinition @@ -223,6 +232,19 @@ evalCommand inp s@(EnvState env@(Environment envDefs) conf cache) = \case | otherwise -> pure s +-- TODO: Reduce redundancy +showResult :: Expression -> Expression -> Environment -> IO () +showResult orig reduced env = + putStrLn + $ "<> " + <> (show orig) + <> "\n*> " + <> (show reduced) + <> "\n?> " + <> (humanifyExpression reduced) + <> "\n#> " + <> (matchingFunctions reduced env) + evalInstruction :: Instruction -> EnvState -> (EnvState -> IO EnvState) -> IO EnvState evalInstruction (ContextualInstruction instr inp) s@(EnvState env conf _) rec = @@ -239,20 +261,10 @@ evalInstruction (ContextualInstruction instr inp) s@(EnvState env conf _) rec = | otherwise -> rec s { _env = env' } Evaluate e -> let (res, _) = evalExp e (Environment M.empty) `runState` env - in putStrLn - (case res of - Left err -> show err - Right e' -> - "<> " - <> (show e') - <> "\n*> " - <> (show reduced) - <> "\n?> " - <> (humanifyExpression reduced) - <> "\n#> " - <> (matchingFunctions reduced env) - where reduced = reduce e' - ) + in (case res of + Left err -> print err + Right e' -> showResult e' (reduce e') env + ) >> rec s Commands cs -> yeet (pure s) cs >>= rec where -- TODO: sus @@ -281,21 +293,6 @@ eval (block : bs) s@(EnvState _ conf _) = blockParser | _isRepl conf = parseReplLine | otherwise = parseBlock 0 -evalMainFunc :: Environment -> Expression -> Maybe Expression -evalMainFunc (Environment env) arg = do - EnvDef { _exp = e } <- M.lookup entryFunction env - pure $ reduce $ Application e arg - -evalFileConf - :: String -> (a -> IO ()) -> (Expression -> a) -> EvalConf -> IO () -evalFileConf path wr conv conf = do - EnvState env _ _ <- loadFile path conf (EnvCache M.empty) - arg <- encodeStdin - case evalMainFunc env arg of - Nothing -> print - $ ContextualError (UndefinedIdentifier entryFunction) (Context "" path) - Just e -> wr $ conv e - dumpFile :: String -> (a -> IO ()) -> (Expression -> a) -> IO () dumpFile path wr conv = do EnvState (Environment env) _ _ <- loadFile path @@ -306,23 +303,31 @@ dumpFile path wr conv = do $ ContextualError (UndefinedIdentifier entryFunction) (Context "" path) Just EnvDef { _exp = e } -> wr $ conv e -evalFile :: String -> (a -> IO ()) -> (Expression -> a) -> IO () -evalFile path wr conv = evalFileConf path wr conv (defaultConf path) +evalFileConf :: String -> EvalConf -> IO () +evalFileConf path conf = do + EnvState (Environment env) _ _ <- loadFile path conf (EnvCache M.empty) + arg <- encodeStdin + case M.lookup entryFunction env of + Nothing -> print + $ ContextualError (UndefinedIdentifier entryFunction) (Context "" path) + Just EnvDef { _exp = e } -> + showResult e (reduce $ Application e arg) (Environment env) + +evalFile :: String -> IO () +evalFile path = evalFileConf path (defaultConf path) -- TODO: Merge with evalFile -evalYolo :: String -> (a -> IO ()) -> (Expression -> a) -> IO () -evalYolo path wr conv = - evalFileConf path wr conv (defaultConf path) { _evalTests = False } +evalYolo :: String -> IO () +evalYolo path = evalFileConf path (defaultConf path) { _evalTests = False } exec :: String -> (String -> IO (Either IOError a)) -> (a -> String) -> IO () exec path rd conv = do f <- rd path arg <- encodeStdin case f of - Left exception -> print (exception :: IOError) - Right f' -> putStr $ humanifyExpression $ reduce $ Application - (fromBinary $ conv f') - arg + Left exception -> print (exception :: IOError) + Right f' -> showResult e (reduce $ Application e arg) (Environment M.empty) + where e = fromBinary $ conv f' repl :: EnvState -> InputT M () repl (EnvState env conf cache) = @@ -401,7 +406,7 @@ evalMain = do ["-e", path] -> exec path (try . Byte.readFile) (fromBitString . Bit.bitString) ["-E", path] -> exec path (try . readFile) id - ["-y", path] -> evalYolo path putStr humanifyExpression + ["-y", path] -> evalYolo path ['-' : _] -> usage - [path ] -> evalFile path putStr humanifyExpression + [path ] -> evalFile path _ -> usage diff --git a/src/Helper.hs b/src/Helper.hs index 0c2b576..b0dea79 100644 --- a/src/Helper.hs +++ b/src/Helper.hs @@ -23,9 +23,9 @@ printContext :: Context -> String printContext (Context inp "" ) = printContext (Context inp "<unknown>") printContext (Context inp path) = p $ lines inp where - withinText = "\ESC[42mwithin\ESC[0m " - inText = "\ESC[44min\ESC[0m " - nearText = "\ESC[45mnear\ESC[0m\n" + withinText = "\ESC[106m\ESC[30mwithin\ESC[0m " + inText = "\ESC[104m\ESC[30min\ESC[0m " + nearText = "\ESC[105m\ESC[30mnear\ESC[0m\n" p [] = withinText <> show path <> "\n" p [l] = inText <> show l <> "\n" <> withinText <> show path <> "\n" p (l : ls) = @@ -35,13 +35,16 @@ printContext (Context inp path) = p $ lines inp <> "\n" errPrefix :: String -errPrefix = "\ESC[41mERROR\ESC[0m " +errPrefix = "\ESC[101m\ESC[30mERROR\ESC[0m " data Error = SyntaxError String | UndefinedIdentifier Identifier | InvalidIndex Int | FailedTest Expression Expression Expression Expression | ContextualError Error Context | SuggestSolution Error String | ImportError String instance Show Error where show (ContextualError err ctx) = show err <> "\n" <> (printContext ctx) - show (SuggestSolution err sol) = show err <> "\nPerhaps you meant: " <> sol + show (SuggestSolution err sol) = + show err + <> "\n\ESC[102m\ESC[30msuggestion\ESC[0m Perhaps you meant: " + <> sol show (SyntaxError err) = - errPrefix <> "invalid syntax\n\ESC[45mnear\ESC[0m " <> err + errPrefix <> "invalid syntax\n\ESC[105m\ESC[30mnear\ESC[0m " <> err show (UndefinedIdentifier ident) = errPrefix <> "undefined identifier " <> show ident show (InvalidIndex err) = errPrefix <> "invalid index " <> show err @@ -92,37 +95,43 @@ printBundle ParseErrorBundle {..} = <> pointer <> "\n" -data Identifier = NormalFunction String | InfixFunction String | PrefixFunction String | NamespacedFunction String Identifier +data MixfixIdentifierKind = MixfixSome String | MixfixNone + deriving (Ord, Eq) +instance Show MixfixIdentifierKind where + show (MixfixSome e) = e + show _ = "…" +data Identifier = NormalFunction String | MixfixFunction [MixfixIdentifierKind] | PrefixFunction String | NamespacedFunction String Identifier deriving (Ord, Eq) functionName :: Identifier -> String functionName = \case NormalFunction f -> f - InfixFunction i -> "(" <> i <> ")" - PrefixFunction p -> p <> "(" + MixfixFunction is -> intercalate "" $ map show is + 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 + +data Mixfix = MixfixOperator Identifier | MixfixExpression Expression + deriving (Ord, Eq) +instance Show Mixfix where + show (MixfixOperator i) = show i + show (MixfixExpression e) = show e +-- TODO: Remove Application and replace with Chain (renaming of MixfixChain) +data Expression = Bruijn Int | Function Identifier | Abstraction Expression | Application Expression Expression | MixfixChain [Mixfix] | Prefix Identifier Expression deriving (Ord, Eq) -data Command = Input String | Import String String | Test Expression Expression - deriving (Show) -data Instruction = Define Identifier Expression [Instruction] | Evaluate Expression | Comment | Commands [Command] | ContextualInstruction Instruction String - deriving (Show) instance Show Expression where 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) = - "\ESC[33m(\ESC[0m" - <> show i - <> " " - <> show le - <> " " - <> show re - <> "\ESC[33m)\ESC[0m" + show (MixfixChain ms) = + "\ESC[33m(\ESC[0m" <> (intercalate " " $ map show ms) <> "\ESC[33m)\ESC[0m" show (Prefix p e) = show p <> " " <> show e +data Command = Input String | Import String String | Test Expression Expression + deriving (Show) +data Instruction = Define Identifier Expression [Instruction] | Evaluate Expression | Comment | Commands [Command] | ContextualInstruction Instruction String + deriving (Show) data EvalConf = EvalConf { _isRepl :: Bool diff --git a/src/Parser.hs b/src/Parser.hs index 04b09e1..984c276 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -19,7 +19,7 @@ sc = void $ char ' ' -- "'" can't be in special chars because of 'c' char notation and prefixation specialChar :: Parser Char -specialChar = oneOf "!?*@.:;+-_#$%^&<>/\\|~=" +specialChar = oneOf "!?*@.,:;+-_#$%^&<>/\\|{}~=" -- lower or upper greekLetter :: Parser Char @@ -38,12 +38,19 @@ mathematicalArrow :: Parser Char mathematicalArrow = satisfy isMathematicalOperator where isMathematicalOperator c = '←' <= c && c <= '⇿' -infixOperator :: Parser Identifier -infixOperator = normalInfix <|> namespacedInfix +mixfixNone :: Parser MixfixIdentifierKind +mixfixNone = char '…' >> pure MixfixNone + +mixfixSome :: Parser MixfixIdentifierKind +mixfixSome = + MixfixSome + <$> (some $ specialChar <|> mathematicalOperator <|> mathematicalArrow) + +mixfixOperator :: Parser Identifier +mixfixOperator = normalMixfix <|> namespacedMixfix where - normalInfix = InfixFunction - <$> some (specialChar <|> mathematicalOperator <|> mathematicalArrow) - namespacedInfix = NamespacedFunction <$> dottedNamespace <*> infixOperator + normalMixfix = MixfixFunction <$> (some $ mixfixNone <|> mixfixSome) + namespacedMixfix = NamespacedFunction <$> dottedNamespace <*> mixfixOperator prefixOperator :: Parser Identifier prefixOperator = normalPrefix <|> namespacedPrefix @@ -54,13 +61,14 @@ prefixOperator = normalPrefix <|> namespacedPrefix defIdentifier :: Parser Identifier defIdentifier = - ( NormalFunction - <$> ((:) <$> (lowerChar <|> greekLetter <|> emoticon) <*> many - (alphaNumChar <|> specialChar <|> char '\'') - ) - ) - <|> (char '(' *> infixOperator <* char ')') - <|> (prefixOperator <* char '(') + try + ( NormalFunction + <$> ((:) <$> (lowerChar <|> greekLetter <|> emoticon) <*> many + (alphaNumChar <|> specialChar <|> char '\'') + ) + ) + <|> try (prefixOperator <* char '‣') + <|> mixfixOperator <?> "defining identifier" identifier :: Parser Identifier @@ -88,12 +96,6 @@ parseAbstraction = do _ <- string "]" <?> "closing abstraction" pure $ Abstraction e --- one or more singletons wrapped in coupled application -parseApplication :: Parser Expression -parseApplication = do - s <- sepEndBy1 (try parsePrefix <|> parseSingleton) sc - pure $ foldl1 Application s - parseBruijn :: Parser Expression parseBruijn = do idx <- digitChar <?> "bruijn index" @@ -139,14 +141,16 @@ parseFunction = do var <- identifier pure $ Function var -parseInfix :: Parser Expression -parseInfix = do - e1 <- parseSingleton - sc - i <- infixOperator - sc - e2 <- parseSingleton - pure $ Infix e1 i e2 +parseMixfix :: Parser Expression +parseMixfix = do + s <- sepBy1 + (try prefixAsMixfix <|> try operatorAsMixfix <|> singletonAsMixfix) + sc + pure $ MixfixChain s + where + prefixAsMixfix = MixfixExpression <$> parsePrefix + operatorAsMixfix = MixfixOperator <$> mixfixOperator + singletonAsMixfix = MixfixExpression <$> parseSingleton parsePrefix :: Parser Expression parsePrefix = do @@ -162,13 +166,12 @@ parseSingleton = <|> parseChar <|> parseAbstraction <|> try parseFunction - <|> try (parens parseInfix <?> "enclosed infix expr") - <|> (parens parseApplication <?> "enclosed application") <|> parsePrefix + <|> try (parens parseMixfix <?> "enclosed mixfix chain") parseExpression :: Parser Expression parseExpression = do - e <- try parseInfix <|> try parseApplication <|> parsePrefix + e <- parseMixfix pure e <?> "expression" parseEvaluate :: Parser Instruction @@ -183,7 +186,6 @@ parseDefine lvl = do var <- defIdentifier sc e <- parseExpression - -- TODO: Fix >1 sub-defs subs <- (try $ newline *> (many (parseBlock (lvl + 1)))) <|> (try eof >> return []) pure $ ContextualInstruction (Define var e subs) inp |