Rough draft of modules

This includes a naive implementation of a module system where imported
files have their imports recursively handled, strips the module/import
AST nodes, and then evals everything into a flat environment using
namespace prefixes like "Module.function".

demos/equality.tri

@@ -1,3 +1,7 @@
+!module Equality
+
+!import "lib/base.tri" Lib
+
 main = lambdaEqualsTC
 
 -- We represent `false` with a Leaf and `true` with a Stem Leaf
@@ -24,7 +28,7 @@ not_Lambda? = demo_matchBool demo_false demo_true
 -- to different tree representations even if they share extensional behavior.
 
 -- Let's see if these are the same:
-lambdaEqualsTC = equal? not_TC? not_Lambda?
+lambdaEqualsTC = Lib.equal? not_TC? not_Lambda?
 
 -- Here are some checks to verify their extensional behavior is the same:
 true_TC?  = not_TC? demo_false
@@ -33,5 +37,5 @@ false_TC? = not_TC? demo_true
 true_Lambda?  = not_Lambda? demo_false
 false_Lambda? = not_Lambda? demo_true
 
-bothTrueEqual?  = equal? true_TC?  true_Lambda?
+bothTrueEqual?  = Lib.equal? true_TC?  true_Lambda?
-bothFalseEqual? = equal? false_TC? false_Lambda?
+bothFalseEqual? = Lib.equal? false_TC? false_Lambda?

demos/levelOrderTraversal.tri

@@ -1,3 +1,7 @@
+!module LOT
+
+!import "lib/base.tri" Lib
+
 main = exampleTwo
 -- Level Order Traversal of a labelled binary tree
 -- Objective: Print each "level" of the tree on a separate line
@@ -15,41 +19,41 @@ main = exampleTwo
 --    /   /  \
 --   4   5    6
 
-label = \node : head node
+label = \node : Lib.head node
 
-left = (\node : if (emptyList? node)
+left = (\node : Lib.if (Lib.emptyList? node)
   [] 
-  (if (emptyList? (tail node)) 
+  (Lib.if (Lib.emptyList? (Lib.tail node)) 
     [] 
-    (head (tail node))))
+    (Lib.head (Lib.tail node))))
 
-right = (\node : if (emptyList? node) 
+right = (\node : Lib.if (Lib.emptyList? node) 
   [] 
-  (if (emptyList? (tail node)) 
+  (Lib.if (Lib.emptyList? (Lib.tail node)) 
     [] 
-    (if (emptyList? (tail (tail node))) 
+    (Lib.if (Lib.emptyList? (Lib.tail (Lib.tail node))) 
       [] 
-      (head (tail (tail node))))))
+      (Lib.head (Lib.tail (Lib.tail node))))))
 
-processLevel = y (\self queue : if (emptyList? queue) 
+processLevel = Lib.y (\self queue : Lib.if (Lib.emptyList? queue) 
   [] 
-  (pair (map label queue) (self (filter 
+  (Lib.pair (Lib.map label queue) (self (Lib.filter 
-    (\node : not? (emptyList? node)) 
+    (\node : Lib.not? (Lib.emptyList? node)) 
-      (lconcat (map left queue) (map right queue))))))
+      (Lib.lconcat (Lib.map left queue) (Lib.map right queue))))))
 
 levelOrderTraversal_ = \a : processLevel (t a t)
 
-toLineString = y (\self levels : if (emptyList? levels) 
+toLineString = Lib.y (\self levels : Lib.if (Lib.emptyList? levels) 
   "" 
-  (lconcat 
+  (Lib.lconcat 
-    (lconcat (map (\x : lconcat x " ") (head levels)) "") 
+    (Lib.lconcat (Lib.map (\x : Lib.lconcat x " ") (Lib.head levels)) "") 
-    (if (emptyList? (tail levels)) "" (lconcat (t (t 10 t) t) (self (tail levels))))))
+    (Lib.if (Lib.emptyList? (Lib.tail levels)) "" (Lib.lconcat (t (t 10 t) t) (self (Lib.tail levels))))))
 
 levelOrderToString = \s : toLineString (levelOrderTraversal_ s)
 
-flatten = foldl (\acc x : lconcat acc x) ""
+flatten = Lib.foldl (\acc x : Lib.lconcat acc x) ""
 
-levelOrderTraversal = \s : lconcat (t 10 t) (flatten (levelOrderToString s))
+levelOrderTraversal = \s : Lib.lconcat (t 10 t) (flatten (levelOrderToString s))
 
 exampleOne = levelOrderTraversal [("1") 
                                  [("2") [("4") t t] t] 

demos/size.tri

@@ -1,20 +1,24 @@
+!module Size
+
+!import "lib/base.tri" Lib
+
 main = size size
 
 compose = \f g x : f (g x)
 
-succ = y (\self :
+succ = Lib.y (\self :
-  triage
+  Lib.triage
     1
     t
-    (triage
+    (Lib.triage
       (t (t t))
-      (\_ tail : t t (self tail))
+      (\_ Lib.tail : t t (self Lib.tail))
       t))
 
 size = (\x :
-  (y (\self x :
+  (Lib.y (\self x :
     compose succ
-      (triage
+      (Lib.triage
         (\x : x)
         self
         (\x y : compose (self x) (self y))

demos/toSource.tri

@@ -1,4 +1,8 @@
-main = toSource not?
+!module ToSource
+
+!import "lib/base.tri" Lib
+
+main = toSource Lib.not?
 -- Thanks to intensionality, we can inspect the structure of a given value
 -- even if it's a function. This includes lambdas which are eliminated to
 -- Tree Calculus (TC) terms during evaluation.
@@ -12,29 +16,29 @@ main = toSource not?
 -- triage = (\leaf stem fork : t (t leaf stem) fork)
 
 -- Base case of a single Leaf
-sourceLeaf = t (head "t")
+sourceLeaf = t (Lib.head "t")
 
 -- Stem case
 sourceStem = (\convert : (\a rest :
-  t (head "(")                       -- Start with a left parenthesis "(".
+  t (Lib.head "(")                       -- Start with a left parenthesis "(".
-    (t (head "t")                    -- Add a "t"
+    (t (Lib.head "t")                    -- Add a "t"
-      (t (head " ")                  -- Add a space.
+      (t (Lib.head " ")                  -- Add a space.
-        (convert a                   -- Recursively convert the argument.
+        (convert a                       -- Recursively convert the argument.
-          (t (head ")") rest))))))   -- Close with ")" and append the rest.
+          (t (Lib.head ")") rest))))))   -- Close with ")" and append the rest.
 
 -- Fork case
 sourceFork = (\convert : (\a b rest :
-  t (head "(")                           -- Start with a left parenthesis "(".
+  t (Lib.head "(")                           -- Start with a left parenthesis "(".
-    (t (head "t")                        -- Add a "t"
+    (t (Lib.head "t")                        -- Add a "t"
-      (t (head " ")                      -- Add a space.
+      (t (Lib.head " ")                      -- Add a space.
-        (convert a                       -- Recursively convert the first arg.
+        (convert a                           -- Recursively convert the first arg.
-          (t (head " ")                  -- Add another space.
+          (t (Lib.head " ")                  -- Add another space.
-            (convert b                   -- Recursively convert the second arg.
+            (convert b                       -- Recursively convert the second arg.
-              (t (head ")") rest)))))))) -- Close with ")" and append the rest.
+              (t (Lib.head ")") rest)))))))) -- Close with ")" and append the rest.
 
 -- Wrapper around triage 
-toSource_ = y (\self arg :
+toSource_ = Lib.y (\self arg :
-  triage
+  Lib.triage
     sourceLeaf        -- `triage` "a" case, Leaf
     (sourceStem self) -- `triage` "b" case, Stem
     (sourceFork self) -- `triage` "c" case, Fork
@@ -43,5 +47,5 @@ toSource_ = y (\self arg :
 -- toSource takes a single TC term and returns a String
 toSource = \v : toSource_ v ""
 
-exampleOne = toSource true -- OUT: "(t t)"
+exampleOne = toSource Lib.true -- OUT: "(t t)"
-exampleTwo = toSource not? -- OUT: "(t (t (t t) (t t t)) (t t (t t t)))"
+exampleTwo = toSource Lib.not? -- OUT: "(t (t (t t) (t t t)) (t t (t t t)))"

src/Eval.hs

@@ -109,10 +109,11 @@ freeVars (SStr    _    ) = Set.empty
 freeVars (SList   s    ) = foldMap freeVars s
 freeVars (SApp    f a  ) = freeVars f <> freeVars a
 freeVars (TLeaf        ) = Set.empty
-freeVars (SDef   _ _ b) = freeVars b
+freeVars (SDef   _ _ 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
+freeVars _               = Set.empty
 
 reorderDefs :: Env -> [TricuAST] -> [TricuAST]
 reorderDefs env defs

src/FileEval.hs

@@ -1,9 +1,12 @@
 module FileEval where
 
 import Eval
+import Lexer
 import Parser
 import Research
 
+import Data.List       (partition)
+import Control.Monad   (foldM)
 import System.IO
 
 import qualified Data.Map as Map
@@ -11,20 +14,130 @@ import qualified Data.Map as Map
 evaluateFileResult :: FilePath -> IO T
 evaluateFileResult filePath = do
   contents <- readFile filePath
-  let asts = parseTricu contents
+  let tokens = lexTricu contents
-  let finalEnv = evalTricu Map.empty asts
+  let moduleName = case parseProgram tokens of
-  case Map.lookup "main" finalEnv of
+        Right ((SModule name) : _) -> name
-    Just finalResult -> return finalResult
+        _                          -> ""
-    Nothing -> errorWithoutStackTrace "No `main` function detected"
+  case parseProgram tokens of
+    Left err -> errorWithoutStackTrace (handleParseError err)
+    Right _ -> do
+      ast <- preprocessFile filePath
+      let finalEnv = mainAlias moduleName $ evalTricu Map.empty ast
+      case Map.lookup "main" finalEnv of
+        Just finalResult -> return finalResult
+        Nothing -> errorWithoutStackTrace "No `main` function detected"
 
 evaluateFile :: FilePath -> IO Env
 evaluateFile filePath = do
   contents <- readFile filePath
-  let asts = parseTricu contents
+  let tokens = lexTricu contents
-  pure $ evalTricu Map.empty asts
+  let moduleName = case parseProgram tokens of
+        Right ((SModule name) : _) -> name
+        _                          -> ""
+  case parseProgram tokens of
+    Left err -> errorWithoutStackTrace (handleParseError err)
+    Right _ -> do
+      ast <- preprocessFile filePath
+      pure $ mainAlias moduleName $ evalTricu Map.empty ast
 
 evaluateFileWithContext :: Env -> FilePath -> IO Env
 evaluateFileWithContext env filePath = do
   contents <- readFile filePath
-  let asts = parseTricu contents
+  let tokens = lexTricu contents
-  pure $ evalTricu env asts
+  let moduleName = case parseProgram tokens of
+        Right ((SModule name) : _) -> name
+        _                          -> ""
+  case parseProgram tokens of
+    Left err -> errorWithoutStackTrace (handleParseError err)
+    Right _ -> do
+      ast <- preprocessFile filePath
+      pure $ mainAlias moduleName $ evalTricu env ast
+
+mainAlias :: String -> Env -> Env
+mainAlias "" env = env
+mainAlias moduleName env =
+  case Map.lookup (moduleName ++ ".main") env of
+    Just value -> Map.insert "main" value env
+    Nothing    -> env
+
+preprocessFile :: FilePath -> IO [TricuAST]
+preprocessFile filePath = do
+  contents <- readFile filePath
+  let tokens = lexTricu contents
+  case parseProgram tokens of
+    Left err -> errorWithoutStackTrace (handleParseError err)
+    Right asts -> do
+      let (moduleName, restAST) = extractModule asts
+      let (imports, nonImports) = partition isImport restAST
+      importedASTs <- concat <$> mapM (processImport moduleName) imports
+      let namespacedAST = namespaceDefinitions moduleName nonImports
+      let fullyNamespacedImports = map (namespaceBody moduleName) importedASTs
+      pure $ fullyNamespacedImports ++ namespacedAST
+  where
+    extractModule :: [TricuAST] -> (String, [TricuAST])
+    extractModule ((SModule name) : xs) = (name, xs)
+    extractModule xs                    = ("", xs)
+
+    isImport :: TricuAST -> Bool
+    isImport (SImport _ _) = True
+    isImport _             = False
+
+    processImport :: String -> TricuAST -> IO [TricuAST]
+    processImport _ (SImport filePath moduleName) = do
+      importedAST <- preprocessFile filePath
+      pure $ namespaceDefinitions moduleName importedAST
+    processImport _ _ = error "Unexpected non-import AST node in processImport"
+
+namespaceDefinitions :: String -> [TricuAST] -> [TricuAST]
+namespaceDefinitions moduleName = map (namespaceDefinition moduleName)
+
+namespaceDefinition :: String -> TricuAST -> TricuAST
+namespaceDefinition "" def = def
+namespaceDefinition moduleName (SDef name args body)
+  | isPrefixed name = SDef name args (namespaceBody moduleName body)
+  | otherwise = SDef (namespaceVariable moduleName name) 
+                        args (namespaceBody moduleName body)
+namespaceDefinition moduleName other =
+  namespaceBody moduleName other
+
+namespaceBody :: String -> TricuAST -> TricuAST
+namespaceBody moduleName (SVar name)
+  | isPrefixed name = SVar name
+  | otherwise = SVar (namespaceVariable moduleName name)
+namespaceBody moduleName (SApp func arg) =
+  SApp (namespaceBody moduleName func) (namespaceBody moduleName arg)
+namespaceBody moduleName (SLambda args body) =
+  SLambda args (namespaceBodyScoped moduleName args body)
+namespaceBody moduleName (SList items) =
+  SList (map (namespaceBody moduleName) items)
+namespaceBody moduleName (TFork left right) =
+  TFork (namespaceBody moduleName left) (namespaceBody moduleName right)
+namespaceBody moduleName (TStem subtree) =
+  TStem (namespaceBody moduleName subtree)
+namespaceBody moduleName (SDef name args body)
+  | isPrefixed name = SDef name args (namespaceBody moduleName body)
+  | otherwise = SDef (namespaceVariable moduleName name) 
+                        args (namespaceBody moduleName body)
+namespaceBody _ other = other
+
+namespaceBodyScoped :: String -> [String] -> TricuAST -> TricuAST
+namespaceBodyScoped moduleName args body = case body of
+  SVar name ->
+    if name `elem` args
+      then SVar name
+      else namespaceBody moduleName (SVar name)
+  SApp func arg -> SApp (namespaceBodyScoped moduleName args func) (namespaceBodyScoped moduleName args arg)
+  SLambda innerArgs innerBody -> SLambda innerArgs (namespaceBodyScoped moduleName (args ++ innerArgs) innerBody)
+  SList items -> SList (map (namespaceBodyScoped moduleName args) items)
+  TFork left right -> TFork (namespaceBodyScoped moduleName args left) (namespaceBodyScoped moduleName args right)
+  TStem subtree -> TStem (namespaceBodyScoped moduleName args subtree)
+  SDef name innerArgs innerBody ->
+    SDef (namespaceVariable moduleName name) innerArgs (namespaceBodyScoped moduleName (args ++ innerArgs) innerBody)
+  other -> other
+
+isPrefixed :: String -> Bool
+isPrefixed name = '.' `elem` name
+
+namespaceVariable :: String -> String -> String
+namespaceVariable "" name = name
+namespaceVariable moduleName name = moduleName ++ "." ++ name

src/Lexer.hs

@@ -20,7 +20,7 @@ identifier = do
   first <- letterChar <|> char '_'
   rest  <- many $ letterChar 
               <|> digitChar 
-              <|> char '_' <|> char '-' <|> char '?' <|> char '!'
+              <|> char '_' <|> char '-' <|> char '?' <|> char '.'
               <|> char '$' <|> char '#' <|> char '@' <|> char '%'
   let name = first : rest
   if (name == "t" || name == "!result")
@@ -39,6 +39,22 @@ stringLiteral = do
   char '"' --"
   return (LStringLiteral content)
 
+lModule :: Lexer LToken
+lModule = do
+  _ <- string "!module"
+  space1
+  LIdentifier moduleName <- identifier
+  return (LModule moduleName)
+
+lImport :: Lexer LToken
+lImport = do
+  _ <- string "!import"
+  space1
+  LStringLiteral path <- stringLiteral
+  space1
+  LIdentifier name <- identifier
+  return (LImport path name)
+
 assign :: Lexer LToken
 assign = char '=' *> pure LAssign
 
@@ -72,28 +88,36 @@ sc = space
 tricuLexer :: Lexer [LToken]
 tricuLexer = do
   sc
+  header <- many $ do
+    tok <- choice
+      [ try lModule
+      , try lImport
+      , lnewline
+      ]
+    sc
+    pure tok
   tokens <- many $ do
     tok <- choice tricuLexer'
     sc
     pure tok
   sc
   eof
-  pure tokens
+  pure (header ++ tokens)
-    where
+  where
-      tricuLexer' = 
+    tricuLexer' =
-        [ try lnewline
+      [ try lnewline
-        , try identifier
+      , try identifier
-        , try keywordT
+      , try keywordT
-        , try integerLiteral
+      , try integerLiteral
-        , try stringLiteral
+      , try stringLiteral
-        , assign
+      , assign
-        , colon
+      , colon
-        , backslash
+      , backslash
-        , openParen
+      , openParen
-        , closeParen
+      , closeParen
-        , openBracket
+      , openBracket
-        , closeBracket
+      , closeBracket
-        ]
+      ]
 
 lexTricu :: String -> [LToken]
 lexTricu input = case runParser tricuLexer "" input of

src/Parser.hs

@@ -73,10 +73,30 @@ parseSingle input =
 
 parseProgramM :: ParserM [TricuAST]
 parseProgramM = do
+  skipMany topLevelNewline
+  moduleNode <- optional parseModuleM
+  skipMany topLevelNewline
+  importNodes <- many parseImportM
   skipMany topLevelNewline
   exprs <- sepEndBy parseOneExpression (some topLevelNewline)
   skipMany topLevelNewline
-  return exprs
+  return (maybe [] (: []) moduleNode ++ importNodes ++ exprs)
+
+parseModuleM :: ParserM TricuAST
+parseModuleM = do
+  LModule moduleName <- satisfyM isModule
+  pure (SModule moduleName)
+  where
+    isModule (LModule _) = True
+    isModule _           = False
+
+parseImportM :: ParserM TricuAST
+parseImportM = do
+  LImport filePath moduleName <- satisfyM isImport
+  pure (SImport filePath moduleName)
+  where
+    isImport (LImport _ _) = True
+    isImport _             = False
 
 parseOneExpression :: ParserM TricuAST
 parseOneExpression = scnParserM *> parseExpressionM

src/REPL.hs

@@ -26,7 +26,7 @@ repl env = runInputT defaultSettings (loop env)
         | Just s  <- minput, strip s == ""      -> do
           outputStrLn ""
           loop env
-        | Just s  <- minput, strip s == "!load" -> do
+        | Just s  <- minput, strip s == "!import" -> do
           path <- getInputLine "File path to load < "
           if
             | Nothing <- path -> do

src/Research.hs

@@ -26,6 +26,8 @@ data TricuAST
   | TFork TricuAST TricuAST
   | SLambda [String] TricuAST
   | SEmpty
+  | SModule String
+  | SImport String String
   deriving (Show, Eq, Ord)
 
 -- Lexer Tokens
@@ -42,6 +44,8 @@ data LToken
   | LOpenBracket
   | LCloseBracket
   | LNewline
+  | LModule String
+  | LImport String String
   deriving (Show, Eq, Ord)
 
 -- Output formats

test/Spec.hs

@@ -501,19 +501,15 @@ fileEval = testGroup "File evaluation tests"
 demos :: TestTree
 demos = testGroup "Test provided demo functionality"
   [ testCase "Structural equality demo" $ do
-      library <- liftIO $ evaluateFile "./lib/base.tri"
+      res     <- liftIO $ evaluateFileResult "./demos/equality.tri"
-      res     <- liftIO $ evaluateFileWithContext library "./demos/equality.tri"
+      decodeResult res @?= "t t"
-      decodeResult (result res) @?= "t t"
   , testCase "Convert values back to source code demo" $ do
-      library <- liftIO $ evaluateFile "./lib/base.tri"
+      res     <- liftIO $ evaluateFileResult "./demos/toSource.tri"
-      res     <- liftIO $ evaluateFileWithContext library "./demos/toSource.tri"
+      decodeResult res @?= "\"(t (t (t t) (t t t)) (t t (t t t)))\""
-      decodeResult (result res) @?= "\"(t (t (t t) (t t t)) (t t (t t t)))\""
   , testCase "Determining the size of functions" $ do
-      library <- liftIO $ evaluateFile "./lib/base.tri"
+      res     <- liftIO $ evaluateFileResult "./demos/size.tri"
-      res     <- liftIO $ evaluateFileWithContext library "./demos/size.tri"
+      decodeResult res @?= "454"
-      decodeResult (result res) @?= "454"
   , testCase "Level Order Traversal demo" $ do
-      library <- liftIO $ evaluateFile "./lib/base.tri"
+      res     <- liftIO $ evaluateFileResult "./demos/levelOrderTraversal.tri"
-      res     <- liftIO $ evaluateFileWithContext library "./demos/levelOrderTraversal.tri"
+      decodeResult res @?= "\"\n1 \n2 3 \n4 5 6 7 \n8 11 10 9 12 \""
-      decodeResult (result res) @?= "\"\n1 \n2 3 \n4 5 6 7 \n8 11 10 9 12 \""
   ]

test/modules-1.tri

@@ -0,0 +1,5 @@
+!module Test
+
+!import "lib/base.tri" Lib
+
+main = Lib.not? t

test/modules-2.tri

@@ -0,0 +1 @@
+n = t t t

tricu.cabal

@@ -1,7 +1,7 @@
 cabal-version: 1.12
 
 name:           tricu
-version:        0.11.0
+version:        0.12.0
 description:    A micro-language for exploring Tree Calculus
 author:         James Eversole
 maintainer:     james@eversole.co