General refactor for legibility

Priming to update all source to lhs and document extensively

src/Eval.hs

@@ -8,110 +8,87 @@ import Data.Map  (Map)
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 
-evalSingle :: Map String T -> TricuAST -> Map String T
+evalSingle :: Env -> TricuAST -> Env
-evalSingle env term = case term of
+evalSingle env term
-  SFunc name [] body ->
+  | SFunc name [] body <- term =
-    let lineNoLambda = eliminateLambda body
+      let res = evalAST env $ elimLambda body
-        result = evalAST env lineNoLambda
+      in Map.insert "__result" res (Map.insert name res env)
-    in Map.insert "__result" result (Map.insert name result env)
+  | SLambda _ body <- term     = Map.insert "__result" (evalAST env body) env
-  SLambda _ body ->
+  | SApp func arg <- term      = Map.insert "__result"
-    let result = evalAST env body
+      (apply (evalAST env $ elimLambda func) (evalAST env $ elimLambda arg)) env
-    in Map.insert "__result" result env
+  | SVar name <- term          = case Map.lookup name env of
-  SApp func arg ->
+      Just v  -> Map.insert "__result" v env
-    let result = apply (evalAST env $ eliminateLambda func) (evalAST env $ eliminateLambda arg)
-    in Map.insert "__result" result env
-  SVar name ->
-    case Map.lookup name env of
-      Just value -> Map.insert "__result" value env
       Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined"
-  _ ->
+  | otherwise                  = Map.insert "__result" (evalAST env term) env
-    let result = evalAST env term
-    in Map.insert "__result" result env
 
-evalTricu :: Map String T -> [TricuAST] -> Map String T
+evalTricu :: Env -> [TricuAST] -> Env
 evalTricu env list = evalTricu' env (filter (/= SEmpty) list)
   where
-  evalTricu' :: Map String T -> [TricuAST] -> Map String T
+    evalTricu' :: Env -> [TricuAST] -> Env
-  evalTricu' env [] = env
+    evalTricu' env [] = env
-  evalTricu' env [lastLine] =
+    evalTricu' env [s] =
-    let lastLineNoLambda = eliminateLambda lastLine
+      let updatedEnv = evalSingle env $ elimLambda s
-        updatedEnv = evalSingle env lastLineNoLambda
+      in Map.insert "__result" (result updatedEnv) updatedEnv
-    in Map.insert "__result" (result updatedEnv) updatedEnv
+    evalTricu' env (x:xs) = evalTricu (evalSingle env $ elimLambda x) xs
-  evalTricu' env (line:rest) =
-    let lineNoLambda = eliminateLambda line
-        updatedEnv = evalSingle env lineNoLambda
-    in evalTricu updatedEnv rest
 
-evalAST :: Map String T -> TricuAST -> T
+evalAST :: Env -> TricuAST -> T
-evalAST env term = case term of
+evalAST env term
-  SVar name -> case Map.lookup name env of
+  | SVar   name <- term = evalVar name
-    Just value -> value
+  | TLeaf       <- term = Leaf
-    Nothing -> errorWithoutStackTrace $ "Variable " ++ name ++ " not defined"
+  | TStem  t    <- term = Stem (evalAST env t)
-  TLeaf -> Leaf
+  | TFork  t u  <- term = Fork (evalAST env t) (evalAST env u)
-  TStem t -> Stem (evalAST env t)
+  | SApp   t u  <- term = apply (evalAST env t) (evalAST env u)
-  TFork t1 t2 -> Fork (evalAST env t1) (evalAST env t2)
+  | SStr   s    <- term = ofString s
-  SApp t1 t2 -> apply (evalAST env t1) (evalAST env t2)
+  | SInt   n    <- term = ofNumber n
-  SStr str -> ofString str
+  | SList  xs   <- term = ofList (map (evalAST env) xs)
-  SInt num -> ofNumber num
+  | SEmpty      <- term = Leaf
-  SList elems -> ofList (map (evalAST env) elems)
+  | otherwise           = errorWithoutStackTrace "Unexpected AST term"
-  SEmpty -> Leaf
+    where
-  SFunc name args body ->
+      evalVar name = Map.findWithDefault 
-    errorWithoutStackTrace $ "Unexpected function definition " ++ name
+        (errorWithoutStackTrace $ "Variable " ++ name ++ " not defined")
-  SLambda {} -> errorWithoutStackTrace "Internal error: SLambda found in evalAST after elimination."
+        name env
-
-eliminateLambda :: TricuAST -> TricuAST
-eliminateLambda (SLambda (v:vs) body)
-  | null vs = lambdaToT v (eliminateLambda body)
-  | otherwise = eliminateLambda (SLambda [v] (SLambda vs body))
-eliminateLambda (SApp f arg) = SApp (eliminateLambda f) (eliminateLambda arg)
-eliminateLambda (TStem t) = TStem (eliminateLambda t)
-eliminateLambda (TFork l r) = TFork (eliminateLambda l) (eliminateLambda r)
-eliminateLambda (SList xs) = SList (map eliminateLambda xs)
-eliminateLambda other = other
 
 -- https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf
 -- Chapter 4: Lambda-Abstraction
-lambdaToT :: String -> TricuAST -> TricuAST
+elimLambda :: TricuAST -> TricuAST
-lambdaToT x (SVar y)
+elimLambda = go
-  | x == y = tI
+  where
-lambdaToT x (SVar y)
+    go (SLambda (v:vs) body)
-  | x /= y = SApp tK (SVar y)
+      | null vs              = toSKI v (elimLambda body)
-lambdaToT x t
+      | otherwise            = elimLambda (SLambda [v] (SLambda vs body))
-  | not (isFree x t) = SApp tK t
+    go (SApp    f g        ) = SApp  (elimLambda f) (elimLambda g)
-lambdaToT x (SApp n u)
+    go (TStem   t          ) = TStem (elimLambda t)
-  | not (isFree x (SApp n u)) = SApp tK (SApp (eliminateLambda n) (eliminateLambda u))
+    go (TFork   l r        ) = TFork (elimLambda l) (elimLambda r)
-lambdaToT x (SApp n u) = SApp (SApp tS (lambdaToT x (eliminateLambda n))) (lambdaToT x (eliminateLambda u))
+    go (SList   x          ) = SList (map elimLambda x)
-lambdaToT x body
+    go x                     = x
-  | not (isFree x body) = SApp tK body
-  | otherwise = SApp (SApp tS (lambdaToT x body)) TLeaf
 
-freeVars :: TricuAST -> Set.Set String
+    toSKI x (SVar y)
-freeVars (SVar v) = Set.singleton v
+      | x == y    = _I
-freeVars (SInt _) = Set.empty
+      | otherwise = SApp _K (SVar y)
-freeVars (SStr _) = Set.empty
+    toSKI x t@(SApp n u)
-freeVars (SList xs) = foldMap freeVars xs
+      | not (isFree x t) = SApp _K (SApp (elimLambda n) (elimLambda u))
-freeVars (SApp f arg) = freeVars f <> freeVars arg
+      | otherwise        = SApp (SApp _S (toSKI x (elimLambda n))) (toSKI x (elimLambda u))
-freeVars TLeaf = Set.empty
+    toSKI x t
-freeVars (SFunc _ _ b) = freeVars b
+      | not (isFree x t) = SApp _K t
-freeVars (TStem t) = freeVars t
+      | otherwise        = SApp (SApp _S (toSKI x t)) TLeaf
-freeVars (TFork l r) = freeVars l <> freeVars r
-freeVars (SLambda vs b) = foldr Set.delete (freeVars b) vs
 
-isFree :: String -> TricuAST -> Bool
+    _S = parseSingle "t (t (t t t)) t"
-isFree x = Set.member x . freeVars
+    _K = parseSingle "t t"
+    _I = parseSingle "t (t (t t)) t"
     
--- We need the SKI operators in an unevaluated TricuAST tree form so that we
+    isFree x = Set.member x . freeVars
--- can keep the evaluation functions straightforward
+    freeVars (SVar    v    ) = Set.singleton v
-tI :: TricuAST
+    freeVars (SInt    _    ) = Set.empty
-tI = SApp (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf))) TLeaf
+    freeVars (SStr    _    ) = Set.empty
+    freeVars (SList   s    ) = foldMap freeVars s
+    freeVars (SApp    f a  ) = freeVars f <> freeVars a
+    freeVars (TLeaf        ) = Set.empty
+    freeVars (SFunc   _ _ b) = freeVars b
+    freeVars (TStem   t    ) = freeVars t
+    freeVars (TFork   l r  ) = freeVars l <> freeVars r
+    freeVars (SLambda v b  ) = foldr Set.delete (freeVars b) v
 
-tK :: TricuAST
+result :: Env -> T
-tK = SApp TLeaf TLeaf
-
-tS :: TricuAST
-tS = SApp (SApp TLeaf (SApp TLeaf (SApp (SApp TLeaf TLeaf) TLeaf))) TLeaf
-
-result :: Map String T -> T
 result r = case Map.lookup "__result" r of
   Just a -> a
   Nothing -> errorWithoutStackTrace "No __result field found in provided environment"

src/Parser.hs

@@ -17,18 +17,20 @@ type AltParser = Parsec Void String
 parseTricu :: String -> [TricuAST]
 parseTricu input
   | null tokens = []
-  | otherwise = map parseSingle tokens
+  | otherwise   = map parseSingle tokens
   where
-    tokens = case lexTricu input of
+    tokens
-      [] -> []
+      | null (lexTricu input) = []
-      tokens -> lines input
+      | otherwise             = lines input
 
 parseSingle :: String -> TricuAST
-parseSingle input = case lexTricu input of
+parseSingle input
-  [] -> SEmpty
+  | null tokens          = SEmpty
-  tokens -> case runParser parseExpression "" tokens of
+  | Left  err  <- parsed = error $ handleParseError err
-    Left err -> error $ handleParseError err
+  | Right ast  <- parsed = ast
-    Right ast -> ast
+  where
+    tokens = lexTricu input
+    parsed = runParser parseExpression "" tokens
 
 parseExpression :: Parser TricuAST
 parseExpression = choice
@@ -115,10 +117,10 @@ parseTreeTerm = do
   rest <- many parseTreeLeafOrParenthesized
   pure $ foldl combine base rest
   where
-    combine acc next = case acc of
+    combine acc next
-      TLeaf -> TStem next
+      | TLeaf     <- acc = TStem next
-      TStem t -> TFork t next
+      | TStem t   <- acc = TFork t next
-      TFork _ _ -> TFork acc next
+      | TFork _ _ <- acc = TFork acc next
 
 parseTreeLeafOrParenthesized :: Parser TricuAST
 parseTreeLeafOrParenthesized = choice
@@ -181,9 +183,9 @@ parseSingleItem :: Parser TricuAST
 parseSingleItem = do
   token <- satisfy isListItem
   case token of
-    LIdentifier name -> return (SVar name)
+    _ | LIdentifier name <- token -> return (SVar name)
-    LKeywordT -> return TLeaf
+      | LKeywordT <- token        -> return TLeaf
-    _ -> fail "Unexpected token in list item"
+      | otherwise                 -> fail "Unexpected token in list item"
 
 isListItem :: LToken -> Bool
 isListItem (LIdentifier _) = True
@@ -254,9 +256,11 @@ parseTernaryFork = do
   pure $ TFork term1 term2
 
 parseTernary :: String -> Either String TricuAST
-parseTernary input = case runParser (parseTernaryTerm <* eof) "" input of
+parseTernary input
-  Left err -> Left (errorBundlePretty err)
+  | Left err <- result  = Left (errorBundlePretty err)
-  Right ast -> Right ast
+  | Right ast <- result = Right ast
+  where
+    result = runParser (parseTernaryTerm <* eof) "" input
 
 -- Error Handling
 handleParseError :: ParseErrorBundle [LToken] Void -> String

src/REPL.hs

@@ -20,37 +20,36 @@ repl env = runInputT defaultSettings (loop env)
     loop :: Env -> InputT IO ()
     loop env = do
       minput <- getInputLine "tricu < "
-      case minput of
+      if
-        Nothing -> outputStrLn "Exiting tricu"
+        | Nothing <- minput                     -> outputStrLn "Exiting tricu"
-        Just s -> case strip s of 
+        | Just s  <- minput, strip s == "!exit" -> outputStrLn "Exiting tricu"
-          "!exit" -> outputStrLn "Exiting tricu"
+        | Just s  <- minput, strip s == ""      -> do
-          "!load" -> do
+          outputStrLn ""
-            path <- getInputLine "File path to load < "
+          loop env
-            case path of
+        | Just s  <- minput, strip s == "!load" -> do
-              Nothing -> do
+          path <- getInputLine "File path to load < "
-                outputStrLn "No input received; stopping import."
+          if
-                loop env
+            | Nothing <- path -> do
-              Just path -> do
+              outputStrLn "No input received; stopping import."
-                loadedEnv <- liftIO $ evaluateFileWithContext env (strip path)
+              loop env
-                loop $ Map.delete "__result" (Map.union loadedEnv env)
+            | Just p  <- path -> do
-          "" -> do
+              loadedEnv <- liftIO $ evaluateFileWithContext env (strip p) `catch` \e -> errorHandler env e
-            outputStrLn ""
+              loop $ Map.delete "__result" (Map.union loadedEnv env)
-            loop env
+        | Just s <- minput -> do
-          input -> do
+          if
-            case (take 2 input) of 
+            | take 2 s == "--" -> loop env
-              "--" -> loop env
+            | otherwise -> do
-              _ -> do
+              newEnv <- liftIO $ processInput env s `catch` errorHandler env
-                newEnv <- liftIO $ (processInput env input `catch` errorHandler env)
+              loop newEnv
-                loop newEnv
 
     processInput :: Env -> String -> IO Env
     processInput env input = do
-      let asts = parseTricu input
+      let asts   = parseTricu input
           newEnv = evalTricu env asts
-      case Map.lookup "__result" newEnv of
+      if
-        Just r -> do
+        | Just r <- Map.lookup "__result" newEnv -> do
           putStrLn $ "tricu > " ++ decodeResult r
-        Nothing -> return ()
+        | otherwise -> return ()
       return newEnv
     
     errorHandler :: Env -> SomeException -> IO (Env)
@@ -62,10 +61,8 @@ repl env = runInputT defaultSettings (loop env)
     strip = dropWhileEnd isSpace . dropWhile isSpace
 
 decodeResult :: T -> String
-decodeResult tc = case toNumber tc of
+decodeResult tc
-  Right num -> show num
+  | Right num  <- toNumber tc = show num
-  Left _ -> case toString tc of
+  | Right str  <- toString tc = "\"" ++ str ++ "\""
-    Right str -> "\"" ++ str ++ "\""
+  | Right list <- toList tc   = "[" ++ intercalate ", " (map decodeResult list) ++ "]"
-    Left _ -> case toList tc of
+  | otherwise                 = formatResult TreeCalculus tc
-      Right list -> "[" ++ intercalate ", " (map decodeResult list) ++ "]"
-      Left _ -> formatResult TreeCalculus tc

src/Research.hs

@@ -28,7 +28,7 @@ data TricuAST
   | SEmpty
   deriving (Show, Eq, Ord)
 
--- Tokens from Lexer
+-- Lexer Tokens
 data LToken
   = LKeywordT
   | LIdentifier String
@@ -61,19 +61,6 @@ apply (Fork (Fork a1 a2) a3) Leaf       = a1
 apply (Fork (Fork a1 a2) a3) (Stem u)   = apply a2 u
 apply (Fork (Fork a1 a2) a3) (Fork u v) = apply (apply a3 u) v
 
--- SKI Combinators
-_S :: T
-_S = Fork (Stem (Fork Leaf Leaf)) Leaf
-
-_K :: T
-_K = Stem Leaf
-
--- Identity
--- We use the "point-free" style which drops a redundant node
--- Full I form (SKK): Fork (Stem (Stem Leaf)) (Stem Leaf)
-_I :: T
-_I = Fork (Stem (Stem Leaf)) Leaf 
-
 -- Booleans
 _false :: T
 _false = Leaf

test/Spec.hs

@@ -31,7 +31,6 @@ tests = testGroup "Tricu Tests"
   , lambdaEvalTests
   , libraryTests
   , fileEvaluationTests
-  , propertyTests
   ]
 
 lexerTests :: TestTree
@@ -414,13 +413,3 @@ fileEvaluationTests = testGroup "Evaluation tests"
       res <- liftIO $ evaluateFileWithContext library "./test/string.tri"
       decodeResult (result res) @?= "\"String test!\""
   ]
-
-propertyTests :: TestTree
-propertyTests = testGroup "Property Tests"
-  [ testProperty "Lexing and parsing round-trip" $ \input ->
-      case runParser tricuLexer "" input of
-        Left _ -> property True
-        Right tokens -> case runParser parseExpression "" tokens of
-          Left _ -> property True
-          Right ast -> parseSingle input === ast
-  ]

tricu.cabal

@@ -18,6 +18,7 @@ executable tricu
       src
   default-extensions:
       DeriveDataTypeable
+      MultiWayIf
       OverloadedStrings
   ghc-options: -threaded -rtsopts -with-rtsopts=-N -optl-pthread -fPIC
   build-depends:
@@ -43,6 +44,7 @@ test-suite tricu-tests
   hs-source-dirs:      test, src
   default-extensions:
       DeriveDataTypeable
+      MultiWayIf
       OverloadedStrings
   build-depends:       
     base