diff options
| -rw-r--r-- | src/Binary.hs | 12 | ||||
| -rw-r--r-- | src/Eval.hs | 46 | ||||
| -rw-r--r-- | src/Helper.hs | 64 | ||||
| -rw-r--r-- | src/Parser.hs | 43 | ||||
| -rw-r--r-- | src/Reducer.hs | 17 |
5 files changed, 85 insertions, 97 deletions
diff --git a/src/Binary.hs b/src/Binary.hs index a9e8028..79d3fb6 100644 --- a/src/Binary.hs +++ b/src/Binary.hs @@ -14,9 +14,9 @@ import Data.Word ( Word8 ) import Helper toBinary :: Expression -> String -toBinary (Bruijn x ) = (replicate (x + 1) '1') ++ "0" +toBinary (Bruijn x ) = replicate (x + 1) '1' ++ "0" toBinary (Abstraction e ) = "00" ++ toBinary e -toBinary (Application exp1 exp2) = "01" ++ (toBinary exp1) ++ (toBinary exp2) +toBinary (Application exp1 exp2) = "01" ++ toBinary exp1 ++ toBinary exp2 toBinary _ = invalidProgramState fromBinary' :: String -> (Expression, String) @@ -30,10 +30,10 @@ fromBinary' inp = case inp of _ -> invalidProgramState where binaryBruijn rst = - let idx = (length $ takeWhile (== '1') $ inp) - 1 + let idx = length (takeWhile (== '1') inp) - 1 in case rst of - "" -> (Bruijn $ idx, "") - _ -> (Bruijn $ idx, drop idx rst) + "" -> (Bruijn idx, "") + _ -> (Bruijn idx, drop idx rst) fromBinary :: String -> Expression fromBinary = fst . fromBinary' @@ -60,7 +60,7 @@ fromBitString bits = True -> '1' ) $ Bit.toList - $ Bit.take (Bit.length bits - (fromIntegral $ pad bits)) + $ Bit.take (Bit.length bits - fromIntegral (pad bits)) $ Bit.drop 8 bits where pad :: Bit.BitString -> Word8 diff --git a/src/Eval.hs b/src/Eval.hs index 3ee762f..5ef743c 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -12,6 +12,7 @@ import qualified Control.Monad.State.Strict as StrictState import qualified Data.BitString as Bit import qualified Data.ByteString.Lazy as Byte import Data.Function ( on ) +import Data.Functor import Data.List import qualified Data.Map as M import Data.Maybe @@ -64,7 +65,7 @@ loadFile path conf cache = do (filter (not . null) $ split "\n\n" f') (EnvState (Environment M.empty) - (conf { _isRepl = False, _evalPaths = (path : (_evalPaths conf)) }) + (conf { _isRepl = False, _evalPaths = path : _evalPaths conf }) cache ) @@ -86,7 +87,7 @@ evalFun fun (Environment sub) = state $ \env@(Environment e) -> _ -> (suggest $ lookup' e, env) -- search in global env evalAbs :: Expression -> Environment -> EvalState (Failable Expression) -evalAbs e sub = evalExp e sub >>= pure . fmap Abstraction +evalAbs e sub = evalExp e sub <&> fmap Abstraction evalApp :: Expression -> Expression -> Environment -> EvalState (Failable Expression) @@ -102,7 +103,7 @@ evalMixfix m sub = resolve (mixfixKind m) mixfixArgs longestMatching x = evalFun (MixfixFunction x) sub >>= \case Left _ -> longestMatching $ init x Right _ -> pure $ Right $ Function $ MixfixFunction x - holeCount f = length [ h | h@(MixfixNone) <- f ] + holeCount f = length [ h | h@MixfixNone <- f ] resolve f args | null [ s | s@(MixfixSome _) <- f ] = evalExp (foldl1 Application args) sub | otherwise = longestMatching f >>= \case @@ -114,7 +115,7 @@ evalMixfix m sub = resolve (mixfixKind m) mixfixArgs [] -> evalExp (foldl1 Application $ l : splitted) sub _ -> evalExp ( MixfixChain - $ (MixfixExpression $ foldl1 Application $ l : splitted) + $ MixfixExpression (foldl1 Application $ l : splitted) : chainRst ) sub @@ -183,10 +184,10 @@ evalCommand inp s@(EnvState env@(Environment envDefs) conf cache) = \case full (conf { _nicePath = path }) cache -- TODO: Fix wrong `within` in import error - cache'' <- pure $ cache - { _imported = M.insert path (Environment env') - $ M.union (_imported cache) (_imported cache') - } + let cache'' = cache + { _imported = M.insert path (Environment env') + $ M.union (_imported cache) (_imported cache') + } pure $ EnvState (Environment $ M.union env' envDefs) conf cache'' -- import => _isRepl = False Watch path -> let @@ -220,7 +221,7 @@ evalCommand inp s@(EnvState env@(Environment envDefs) conf cache) = \case rewriteFuns = M.map $ \d -> d { _flags = (_flags d) { _isImported = True } } filterImported = - M.filter $ \(EnvDef { _flags = f }) -> _isImported f == False + M.filter $ \(EnvDef { _flags = f }) -> not $ _isImported f env'' = rewriteFuns $ rewriteKeys prefix $ filterImported env' in pure $ s { _env = Environment $ M.union env'' envDefs } @@ -229,11 +230,11 @@ evalCommand inp s@(EnvState env@(Environment envDefs) conf cache) = \case full (conf { _nicePath = path }) cache -- TODO: Fix wrong `within` in import error - cache'' <- pure $ cache - { _imported = M.insert path (Environment env') - $ M.union (_imported cache) (_imported cache') - } let + cache'' = cache + { _imported = M.insert path (Environment env') + $ M.union (_imported cache) (_imported cache') + } prefix | null namespace = takeBaseName path ++ "." | namespace == "." = "" | otherwise = namespace ++ "." @@ -242,8 +243,8 @@ evalCommand inp s@(EnvState env@(Environment envDefs) conf cache) = \case rewriteFuns = M.map $ \d -> d { _flags = (_flags d) { _isImported = True } } filterImported = - M.filter $ \(EnvDef { _flags = f }) -> _isImported f == False - env'' <- pure $ rewriteFuns $ rewriteKeys prefix $ filterImported env' + M.filter $ \(EnvDef { _flags = f }) -> not $ _isImported f + env'' = rewriteFuns $ rewriteKeys prefix $ filterImported env' pure $ EnvState (Environment $ M.union env'' envDefs) conf cache'' -- import => _isRepl = False Test e1 e2 | _evalTests conf @@ -273,8 +274,7 @@ evalCommand inp s@(EnvState env@(Environment envDefs) conf cache) = \case Right e' -> do red <- reduce e' deepseq red (getTime Monotonic) - let roundSecs x = - (fromIntegral (round $ x * 1e6 :: Integer)) / 1e6 :: Double + let roundSecs x = fromIntegral (round $ x * 1e6 :: Integer) / 1e6 :: Double putStr $ show $ roundSecs @@ -290,7 +290,7 @@ showResult reduced env = humanified = humanifyExpression reduced in putStrLn $ "*> " - <> (show reduced) + <> show reduced <> (if null humanified then "" else "\n?> " <> humanified) <> (if null matching then "" else "\n#> " <> matching) @@ -305,7 +305,7 @@ evalInstruction (ContextualInstruction instr inp) s@(EnvState env conf _) rec = Left err -> print (ContextualError err $ Context inp $ _nicePath conf) >> pure s -- don't continue Right _ - | _isRepl conf -> (putStrLn $ show i <> " = " <> show e) + | _isRepl conf -> putStrLn (show i <> " = " <> show e) >> return s { _env = env' } | otherwise -> rec s { _env = env' } Evaluate e -> @@ -385,9 +385,8 @@ exec path rd conv = do repl :: EnvState -> InputT M () repl (EnvState env conf cache) = - (handleInterrupt (return $ Just "") $ withInterrupt $ getInputLine - "\ESC[36mλ\ESC[0m " - ) + handleInterrupt (return $ Just "") + (withInterrupt $ getInputLine "\ESC[36mλ\ESC[0m ") >>= \case -- TODO: Add non-parser error support for REPL Nothing -> return () Just line -> do -- setting imported [] for better debugging @@ -428,10 +427,9 @@ runRepl = do conf (EnvCache M.empty) ) - code <- StrictState.evalStateT + StrictState.evalStateT looper (EnvState (Environment M.empty) conf (EnvCache M.empty)) - return code usage :: IO () usage = do diff --git a/src/Helper.hs b/src/Helper.hs index bf5bc23..bfeeb66 100644 --- a/src/Helper.hs +++ b/src/Helper.hs @@ -16,6 +16,7 @@ import qualified Data.ByteString.Lazy as Byte import qualified Data.ByteString.Lazy.Char8 as C import Data.List import qualified Data.Map as M +import Data.Maybe ( fromMaybe ) import GHC.Generics ( Generic ) import Text.Megaparsec @@ -37,16 +38,13 @@ printContext (Context inp path) = p $ lines inp p [] = withinText <> show path <> "\n" p [l] = inText <> l <> "\n" <> withinText <> path <> "\n" p (l : ls) = - (p [l]) - <> nearText - <> (intercalate "\n" $ map (" | " ++) $ take 3 $ ls) - <> "\n" + p [l] <> nearText <> intercalate "\n" (map (" | " ++) $ take 3 ls) <> "\n" errPrefix :: String errPrefix = "\ESC[101m\ESC[30mERROR\ESC[0m " data Error = SyntaxError String | UndefinedIdentifier Identifier | UnmatchedMixfix [MixfixIdentifierKind] [Mixfix] | 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 (ContextualError err ctx) = show err <> "\n" <> printContext ctx show (SuggestSolution err sol) = show err <> "\n\ESC[102m\ESC[30msuggestion\ESC[0m Perhaps you meant " <> sol show (SyntaxError err) = @@ -56,9 +54,9 @@ instance Show Error where show (UnmatchedMixfix ks ms) = errPrefix <> "couldn't find matching mixfix for " - <> (intercalate "" (map show ks)) + <> intercalate "" (map show ks) <> "\n\ESC[105m\ESC[30mnear\ESC[0m " - <> (intercalate " " (map show ms)) + <> unwords (map show ms) show (InvalidIndex err) = errPrefix <> "invalid index " <> show err show (FailedTest exp1 exp2 red1 red2) = errPrefix @@ -87,7 +85,7 @@ printBundle ParseErrorBundle {..} = where (msline, pst') = reachOffset (errorOffset e) pst epos = pstateSourcePos pst' - outChunk = "\n\n" <> offendingLine <> (init $ parseErrorTextPretty e) + outChunk = "\n\n" <> offendingLine <> init (parseErrorTextPretty e) offendingLine = case msline of Nothing -> "" Just sline -> @@ -131,25 +129,24 @@ instance Show Mixfix where -- 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, Generic, NFData) -instance Show Expression where -- TODO: make use of precedence value? +instance Show Expression where showsPrec _ (Bruijn x) = showString "\ESC[91m" . shows x . showString "\ESC[0m" showsPrec _ (Function ident) = showString "\ESC[95m" . shows ident . showString "\ESC[0m" showsPrec _ (Abstraction e) = - showString "\ESC[36m[\ESC[0m" . showsPrec 0 e . showString - "\ESC[36m]\ESC[0m" + showString "\ESC[36m[\ESC[0m" . shows e . showString "\ESC[36m]\ESC[0m" showsPrec _ (Application exp1 exp2) = showString "\ESC[33m(\ESC[0m" - . showsPrec 0 exp1 + . shows exp1 . showString " " - . showsPrec 0 exp2 + . shows exp2 . showString "\ESC[33m)\ESC[0m" showsPrec _ (MixfixChain ms) = showString "\ESC[33m(\ESC[0m" - . foldr (.) id (map (showsPrec 0) ms) + . foldr1 (\x y -> x . showString " " . y) (map shows ms) . showString "\ESC[33m)\ESC[0m" - showsPrec _ (Prefix p e) = shows p . showString " " . showsPrec 0 e + showsPrec _ (Prefix p e) = shows p . showString " " . shows e data Command = Input String | Watch String | Import String String | Test Expression Expression | ClearState | Time Expression deriving (Show) data Instruction = Define Identifier Expression [Instruction] | Evaluate Expression | Comment | Commands [Command] | ContextualInstruction Instruction String @@ -161,7 +158,7 @@ data EvalConf = EvalConf , _nicePath :: String , _evalPaths :: [String] } -data ExpFlags = ExpFlags +newtype ExpFlags = ExpFlags { _isImported :: Bool } deriving Show @@ -171,9 +168,9 @@ data EnvDef = EnvDef , _flags :: ExpFlags } deriving Show -data Environment = Environment (M.Map Identifier EnvDef) +newtype Environment = Environment (M.Map Identifier EnvDef) deriving Show -data EnvCache = EnvCache +newtype EnvCache = EnvCache { _imported :: M.Map String Environment } type EvalState = S.State Environment @@ -196,8 +193,7 @@ listify (e : es) = Abstraction (Application (Application (Bruijn 0) e) (listify es)) binarify :: [Expression] -> Expression -binarify [] = Bruijn 2 -binarify (e : es) = Application e (binarify es) +binarify = foldr Application (Bruijn 2) encodeByte :: [Bool] -> Expression encodeByte bits = Abstraction $ Abstraction $ Abstraction $ binarify @@ -219,14 +215,12 @@ charToExpression :: Char -> Expression charToExpression ch = encodeByte $ Bit.toList $ Bit.bitStringLazy $ C.pack [ch] encodeStdin :: IO Expression -encodeStdin = do - bytes <- Byte.getContents - pure $ encodeBytes bytes +encodeStdin = encodeBytes <$> Byte.getContents unlistify :: Expression -> Maybe [Expression] unlistify (Abstraction (Abstraction (Bruijn 0))) = Just [] unlistify (Abstraction (Application (Application (Bruijn 0) e) es)) = - (:) <$> Just e <*> (unlistify es) + (:) <$> Just e <*> unlistify es unlistify _ = Nothing unpairify :: Expression -> Maybe [Expression] @@ -236,8 +230,8 @@ unpairify _ = Nothing decodeByte :: Expression -> Maybe [Bool] decodeByte (Abstraction (Abstraction (Abstraction es))) = decodeByte es -decodeByte (Application (Bruijn 0) es) = (:) <$> Just False <*> (decodeByte es) -decodeByte (Application (Bruijn 1) es) = (:) <$> Just True <*> (decodeByte es) +decodeByte (Application (Bruijn 0) es) = (:) <$> Just False <*> decodeByte es +decodeByte (Application (Bruijn 1) es) = (:) <$> Just True <*> decodeByte es decodeByte (Bruijn 2 ) = Just [] decodeByte _ = Nothing @@ -290,21 +284,19 @@ maybeHumanifyExpression e = <|> humanifyPair e humanifyExpression :: Expression -> String -humanifyExpression e = case maybeHumanifyExpression e of - Nothing -> "" - Just h -> h +humanifyExpression e = fromMaybe "" (maybeHumanifyExpression e) humanifyList :: Expression -> Maybe String humanifyList e = do es <- unlistify e - let conv x = maybe (show x) id (maybeHumanifyExpression x) + let conv x = fromMaybe (show x) (maybeHumanifyExpression x) m = map conv es pure $ "{" <> intercalate ", " m <> "}" humanifyPair :: Expression -> Maybe String humanifyPair e = do es <- unpairify e - let conv x = maybe (show x) id (maybeHumanifyExpression x) + let conv x = fromMaybe (show x) (maybeHumanifyExpression x) m = map conv es pure $ "<" <> intercalate " : " m <> ">" @@ -323,7 +315,7 @@ decimalToTernary n = -- Decimal to binary encoding decimalToBinary :: Integer -> Expression decimalToBinary n | n < 0 = decimalToBinary 0 -decimalToBinary n | otherwise = Abstraction $ Abstraction $ Abstraction $ gen n + | otherwise = Abstraction $ Abstraction $ Abstraction $ gen n where gen 0 = Bruijn 2 gen n' = Application (Bruijn $ fromIntegral $ mod n' 2) (gen $ div n' 2) @@ -331,7 +323,7 @@ decimalToBinary n | otherwise = Abstraction $ Abstraction $ Abstraction $ gen n -- Decimal to unary (church) encoding decimalToUnary :: Integer -> Expression decimalToUnary n | n < 0 = decimalToUnary 0 -decimalToUnary n | otherwise = Abstraction $ Abstraction $ gen n + | otherwise = Abstraction $ Abstraction $ gen n where gen 0 = Bruijn 0 gen n' = Application (Bruijn 1) (gen (n' - 1)) @@ -347,7 +339,7 @@ unaryToDecimal e = do resolve' (Application x@(Bruijn _) (Bruijn 0)) = (:) <$> multiplier x <*> Just [] resolve' (Application x@(Bruijn _) xs@(Application _ _)) = - (:) <$> (multiplier x) <*> (resolve' xs) + (:) <$> multiplier x <*> resolve' xs resolve' _ = Nothing resolve (Abstraction (Abstraction n)) = resolve' n resolve _ = Nothing @@ -364,7 +356,7 @@ binaryToDecimal e = do resolve' (Application x@(Bruijn _) (Bruijn 2)) = (:) <$> multiplier x <*> Just [] resolve' (Application x@(Bruijn _) xs@(Application _ _)) = - (:) <$> (multiplier x) <*> (resolve' xs) + (:) <$> multiplier x <*> resolve' xs resolve' _ = Nothing resolve (Abstraction (Abstraction (Abstraction n))) = resolve' n resolve _ = Nothing @@ -382,7 +374,7 @@ ternaryToDecimal e = do resolve' (Application x@(Bruijn _) (Bruijn 3)) = (:) <$> multiplier x <*> Just [] resolve' (Application x@(Bruijn _) xs@(Application _ _)) = - (:) <$> (multiplier x) <*> (resolve' xs) + (:) <$> multiplier x <*> resolve' xs resolve' _ = Nothing resolve (Abstraction (Abstraction (Abstraction (Abstraction n)))) = resolve' n diff --git a/src/Parser.hs b/src/Parser.hs index b82a266..d796682 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -25,7 +25,7 @@ greekLetter = satisfy isGreek emoticon :: Parser Char emoticon = satisfy isEmoticon - where isEmoticon c = ('\128512' <= c && c <= '\128591') + where isEmoticon c = '\128512' <= c && c <= '\128591' mathematicalOperator :: Parser Char mathematicalOperator = @@ -33,8 +33,8 @@ mathematicalOperator = <|> satisfy isMiscMathematicalAUnicodeBlock <|> oneOf "¬₀₁₂₃₄₅₆₇₈₉₊₋₌₍₎⁰¹²³⁴⁵⁶⁷⁸⁹⁺⁻⁼⁽⁾" where - isMathematicalUnicodeBlock c = ('∀' <= c && c <= '⋿') - isMiscMathematicalAUnicodeBlock c = ('⟀' <= c && c <= '⟯') + isMathematicalUnicodeBlock c = '∀' <= c && c <= '⋿' + isMiscMathematicalAUnicodeBlock c = '⟀' <= c && c <= '⟯' mathematicalArrow :: Parser Char mathematicalArrow = satisfy isMathematicalOperator @@ -51,12 +51,12 @@ mixfixNone :: Parser MixfixIdentifierKind mixfixNone = char '…' >> pure MixfixNone mixfixSome :: Parser MixfixIdentifierKind -mixfixSome = MixfixSome <$> (some specialChar) +mixfixSome = MixfixSome <$> some specialChar mixfixOperator :: Parser Identifier mixfixOperator = normalMixfix <|> namespacedMixfix where - normalMixfix = MixfixFunction <$> (some $ mixfixNone <|> mixfixSome) + normalMixfix = MixfixFunction <$> some (mixfixNone <|> mixfixSome) namespacedMixfix = NamespacedFunction <$> dottedNamespace <*> mixfixOperator prefixOperator :: Parser Identifier @@ -117,9 +117,9 @@ parseNumeral :: Parser Expression parseNumeral = do _ <- string "(" <?> "number start" num <- number <?> "signed number" - base <- (try (oneOf "ubt") <|> return 't') + base <- try (oneOf "ubt") <|> return 't' _ <- string ")" <?> "number end" - pure $ (f base) num + pure $ f base num where f 't' = decimalToTernary f 'b' = decimalToBinary @@ -142,7 +142,7 @@ parseString = do between (char '\"') (char '\"') - (some $ (char '\\' *> specialEscape) <|> (satisfy (`notElem` "\"\\"))) + (some $ (char '\\' *> specialEscape) <|> satisfy (`notElem` "\"\\")) <?> "quoted string" pure $ stringToExpression str @@ -156,9 +156,7 @@ parseChar = do pure $ charToExpression ch parseFunction :: Parser Expression -parseFunction = do - var <- identifier - pure $ Function var +parseFunction = Function <$> identifier parseMixfix :: Parser Expression parseMixfix = do @@ -237,7 +235,7 @@ parseTypeExpression = parseFunctionType <?> "type expression" parseDefineType :: Parser () parseDefineType = do - (try $ char '⧗' <* sc *> parseTypeExpression) <|> (return ()) + try (char '⧗' <* sc *> parseTypeExpression) <|> return () parseDefine :: Int -> Parser Instruction parseDefine lvl = do @@ -247,7 +245,7 @@ parseDefine lvl = do e <- parseExpression _ <- parseDefineType subs <- - (try $ newline *> (many $ parseBlock $ lvl + 1)) <|> (try eof >> return []) + try (newline *> many (parseBlock $ lvl + 1)) <|> (try eof >> return []) pure $ ContextualInstruction (Define var e subs) inp parseReplDefine :: Parser Instruction @@ -280,7 +278,7 @@ parseImport :: Parser Command parseImport = do _ <- string ":import" <* sc <?> "import instruction" path <- importPath - ns <- (try $ sc *> (namespace <|> string ".")) <|> (eof >> return "") + ns <- try (sc *> (namespace <|> string ".")) <|> (eof >> return "") pure $ Import (path ++ ".bruijn") ns parseInput :: Parser Command @@ -321,9 +319,8 @@ parseCommandBlock = do parseDefBlock :: Int -> Parser Instruction parseDefBlock lvl = - (sepEndBy parseComment newline) - *> string (replicate lvl '\t') - *> (try $ parseDefine lvl) + sepEndBy parseComment newline *> string (replicate lvl '\t') *> try + (parseDefine lvl) parseBlock :: Int -> Parser Instruction parseBlock lvl = @@ -332,10 +329,10 @@ parseBlock lvl = parseReplLine :: Parser Instruction parseReplLine = try parseReplDefine -- TODO: This is kinda hacky - <|> ((Commands . (: [])) <$> try parseTest) - <|> ((Commands . (: [])) <$> try parseInput) - <|> ((Commands . (: [])) <$> try parseWatch) - <|> ((Commands . (: [])) <$> try parseImport) - <|> ((Commands . (: [])) <$> try parseTime) - <|> ((Commands . (: [])) <$> try parseClearState) + <|> (Commands . (: []) <$> try parseTest) + <|> (Commands . (: []) <$> try parseInput) + <|> (Commands . (: []) <$> try parseWatch) + <|> (Commands . (: []) <$> try parseImport) + <|> (Commands . (: []) <$> try parseTime) + <|> (Commands . (: []) <$> try parseClearState) <|> try parseEvaluate diff --git a/src/Reducer.hs b/src/Reducer.hs index ba63675..cfa9a35 100644 --- a/src/Reducer.hs +++ b/src/Reducer.hs @@ -8,14 +8,15 @@ import Control.Concurrent.MVar import Data.List ( elemIndex ) import Data.Map ( Map ) import qualified Data.Map as Map +import Data.Maybe ( fromMaybe ) import Helper type Store = Map Int Box type Stack = [Redex] -data NameGen = NameGen Int +newtype NameGen = NameGen Int data BoxValue = Todo Redex | Done Redex | Empty -data Box = Box (MVar BoxValue) +newtype Box = Box (MVar BoxValue) data Rvar = Num Int | Hole data Redex = Rabs Int Redex | Rapp Redex Redex | Rvar Rvar | Rclosure Redex Store | Rcache Box Redex data Conf = Econf NameGen Redex Store Stack | Cconf NameGen Stack Redex | End @@ -46,12 +47,12 @@ fromRedex = convertWorker [] let lhs = convertWorker es l rhs = convertWorker es r in Application lhs rhs - convertWorker es (Rvar (Num n)) = Bruijn $ maybe n id (elemIndex n es) + convertWorker es (Rvar (Num n)) = Bruijn $ fromMaybe n (elemIndex n es) convertWorker _ _ = invalidProgramState transition :: Conf -> IO Conf transition (Econf g (Rapp u v) e s) = - pure $ Econf g u e ((Rapp (Rvar Hole) (Rclosure v e)) : s) + pure $ Econf g u e (Rapp (Rvar Hole) (Rclosure v e) : s) transition (Econf g (Rabs x t) e s) = do box <- newMVar Empty pure $ Cconf g s (Rcache (Box box) (Rclosure (Rabs x t) e)) @@ -60,7 +61,7 @@ transition (Econf g (Rvar (Num x)) e s) = do let b@(Box m) = Map.findWithDefault (Box def) x e rd <- readMVar m case rd of - Todo (Rclosure v e') -> pure $ Econf g v e' ((Rcache b (Rvar Hole)) : s) + Todo (Rclosure v e') -> pure $ Econf g v e' (Rcache b (Rvar Hole) : s) Done t -> pure $ Cconf g s t _ -> invalidProgramState transition (Cconf g ((Rcache (Box m) (Rvar Hole)) : s) t) = do @@ -80,10 +81,10 @@ transition (Cconf g s (Rcache (Box m) (Rclosure (Rabs x t) e))) = do pure $ Econf g' t (Map.insert x (Box box) e) - ((Rabs x1 (Rvar Hole)) : (Rcache (Box m) (Rvar Hole)) : s) + (Rabs x1 (Rvar Hole) : Rcache (Box m) (Rvar Hole) : s) Todo _ -> invalidProgramState transition (Cconf g ((Rapp (Rvar Hole) (Rclosure v e)) : s) t) = - pure $ Econf g v e ((Rapp t (Rvar Hole)) : s) + pure $ Econf g v e (Rapp t (Rvar Hole) : s) transition (Cconf g ((Rapp t (Rvar Hole)) : s) v) = pure $ Cconf g s (Rapp t v) transition (Cconf g ((Rabs x1 (Rvar Hole)) : s) v) = pure $ Cconf g s (Rabs x1 v) @@ -101,7 +102,7 @@ loadTerm t = Econf (NameGen 1000000) t Map.empty [] reduce :: Expression -> IO Expression reduce e = do - redex <- pure $ toRedex e + let redex = toRedex e forEachState (loadTerm redex) transition >>= \case Cconf _ [] v -> pure $ fromRedex v _ -> invalidProgramState |