REPL namespaces; lib function for pattern matching

Adds support for REPL namespacing, primarily to avoid `main` collisions.
Also adds a library function for an ergonomic pattern matching function
that I've been noodling on. I might explore ways to make list syntax
less annoying specifically for pattern matching like this.

.gitignore

@@ -9,3 +9,4 @@
 WD
 bin/
 dist*
+.tricu_history

flake.nix

@@ -34,6 +34,7 @@
         devShells.default = pkgs.mkShell {
           buildInputs = with pkgs; [
             haskellPackages.cabal-install
+            haskellPackages.ghc-events
             haskellPackages.ghcid
             customGHC
             upx

lib/base.tri

@@ -31,7 +31,7 @@ lOr = (triage
   (\_ _   : true)
   (\_ _ _ : true))
 
-matchPair = \a   : triage _ _ a
+matchPair = \a : triage _ _ a
 
 not? = matchBool false true
 and? = matchBool id (\_ : false)

lib/patterns.tri

@@ -0,0 +1,35 @@
+!import "list.tri" !Local
+
+match_ = y (\self value patterns :
+  triage
+    t
+    (\_ : t)
+    (\pattern rest :
+      triage
+        t
+        (\_ : t)
+        (\test result :
+          if (test value)
+             (result value)
+             (self value rest))
+        pattern)
+    patterns)
+
+match = (\value patterns :
+  match_ value (map (\sublist :
+    pair (head sublist) (head (tail sublist)))
+    patterns))
+
+otherwise = const (t t)
+
+-- matchExample = (\x : match x [[(equal? 1)  (\_ : "one")]
+--                               [(equal? 2)  (\_ : "two")]
+--                               [(equal? 3)  (\_ : "three")]
+--                               [(equal? 4)  (\_ : "four")]
+--                               [(equal? 5)  (\_ : "five")]
+--                               [(equal? 6)  (\_ : "six")]
+--                               [(equal? 7)  (\_ : "seven")]
+--                               [(equal? 8)  (\_ : "eight")]
+--                               [(equal? 9)  (\_ : "nine")]
+--                               [(equal? 10) (\_ : "ten")]
+--                               [ otherwise  (\_ : "I ran out of fingers!")]])

src/Eval.hs

@@ -19,16 +19,16 @@ evalSingle env term
       Nothing ->
         let res = evalAST env body
         in Map.insert "!result" res (Map.insert name res env)
-  | SApp func arg <- term 
+  | SApp func arg <- term
   = let res = apply (evalAST env func) (evalAST env arg)
       in Map.insert "!result" res env
-  | SVar name <- term 
+  | SVar name <- term
   = case Map.lookup name env of
         Just v  -> Map.insert "!result" v env
         Nothing ->
           errorWithoutStackTrace $ "Variable `" ++ name ++ "` not defined\n\
           \This error should never occur here. Please report this as an issue."
-  | otherwise 
+  | otherwise
   = Map.insert "!result" (evalAST env term) env
 
 evalTricu :: Env -> [TricuAST] -> Env

src/FileEval.hs

@@ -6,6 +6,7 @@ import Parser
 import Research
 
 import Data.List       (partition)
+import Data.Maybe      (mapMaybe)
 import Control.Monad   (foldM)
 import System.IO
 import System.FilePath (takeDirectory, normalise, (</>))
@@ -13,6 +14,26 @@ import System.FilePath (takeDirectory, normalise, (</>))
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 
+extractMain :: Env -> Either String T
+extractMain env =
+  case Map.lookup "main" env of
+    Just result -> Right result
+    Nothing -> Left "No `main` function detected"
+
+processImports :: Set.Set FilePath -> FilePath -> FilePath -> [TricuAST]
+                 -> Either String ([TricuAST], [(FilePath, String, FilePath)])
+processImports seen base currentPath asts =
+  let (imports, nonImports) = partition isImp asts
+      importPaths = mapMaybe getImportInfo imports
+  in if currentPath `Set.member` seen
+     then Left $ "Encountered cyclic import: " ++ currentPath
+     else Right (nonImports, importPaths)
+  where
+    isImp (SImport _ _) = True
+    isImp _ = False
+    getImportInfo (SImport p n) = Just (p, n, makeRelativeTo currentPath p)
+    getImportInfo _ = Nothing
+
 evaluateFileResult :: FilePath -> IO T
 evaluateFileResult filePath = do
   contents <- readFile filePath
@@ -20,11 +41,11 @@ evaluateFileResult filePath = do
   case parseProgram tokens of
     Left err -> errorWithoutStackTrace (handleParseError err)
     Right ast -> do
-      ast <- preprocessFile filePath
+      processedAst <- preprocessFile filePath
-      let finalEnv = evalTricu Map.empty ast
+      let finalEnv = evalTricu Map.empty processedAst
-      case Map.lookup "main" finalEnv of
+      case extractMain finalEnv of
-        Just finalResult -> return finalResult
+        Right result -> return result
-        Nothing -> errorWithoutStackTrace "No `main` function detected"
+        Left err -> errorWithoutStackTrace err
 
 evaluateFile :: FilePath -> IO Env
 evaluateFile filePath = do
@@ -50,37 +71,25 @@ preprocessFile :: FilePath -> IO [TricuAST]
 preprocessFile p = preprocessFile' Set.empty p p
 
 preprocessFile' :: Set.Set FilePath -> FilePath -> FilePath -> IO [TricuAST]
-preprocessFile' s b p
+preprocessFile' seen base currentPath = do
-  | p `Set.member` s =
+  contents <- readFile currentPath
-      errorWithoutStackTrace $ "Encountered cyclic import: " ++ p
+  let tokens = lexTricu contents
-  | otherwise = do
+  case parseProgram tokens of
-      c <- readFile p
+    Left err -> errorWithoutStackTrace (handleParseError err)
-      let t = lexTricu c
+    Right ast ->
-      case parseProgram t of
+      case processImports seen base currentPath ast of
-        Left e -> errorWithoutStackTrace (handleParseError e)
+        Left err -> errorWithoutStackTrace err
-        Right a -> do
+        Right (nonImports, importPaths) -> do
-          let (i, n) = partition isImp a
+          let seen' = Set.insert currentPath seen
-          let s' = Set.insert p s
+          imported <- concat <$> mapM (processImportPath seen' base) importPaths
-          r <- concat <$>
+          pure $ imported ++ nonImports
-            mapM (procImp s' "" p) i
-          pure $ r ++ n
   where
-    isImp :: TricuAST -> Bool
+    processImportPath seen base (path, name, importPath) = do
+      ast <- preprocessFile' seen base importPath
+      pure $ map (nsDefinition (if name == "!Local" then "" else name))
+           $ filter (not . isImp) ast
     isImp (SImport _ _) = True
-    isImp _             = False
+    isImp _ = False
-
-    procImp :: Set.Set FilePath -> String -> FilePath -> TricuAST -> IO [TricuAST]
-    procImp s m f (SImport p "!Local") = do
-      let ip = makeRelativeTo f p
-      a <- preprocessFile' s b ip
-      let d = filter (not . isImp) a
-      pure $ map (nsDefinition m) d
-    procImp s _ f (SImport p n) = do
-      let ip = makeRelativeTo f p
-      a <- preprocessFile' s b ip
-      let d = filter (not . isImp) a
-      pure $ map (nsDefinition n) d
-    procImp _ _ _ _ = error "Unexpected non-import in processImport"
 
 makeRelativeTo :: FilePath -> FilePath -> FilePath
 makeRelativeTo f i =
@@ -94,7 +103,7 @@ nsDefinition :: String -> TricuAST -> TricuAST
 nsDefinition "" def = def
 nsDefinition moduleName (SDef name args body)
   | isPrefixed name = SDef name args (nsBody moduleName body)
-  | otherwise = SDef (nsVariable moduleName name) 
+  | otherwise = SDef (nsVariable moduleName name)
                         args (nsBody moduleName body)
 nsDefinition moduleName other =
   nsBody moduleName other
@@ -115,7 +124,7 @@ nsBody moduleName (TStem subtree) =
   TStem (nsBody moduleName subtree)
 nsBody moduleName (SDef name args body)
   | isPrefixed name = SDef name args (nsBody moduleName body)
-  | otherwise = SDef (nsVariable moduleName name) 
+  | otherwise = SDef (nsVariable moduleName name)
                         args (nsBody moduleName body)
 nsBody _ other = other
 
@@ -125,19 +134,19 @@ nsBodyScoped moduleName args body = case body of
     if name `elem` args
       then SVar name
       else nsBody moduleName (SVar name)
-  SApp func arg -> 
+  SApp func arg ->
     SApp (nsBodyScoped moduleName args func) (nsBodyScoped moduleName args arg)
-  SLambda innerArgs innerBody -> 
+  SLambda innerArgs innerBody ->
     SLambda innerArgs (nsBodyScoped moduleName (args ++ innerArgs) innerBody)
-  SList items -> 
+  SList items ->
     SList (map (nsBodyScoped moduleName args) items)
-  TFork left right -> 
+  TFork left right ->
-    TFork (nsBodyScoped moduleName args left) 
+    TFork (nsBodyScoped moduleName args left)
           (nsBodyScoped moduleName args right)
-  TStem subtree -> 
+  TStem subtree ->
     TStem (nsBodyScoped moduleName args subtree)
   SDef name innerArgs innerBody ->
-    SDef (nsVariable moduleName name) innerArgs 
+    SDef (nsVariable moduleName name) innerArgs
          (nsBodyScoped moduleName (args ++ innerArgs) innerBody)
   other -> other
 

src/Lexer.hs

@@ -59,7 +59,7 @@ keywordT = string "t" *> notFollowedBy alphaNumChar *> pure LKeywordT
 identifier :: Lexer LToken
 identifier = do
   first <- lowerChar <|> char '_'
-  rest  <- many $ letterChar 
+  rest  <- many $ letterChar
               <|> digitChar <|> char '_' <|> char '-' <|> char '?'
               <|> char '$'  <|> char '#' <|> char '@' <|> char '%'
   let name = first : rest

src/Parser.hs

@@ -255,9 +255,9 @@ parseSingleItemM = do
 
 parseVarM :: ParserM TricuAST
 parseVarM = do
-  token <- satisfyM (\case 
+  token <- satisfyM (\case
     LNamespace _ -> True
-    LIdentifier _ -> True 
+    LIdentifier _ -> True
     _ -> False)
   case token of
     LNamespace ns -> do

src/REPL.hs

@@ -6,21 +6,35 @@ import Lexer
 import Parser
 import Research
 
-import Control.Exception      (SomeException, catch)
+import Control.Exception         (SomeException, catch)
-import Control.Monad.IO.Class (liftIO)
+import Control.Monad.IO.Class    (liftIO)
-import Control.Monad.Catch    (handle, MonadCatch)
+import Control.Monad.Catch       (handle, MonadCatch)
-import Data.Char              (isSpace)
+import Control.Monad.Trans.Class (lift)
-import Data.List              ( dropWhile
+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
-                              , dropWhileEnd
+import Data.Char                 (isSpace)
-                              , intercalate
+import Data.List                 ( dropWhile
-                              , isPrefixOf)
+                                 , dropWhileEnd
+                                 , isPrefixOf)
 import System.Console.Haskeline
 
 import qualified Data.Map as Map
 
 repl :: Env -> IO ()
-repl env = runInputT defaultSettings (withInterrupt (loop env True))
+repl env = runInputT settings (withInterrupt (loop env True))
   where
+    settings :: Settings IO
+    settings = Settings
+      { complete = completeWord Nothing " \t" completeCommands
+      , historyFile = Just ".tricu_history"
+      , autoAddHistory = True
+      }
+
+    completeCommands :: String -> IO [Completion]
+    completeCommands str = return $ map simpleCompletion $
+      filter (str `isPrefixOf`) commands
+      where
+        commands = ["!exit", "!decode", "!definitions", "!import"]
+
     loop :: Env -> Bool -> InputT IO ()
     loop env decode = handle (interruptHandler env decode) $ do
       minput <- getInputLine "tricu < "
@@ -32,26 +46,48 @@ repl env = runInputT defaultSettings (withInterrupt (loop env True))
           | strip s == "!decode" -> do
               outputStrLn $ "Decoding " ++ (if decode then "disabled" else "enabled")
               loop env (not decode)
-          | "!import" `isPrefixOf` strip s -> do
+          | strip s == "!definitions" -> do
-              let afterImport = dropWhile (== ' ') $ drop (length ("!import" :: String)) (strip s)
+              let defs = Map.keys $ Map.delete "!result" env
-              if not (null afterImport)
+              if null defs
-                then outputStrLn "Warning: REPL imports are interactive; \
+                then outputStrLn "No definitions discovered."
-                                  \additional arguments are ignored."
+                else do
-                else pure ()
+                  outputStrLn "Available definitions:"
-              path <- getInputLine "File path to load < "
+                  mapM_ outputStrLn defs
-              case path of
+              loop env decode
-                Nothing -> do
+          | "!import" `isPrefixOf` strip s -> handleImport env decode
-                  outputStrLn "No input received; stopping import."
-                  loop env decode
-                Just p -> do
-                  loadedEnv <- liftIO $ evaluateFileWithContext env
-                    (strip p) `catch` \e -> errorHandler env e
-                  loop (Map.delete "!result" (Map.union loadedEnv env)) decode
           | take 2 s == "--" -> loop env decode
           | otherwise -> do
               newEnv <- liftIO $ processInput env s decode `catch` errorHandler env
               loop newEnv decode
 
+    handleImport :: Env -> Bool -> InputT IO ()
+    handleImport env decode = do
+      result <- runMaybeT $ do
+        let fileSettings = setComplete completeFilename defaultSettings
+        path <- MaybeT $ runInputT fileSettings $
+          getInputLineWithInitial "File path to load < " ("", "")
+
+        contents <- liftIO $ readFile (strip path)
+
+        if | Left err <- parseProgram (lexTricu contents) -> do
+               lift $ outputStrLn $ "Parse error: " ++ handleParseError err
+               MaybeT $ return Nothing
+           | Right ast <- parseProgram (lexTricu contents) -> do
+               ns <- MaybeT $ runInputT defaultSettings $
+                 getInputLineWithInitial "Namespace (or !Local for no namespace) < " ("", "")
+
+               processedAst <- liftIO $ preprocessFile (strip path)
+               let namespacedAst | strip ns == "!Local" = processedAst
+                                | otherwise = nsDefinitions (strip ns) processedAst
+                   loadedEnv = evalTricu env namespacedAst
+               return loadedEnv
+
+      if | Nothing <- result -> do
+             outputStrLn "Import cancelled."
+             loop env decode
+         | Just loadedEnv <- result ->
+             loop (Map.delete "!result" loadedEnv) decode
+
     interruptHandler :: Env -> Bool -> Interrupt -> InputT IO ()
     interruptHandler env decode _ = do
       outputStrLn "Interrupted with CTRL+C\n\
@@ -64,17 +100,17 @@ repl env = runInputT defaultSettings (withInterrupt (loop env True))
           newEnv = evalTricu env asts
       case Map.lookup "!result" newEnv of
         Just r -> do
-          putStrLn $ "tricu > " ++ 
+          putStrLn $ "tricu > " ++
-            if decode 
+            if decode
               then decodeResult r
               else show r
         Nothing -> pure ()
       return newEnv
-    
+
     errorHandler :: Env -> SomeException -> IO (Env)
     errorHandler env e = do
       putStrLn $ "Error: " ++ show e
       return env
-    
+
     strip :: String -> String
     strip = dropWhileEnd isSpace . dropWhile isSpace

src/Research.hs

@@ -53,7 +53,7 @@ data EvaluatedForm = TreeCalculus | FSL | AST | Ternary | Ascii | Decode
   deriving (Show, Data, Typeable)
 
 -- Environment containing previously evaluated TC terms
-type Env = Map.Map String T 
+type Env = Map.Map String T
 
 -- Tree Calculus Reduction
 apply :: T -> T -> T
@@ -122,7 +122,7 @@ formatResult Ascii        = toAscii
 formatResult Decode       = decodeResult
 
 toSimpleT :: String -> String
-toSimpleT s = T.unpack 
+toSimpleT s = T.unpack
   $ replace "Fork" "t"
   $ replace "Stem" "t"
   $ replace "Leaf" "t"

tricu.cabal

@@ -1,7 +1,7 @@
 cabal-version: 1.12
 
 name:           tricu
-version:        0.14.0
+version:        0.15.0
 description:    A micro-language for exploring Tree Calculus
 author:         James Eversole
 maintainer:     james@eversole.co
@@ -32,6 +32,7 @@ executable tricu
     , megaparsec
     , mtl
     , text
+    , transformers
   other-modules:
     Eval
     FileEval
@@ -63,6 +64,7 @@ test-suite tricu-tests
     , tasty-hunit
     , tasty-quickcheck
     , text
+    , transformers
   default-language:    Haskell2010
   other-modules:
     Eval