commit a87e57f2f735ae74307bf6acb84dffcb8f34d24a
parent 32011e21bbf1acb4e87edc432beb08ffe60021e8
Author: James Eversole <james@eversole.co>
Date: Thu, 30 Jan 2025 17:56:46 -0600
Caller-relative imports; smart deduping in imports
Diffstat:
19 files changed, 183 insertions(+), 205 deletions(-)
diff --git a/demos/equality.tri b/demos/equality.tri
@@ -1,4 +1,5 @@
-!import "lib/base.tri" !Local
+!import "../lib/base.tri" !Local
+!import "../lib/list.tri" !Local
main = lambdaEqualsTC
diff --git a/demos/levelOrderTraversal.tri b/demos/levelOrderTraversal.tri
@@ -1,4 +1,5 @@
-!import "lib/base.tri" !Local
+!import "../lib/base.tri" Lib
+!import "../lib/list.tri" !Local
main = exampleTwo
-- Level Order Traversal of a labelled binary tree
diff --git a/demos/size.tri b/demos/size.tri
@@ -1,4 +1,5 @@
-!import "lib/base.tri" !Local
+!import "../lib/base.tri" !Local
+!import "../lib/list.tri" !Local
main = size size
diff --git a/demos/toSource.tri b/demos/toSource.tri
@@ -1,4 +1,5 @@
-!import "lib/base.tri" !Local
+!import "../lib/base.tri" !Local
+!import "../lib/list.tri" !Local
main = toSource not?
-- Thanks to intensionality, we can inspect the structure of a given value
diff --git a/lib/base.tri b/lib/base.tri
@@ -1,13 +1,8 @@
false = t
_ = t
true = t t
-k = t t
-i = t (t k) t
-s = t (t (k t)) t
-m = s i i
-b = s (k s) k
-c = s (s (k s) (s (k k) s)) (k k)
id = \a : a
+const = \a b : a
pair = t
if = \cond then else : t (t else (t t then)) t cond
@@ -26,49 +21,33 @@ matchBool = (\ot of : triage
(\_ _ : ot)
)
-matchList = \a b : triage a _ b
+lAnd = (triage
+ (\_ : false)
+ (\_ x : x)
+ (\_ _ x : x))
+
+lOr = (triage
+ (\x : x)
+ (\_ _ : true)
+ (\_ _ _ : true))
matchPair = \a : triage _ _ a
not? = matchBool false true
and? = matchBool id (\_ : false)
-emptyList? = matchList true (\_ _ : false)
-head = matchList t (\head _ : head)
-tail = matchList t (\_ tail : tail)
-
-or? = (\x y :
+or? = (\x z :
matchBool
- (matchBool (t t) (t t) y)
- (matchBool (t t) t y)
+ (matchBool true true z)
+ (matchBool true false z)
x)
-xor? = (\x y :
+xor? = (\x z :
matchBool
- (matchBool t (t t) y)
- (matchBool (t t) t y)
+ (matchBool false true z)
+ (matchBool true false z)
x)
-append = y (\self : matchList
- (\k : k)
- (\h r k : pair h (self r k)))
-
-lAnd = (triage
- (\_ : false)
- (\_ x : x)
- (\_ _ x : x))
-
-lOr = (triage
- (\x : x)
- (\_ _ : true)
- (\_ _ _ : true))
-
-map_ = y (\self :
- matchList
- (\_ : t)
- (\head tail f : pair (f head) (self tail f)))
-map = \f l : map_ l f
-
equal? = y (\self : triage
(triage
true
@@ -85,21 +64,6 @@ equal? = y (\self : triage
(\_ : false)
(\bx by : lAnd (self ax bx) (self ay by))))
-lExist? = y (\self x : matchList
- false
- (\h z : or? (equal? x h) (self x z)))
-
-filter_ = y (\self : matchList
- (\_ : t)
- (\head tail f : matchBool (t head) i (f head) (self tail f)))
-filter = \f l : filter_ l f
-
-foldl_ = y (\self f l x : matchList (\acc : acc) (\head tail acc : self f tail (f acc head)) l x)
-foldl = \f x l : foldl_ f l x
-
-foldr_ = y (\self x f l : matchList x (\head tail : f (self x f tail) head) l)
-foldr = \f x l : foldr_ x f l
-
succ = y (\self :
triage
1
@@ -108,48 +72,3 @@ succ = y (\self :
(t (t t))
(\_ tail : t t (self tail))
t))
-
-length = y (\self : matchList
- 0
- (\_ tail : succ (self tail)))
-
-reverse = y (\self : matchList
- t
- (\head tail : append (self tail) (pair head t)))
-
-snoc = y (\self x : matchList
- (pair x t)
- (\h z : pair h (self x z)))
-
-count = y (\self x : matchList
- 0
- (\h z : matchBool
- (succ (self x z))
- (self x z)
- (equal? x h)))
-
-last = y (\self : matchList
- t
- (\hd tl : matchBool
- hd
- (self tl)
- (emptyList? tl)))
-
-all? = y (\self pred : matchList
- true
- (\h z : and? (pred h) (self pred z)))
-
-any? = y (\self pred : matchList
- false
- (\h z : or? (pred h) (self pred z)))
-
-unique_ = y (\self seen : matchList
- t
- (\head rest : matchBool
- (self seen rest)
- (pair head (self (pair head seen) rest))
- (lExist? head seen)))
-unique = \xs : unique_ t xs
-
-intersect = \xs ys : filter (\x : lExist? x ys) xs
-union = \xs ys : unique (append xs ys)
diff --git a/lib/list.tri b/lib/list.tri
@@ -0,0 +1,77 @@
+!import "base.tri" !Local
+
+matchList = \a b : triage a _ b
+
+emptyList? = matchList true (\_ _ : false)
+head = matchList t (\head _ : head)
+tail = matchList t (\_ tail : tail)
+
+append = y (\self : matchList
+ (\k : k)
+ (\h r k : pair h (self r k)))
+
+lExist? = y (\self x : matchList
+ false
+ (\h z : or? (equal? x h) (self x z)))
+
+map_ = y (\self :
+ matchList
+ (\_ : t)
+ (\head tail f : pair (f head) (self tail f)))
+map = \f l : map_ l f
+
+filter_ = y (\self : matchList
+ (\_ : t)
+ (\head tail f : matchBool (t head) id (f head) (self tail f)))
+filter = \f l : filter_ l f
+
+foldl_ = y (\self f l x : matchList (\acc : acc) (\head tail acc : self f tail (f acc head)) l x)
+foldl = \f x l : foldl_ f l x
+
+foldr_ = y (\self x f l : matchList x (\head tail : f (self x f tail) head) l)
+foldr = \f x l : foldr_ x f l
+
+length = y (\self : matchList
+ 0
+ (\_ tail : succ (self tail)))
+
+reverse = y (\self : matchList
+ t
+ (\head tail : append (self tail) (pair head t)))
+
+snoc = y (\self x : matchList
+ (pair x t)
+ (\h z : pair h (self x z)))
+
+count = y (\self x : matchList
+ 0
+ (\h z : matchBool
+ (succ (self x z))
+ (self x z)
+ (equal? x h)))
+
+last = y (\self : matchList
+ t
+ (\hd tl : matchBool
+ hd
+ (self tl)
+ (emptyList? tl)))
+
+all? = y (\self pred : matchList
+ true
+ (\h z : and? (pred h) (self pred z)))
+
+any? = y (\self pred : matchList
+ false
+ (\h z : or? (pred h) (self pred z)))
+
+unique_ = y (\self seen : matchList
+ t
+ (\head rest : matchBool
+ (self seen rest)
+ (pair head (self (pair head seen) rest))
+ (lExist? head seen)))
+unique = \xs : unique_ t xs
+
+intersect = \xs ys : filter (\x : lExist? x ys) xs
+union = \xs ys : unique (append xs ys)
diff --git a/src/Eval.hs b/src/Eval.hs
@@ -141,18 +141,23 @@ reorderDefs env defs
buildDepGraph :: [TricuAST] -> Map.Map String (Set.Set String)
buildDepGraph topDefs
- | not (null duplicateNames) =
+ | not (null conflictingDefs) =
errorWithoutStackTrace $
- "Duplicate definitions detected: " ++ show duplicateNames
+ "Conflicting definitions detected: " ++ show conflictingDefs
| otherwise =
Map.fromList
[ (name, depends topDefs (SDef name [] body))
| SDef name _ body <- topDefs]
where
- names = [name | SDef name _ _ <- topDefs]
- duplicateNames =
- [ name | (name, count) <- Map.toList (countOccurrences names) , count > 1]
- countOccurrences = foldr (\x -> Map.insertWith (+) x 1) Map.empty
+ defsMap = Map.fromListWith (++)
+ [(name, [(name, body)]) | SDef name _ body <- topDefs]
+
+ conflictingDefs =
+ [ name
+ | (name, defs) <- Map.toList defsMap
+ , let bodies = map snd defs
+ , not $ all (== head bodies) (tail bodies)
+ ]
sortDeps :: Map.Map String (Set.Set String) -> [String]
sortDeps graph = go [] Set.empty (Map.keys graph)
diff --git a/src/FileEval.hs b/src/FileEval.hs
@@ -8,6 +8,7 @@ import Research
import Data.List (partition)
import Control.Monad (foldM)
import System.IO
+import System.FilePath (takeDirectory, normalise, (</>))
import qualified Data.Map as Map
import qualified Data.Set as Set
@@ -46,38 +47,45 @@ evaluateFileWithContext env filePath = do
pure $ evalTricu env ast
preprocessFile :: FilePath -> IO [TricuAST]
-preprocessFile = preprocessFile' Set.empty
+preprocessFile p = preprocessFile' Set.empty p p
-preprocessFile' :: Set.Set FilePath -> FilePath -> IO [TricuAST]
-preprocessFile' inProgress filePath
- | filePath `Set.member` inProgress =
- errorWithoutStackTrace $ "Encountered cyclic import: " ++ filePath
+preprocessFile' :: Set.Set FilePath -> FilePath -> FilePath -> IO [TricuAST]
+preprocessFile' s b p
+ | p `Set.member` s =
+ errorWithoutStackTrace $ "Encountered cyclic import: " ++ p
| otherwise = do
- contents <- readFile filePath
- let tokens = lexTricu contents
- case parseProgram tokens of
- Left err -> errorWithoutStackTrace (handleParseError err)
- Right asts -> do
- let (imports, nonImports) = partition isImport asts
- let newInProgress = Set.insert filePath inProgress
- importedASTs <- concat <$>
- mapM (processImport newInProgress "") imports
- pure $ importedASTs ++ nonImports
+ c <- readFile p
+ let t = lexTricu c
+ case parseProgram t of
+ Left e -> errorWithoutStackTrace (handleParseError e)
+ Right a -> do
+ let (i, n) = partition isImp a
+ let s' = Set.insert p s
+ r <- concat <$>
+ mapM (procImp s' "" p) i
+ pure $ r ++ n
where
- isImport :: TricuAST -> Bool
- isImport (SImport _ _) = True
- isImport _ = False
-
- processImport :: Set.Set FilePath -> String -> TricuAST -> IO [TricuAST]
- processImport prog currentModule (SImport path "!Local") = do
- ast <- preprocessFile' prog path
- let defs = filter (not . isImport) ast
- pure $ map (nsDefinition currentModule) defs
- processImport prog _ (SImport path name) = do
- ast <- preprocessFile' prog path
- let defs = filter (not . isImport) ast
- pure $ map (nsDefinition name) defs
- processImport _ _ _ = error "Unexpected non-import in processImport"
+ isImp :: TricuAST -> Bool
+ isImp (SImport _ _) = True
+ 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 =
+ let d = takeDirectory f
+ in normalise $ d </> i
nsDefinitions :: String -> [TricuAST] -> [TricuAST]
nsDefinitions moduleName = map (nsDefinition moduleName)
diff --git a/test/Spec.hs b/test/Spec.hs
@@ -30,7 +30,7 @@ tests = testGroup "Tricu Tests"
, parser
, simpleEvaluation
, lambdas
- , baseLibrary
+ , providedLibraries
, fileEval
, modules
, demos
@@ -343,137 +343,101 @@ lambdas = testGroup "Lambda Evaluation Tests"
runTricu input @?= "Fork Leaf (Fork (Stem Leaf) Leaf)"
]
-baseLibrary :: TestTree
-baseLibrary = testGroup "Library Tests"
- [ testCase "K combinator 1" $ do
- library <- evaluateFile "./lib/base.tri"
- let input = "k (t) (t t)"
- env = evalTricu library (parseTricu input)
- result env @?= Leaf
-
- , testCase "K combinator 2" $ do
- library <- evaluateFile "./lib/base.tri"
- let input = "k (t t) (t)"
- env = evalTricu library (parseTricu input)
- result env @?= Stem Leaf
-
- , testCase "K combinator 3" $ do
- library <- evaluateFile "./lib/base.tri"
- let input = "k (t t t) (t)"
- env = evalTricu library (parseTricu input)
- result env @?= Fork Leaf Leaf
-
- , testCase "S combinator" $ do
- library <- evaluateFile "./lib/base.tri"
- let input = "s (t) (t) (t)"
- env = evalTricu library (parseTricu input)
- result env @?= Fork Leaf (Stem Leaf)
-
- , testCase "SKK == I (fully expanded)" $ do
- library <- evaluateFile "./lib/base.tri"
- let input = "s k k"
- env = evalTricu library (parseTricu input)
- result env @?= Fork (Stem (Stem Leaf)) (Stem Leaf)
-
- , testCase "I combinator" $ do
- library <- evaluateFile "./lib/base.tri"
- let input = "i not?"
- env = evalTricu library (parseTricu input)
- result env @?= Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) (Fork Leaf (Fork Leaf Leaf))
-
- , testCase "Triage test Leaf" $ do
- library <- evaluateFile "./lib/base.tri"
+providedLibraries :: TestTree
+providedLibraries = testGroup "Library Tests"
+ [ testCase "Triage test Leaf" $ do
+ library <- evaluateFile "./lib/list.tri"
let input = "test t"
env = decodeResult $ result $ evalTricu library (parseTricu input)
env @?= "\"Leaf\""
, testCase "Triage test (Stem Leaf)" $ do
- library <- evaluateFile "./lib/base.tri"
+ library <- evaluateFile "./lib/list.tri"
let input = "test (t t)"
env = decodeResult $ result $ evalTricu library (parseTricu input)
env @?= "\"Stem\""
, testCase "Triage test (Fork Leaf Leaf)" $ do
- library <- evaluateFile "./lib/base.tri"
+ library <- evaluateFile "./lib/list.tri"
let input = "test (t t t)"
env = decodeResult $ result $ evalTricu library (parseTricu input)
env @?= "\"Fork\""
, testCase "Boolean NOT: true" $ do
- library <- evaluateFile "./lib/base.tri"
+ library <- evaluateFile "./lib/list.tri"
let input = "not? true"
env = result $ evalTricu library (parseTricu input)
env @?= Leaf
, testCase "Boolean NOT: false" $ do
- library <- evaluateFile "./lib/base.tri"
+ library <- evaluateFile "./lib/list.tri"
let input = "not? false"
env = result $ evalTricu library (parseTricu input)
env @?= Stem Leaf
, testCase "Boolean AND TF" $ do
- library <- evaluateFile "./lib/base.tri"
+ library <- evaluateFile "./lib/list.tri"
let input = "and? (t t) (t)"
env = evalTricu library (parseTricu input)
result env @?= Leaf
, testCase "Boolean AND FT" $ do
- library <- evaluateFile "./lib/base.tri"
+ library <- evaluateFile "./lib/list.tri"
let input = "and? (t) (t t)"
env = evalTricu library (parseTricu input)
result env @?= Leaf
, testCase "Boolean AND FF" $ do
- library <- evaluateFile "./lib/base.tri"
+ library <- evaluateFile "./lib/list.tri"
let input = "and? (t) (t)"
env = evalTricu library (parseTricu input)
result env @?= Leaf
, testCase "Boolean AND TT" $ do
- library <- evaluateFile "./lib/base.tri"
+ library <- evaluateFile "./lib/list.tri"
let input = "and? (t t) (t t)"
env = evalTricu library (parseTricu input)
result env @?= Stem Leaf
, testCase "List head" $ do
- library <- evaluateFile "./lib/base.tri"
+ library <- evaluateFile "./lib/list.tri"
let input = "head [(t) (t t) (t t t)]"
env = evalTricu library (parseTricu input)
result env @?= Leaf
, testCase "List tail" $ do
- library <- evaluateFile "./lib/base.tri"
+ library <- evaluateFile "./lib/list.tri"
let input = "head (tail (tail [(t) (t t) (t t t)]))"
env = evalTricu library (parseTricu input)
result env @?= Fork Leaf Leaf
, testCase "List map" $ do
- library <- evaluateFile "./lib/base.tri"
+ library <- evaluateFile "./lib/list.tri"
let input = "head (tail (map (\\a : (t t t)) [(t) (t) (t)]))"
env = evalTricu library (parseTricu input)
result env @?= Fork Leaf Leaf
, testCase "Empty list check" $ do
- library <- evaluateFile "./lib/base.tri"
+ library <- evaluateFile "./lib/list.tri"
let input = "emptyList? []"
env = evalTricu library (parseTricu input)
result env @?= Stem Leaf
, testCase "Non-empty list check" $ do
- library <- evaluateFile "./lib/base.tri"
+ library <- evaluateFile "./lib/list.tri"
let input = "not? (emptyList? [(1) (2) (3)])"
env = evalTricu library (parseTricu input)
result env @?= Stem Leaf
, testCase "Concatenate strings" $ do
- library <- evaluateFile "./lib/base.tri"
+ library <- evaluateFile "./lib/list.tri"
let input = "append \"Hello, \" \"world!\""
env = decodeResult $ result $ evalTricu library (parseTricu input)
env @?= "\"Hello, world!\""
, testCase "Verifying Equality" $ do
- library <- evaluateFile "./lib/base.tri"
+ library <- evaluateFile "./lib/list.tri"
let input = "equal? (t t t) (t t t)"
env = evalTricu library (parseTricu input)
result env @?= Stem Leaf
@@ -490,12 +454,12 @@ fileEval = testGroup "File evaluation tests"
res @?= Fork (Stem Leaf) Leaf
, testCase "Mapping and Equality" $ do
- library <- liftIO $ evaluateFile "./lib/base.tri"
+ library <- liftIO $ evaluateFile "./lib/list.tri"
fEnv <- liftIO $ evaluateFileWithContext library "./test/map.tri"
(mainResult fEnv) @?= Stem Leaf
, testCase "Eval and decoding string" $ do
- library <- liftIO $ evaluateFile "./lib/base.tri"
+ library <- liftIO $ evaluateFile "./lib/list.tri"
res <- liftIO $ evaluateFileWithContext library "./test/string.tri"
decodeResult (result res) @?= "\"String test!\""
]
diff --git a/test/cycle-1.tri b/test/cycle-1.tri
@@ -1,4 +1,4 @@
-!import "test/cycle-2.tri" Cycle2
+!import "cycle-2.tri" Cycle2
cycle1 = t Cycle2.cycle2
diff --git a/test/cycle-2.tri b/test/cycle-2.tri
@@ -1,4 +1,4 @@
-!import "test/cycle-1.tri" Cycle1
+!import "cycle-1.tri" Cycle1
cycle2 = t Cycle1.cycle1
diff --git a/test/local-ns/1.tri b/test/local-ns/1.tri
@@ -1,4 +1,4 @@
-!import "test/local-ns/2.tri" Two
+!import "2.tri" Two
main = Two.x
diff --git a/test/local-ns/2.tri b/test/local-ns/2.tri
@@ -1,2 +1,2 @@
-!import "test/local-ns/3.tri" !Local
+!import "3.tri" !Local
diff --git a/test/local-ns/3.tri b/test/local-ns/3.tri
@@ -1,2 +1 @@
-
x = 3
diff --git a/test/multi-level-A.tri b/test/multi-level-A.tri
@@ -1,2 +1,2 @@
-!import "./test/multi-level-B.tri" B
+!import "multi-level-B.tri" B
main = B.main
diff --git a/test/multi-level-B.tri b/test/multi-level-B.tri
@@ -1,2 +1,2 @@
-!import "./test/multi-level-C.tri" C
+!import "multi-level-C.tri" C
main = C.val
diff --git a/test/namespace-A.tri b/test/namespace-A.tri
@@ -1,2 +1,2 @@
-!import "./test/namespace-B.tri" B
+!import "namespace-B.tri" B
main = B.x
diff --git a/test/vars-A.tri b/test/vars-A.tri
@@ -1,6 +1,6 @@
-!import "./test/vars-B.tri" B
+!import "vars-B.tri" B
-!import "./test/vars-C.tri" C
+!import "vars-C.tri" C
main = B.y (C.z)
diff --git a/tricu.cabal b/tricu.cabal
@@ -1,7 +1,7 @@
cabal-version: 1.12
name: tricu
-version: 0.13.2
+version: 0.14.0
description: A micro-language for exploring Tree Calculus
author: James Eversole
maintainer: james@eversole.co
@@ -27,6 +27,7 @@ executable tricu
, cmdargs
, containers
, exceptions
+ , filepath
, haskeline
, megaparsec
, mtl
@@ -54,6 +55,7 @@ test-suite tricu-tests
, cmdargs
, containers
, exceptions
+ , filepath
, haskeline
, megaparsec
, mtl
