diff --git a/demos/equality.tri b/demos/equality.tri index d0008bf..86ace3b 100644 --- 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 index 2a5d4ac..803a1dd 100644 --- 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 index 83c8937..cbfd6c9 100644 --- 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 index f8a65f8..354943e 100644 --- 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 index 6a132b9..914bfe7 100644 --- 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,33 +21,6 @@ matchBool = (\ot of : triage (\_ _ : ot) ) -matchList = \a b : triage a _ b - -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 : - matchBool - (matchBool (t t) (t t) y) - (matchBool (t t) t y) - x) - -xor? = (\x y : - matchBool - (matchBool t (t t) y) - (matchBool (t t) t y) - x) - -append = y (\self : matchList - (\k : k) - (\h r k : pair h (self r k))) - lAnd = (triage (\_ : false) (\_ x : x) @@ -63,11 +31,22 @@ lOr = (triage (\_ _ : true) (\_ _ _ : true)) -map_ = y (\self : - matchList - (\_ : t) - (\head tail f : pair (f head) (self tail f))) -map = \f l : map_ l f +matchPair = \a : triage _ _ a + +not? = matchBool false true +and? = matchBool id (\_ : false) + +or? = (\x z : + matchBool + (matchBool true true z) + (matchBool true false z) + x) + +xor? = (\x z : + matchBool + (matchBool false true z) + (matchBool true false z) + x) equal? = y (\self : triage (triage @@ -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 new file mode 100644 index 0000000..d784a6b --- /dev/null +++ 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 index 202bcd7..832c351 100644 --- 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 index af8ddc0..5b9845f 100644 --- 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 + isImp :: TricuAST -> Bool + isImp (SImport _ _) = True + isImp _ = 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" + 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 index d657a60..a1912de 100644 --- 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 index f77d6c1..40d9fa2 100644 --- 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 index 61e911a..5336f1e 100644 --- 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 index fd10a99..e461a5e 100644 --- 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 index 6296138..729429b 100644 --- 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 index 6d16539..b95c23a 100644 --- 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 index 53a23b2..3553c2c 100644 --- 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 index 63164d0..115d591 100644 --- 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 index 06813f9..5d24219 100644 --- 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 index 3336f41..1f38f8d 100644 --- 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 index ed98ad0..e0a4b21 100644 --- 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