-
-
Save hhefesto/cbaeb8a5469f9ab5a9d5d0b0f980868b to your computer and use it in GitHub Desktop.
039312d and HEAD~1
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
diff --git a/Prelude.tel b/Prelude.tel | |
index 555aa9f..8908c75 100644 | |
--- a/Prelude.tel | |
+++ b/Prelude.tel | |
@@ -89,3 +89,6 @@ quicksort = let layer = \recur l -> if right l | |
in listPlus (recur p2) (t,(recur p1)) | |
else l | |
in ? layer (\l -> 0) | |
+ | |
+abort = \str -> let x : (\y -> listPlus "abort: " str) = 1 | |
+ in x | |
diff --git a/app/Main.hs b/app/Main.hs | |
index aaf0d04..80219d1 100644 | |
--- a/app/Main.hs | |
+++ b/app/Main.hs | |
@@ -40,7 +40,7 @@ main = do | |
prelude = case parsePrelude preludeString of | |
Right p -> p | |
Left pe -> error pe | |
- runMain s = case compile <$> parseMain prelude s of | |
+ runMain s = case compileMain <$> parseMain prelude s of | |
Left e -> putStrLn $ concat ["failed to parse ", s, " ", e] | |
Right (Right g) -> evalLoop g | |
Right z -> putStrLn $ "compilation failed somehow, with result " <> show z | |
diff --git a/app/MiniRepl.hs b/app/MiniRepl.hs | |
index 5a1e9b6..d14954f 100644 | |
--- a/app/MiniRepl.hs | |
+++ b/app/MiniRepl.hs | |
@@ -93,7 +93,7 @@ resolveBinding' name bindings = lookup name bindings >>= (rightToMaybe . process | |
-- |Obtain expression from the bindings and transform them maybe into a IExpr. | |
resolveBinding :: String -> [(String, UnprocessedParsedTerm)] -> Maybe IExpr | |
-resolveBinding name bindings = rightToMaybe $ compile =<< (maybeToRight $ resolveBinding' name bindings) | |
+resolveBinding name bindings = rightToMaybe $ compileUnitTest =<< (maybeToRight $ resolveBinding' name bindings) | |
-- |Print last expression bound to | |
-- the _tmp_ variable in the bindings | |
@@ -105,7 +105,7 @@ printLastExpr :: (MonadIO m) | |
printLastExpr printer eval bindings = case lookup "_tmp_" bindings of | |
Nothing -> printer "Could not find _tmp_ in bindings" | |
Just upt -> do | |
- let compile' x = case compile x of | |
+ let compile' x = case compileUnitTest x of | |
Left err -> Left . show $ err | |
Right r -> Right r | |
case compile' =<< (process bindings (LetUP bindings upt)) of | |
@@ -136,7 +136,7 @@ replStep eval bindings s = do | |
outputStrLn $ "Parse error: " ++ err | |
return bindings | |
Right (ReplExpr new_bindings) -> do | |
- printLastExpr (outputStrLn) (liftIO . eval) new_bindings | |
+ printLastExpr outputStrLn (liftIO . eval) new_bindings | |
return bindings | |
Right (ReplAssignment new_bindings) -> do | |
return new_bindings | |
diff --git a/examples.tel b/examples.tel | |
index 7e1b0f6..33f58bb 100644 | |
--- a/examples.tel | |
+++ b/examples.tel | |
@@ -6,16 +6,16 @@ | |
-- -- refinement fail | |
-- main : (\x -> if x then "fail" else 0) = 1 | |
-abort : (\x -> "abort") = 1 | |
+-- abort : (\x -> "abort") = 1 | |
-- Ad hoc user defined types example: | |
MyInt = let wrapper = \h -> ( \i -> if not i | |
- then abort | |
+ then abort "MyInt cannot be 0" | |
else i | |
, \i -> if dEqual (left i) h | |
then 0 | |
- else abort | |
+ else abort "Not a MyInt" | |
) | |
in wrapper (# wrapper) | |
--- main = \i -> ((left MyInt) 0, 0) | |
-main = abort | |
+main = \i -> ((left MyInt) 0, 0) | |
+-- main = abort | |
diff --git a/src/Telomare.hs b/src/Telomare.hs | |
index ab52162..ed0fac9 100644 | |
--- a/src/Telomare.hs | |
+++ b/src/Telomare.hs | |
@@ -122,6 +122,7 @@ data ParserTerm l v | |
| TLimitedRecursion | |
deriving (Eq, Ord, Functor, Foldable, Traversable) | |
makeBaseFunctor ''ParserTerm -- Functorial version ParserTermF | |
+makePrisms ''ParserTerm | |
instance Plated (ParserTerm l v) where | |
plate f = \case | |
diff --git a/src/Telomare/Eval.hs b/src/Telomare/Eval.hs | |
index 068c78d..27666ad 100644 | |
--- a/src/Telomare/Eval.hs | |
+++ b/src/Telomare/Eval.hs | |
@@ -111,17 +111,35 @@ removeChecks (Term4 m) = | |
in Term4 $ Map.map (transform f) newM | |
runStaticChecks :: Term4 -> Maybe String | |
-runStaticChecks (Term4 termMap) = case ((toPossible (termMap Map.!) staticAbortSetEval AnyX (rootFrag termMap)) :: Either String (PossibleExpr Void Void)) of | |
- Left s -> pure s | |
- _ -> Nothing | |
- | |
-compile :: Term3 -> Either EvalError IExpr | |
-compile t = let sized = findChurchSize t | |
- in case runStaticChecks sized of | |
- Nothing -> case toTelomare $ removeChecks sized of | |
- Just i -> pure i | |
- Nothing -> Left CompileConversionError | |
- Just s -> Left $ StaticCheckError s | |
+runStaticChecks (Term4 termMap) = | |
+ case (toPossible (termMap Map.!) staticAbortSetEval AnyX (rootFrag termMap) :: Either String (PossibleExpr Void Void)) of | |
+ Left s -> pure s | |
+ _ -> Nothing | |
+ | |
+runStaticChecksMain :: Term4 -> Maybe String | |
+runStaticChecksMain (Term4 termMap) = | |
+ let (PairFrag (DeferFrag i) y) = rootFrag termMap | |
+ in case (toPossible (termMap Map.!) staticAbortSetEval AnyX (termMap Map.! i) :: Either String (PossibleExpr Void Void)) of | |
+ Left s -> pure s | |
+ _ -> Nothing | |
+ | |
+ | |
+compileMain :: Term3 -> Either EvalError IExpr | |
+compileMain = compile runStaticChecksMain | |
+ | |
+compileUnitTest :: Term3 -> Either EvalError IExpr | |
+compileUnitTest = compile runStaticChecks | |
+ | |
+compile :: (Term4 -> Maybe String) -> Term3 -> Either EvalError IExpr | |
+compile f t = | |
+ let sized = findChurchSize t | |
+ in case f sized of | |
+ Nothing -> case toTelomare $ removeChecks sized of | |
+ Just i -> pure i | |
+ Nothing -> Left CompileConversionError | |
+ Just s -> Left $ StaticCheckError s | |
+ | |
+ | |
{- | |
findAllSizes :: Term2 -> (Bool, Term3) | |
findAllSizes = let doChild (True, x) = TTransformedGrammar $ findChurchSize x | |
diff --git a/src/Telomare/Parser.hs b/src/Telomare/Parser.hs | |
index 587535c..dca4d97 100644 | |
--- a/src/Telomare/Parser.hs | |
+++ b/src/Telomare/Parser.hs | |
@@ -278,15 +278,15 @@ parseITE = do | |
elseExpr <- parseLongExpr <* scn | |
pure $ ITEUP cond thenExpr elseExpr | |
-parseUnique :: TelomareParser UnprocessedParsedTerm | |
-parseUnique = do | |
+parseHash :: TelomareParser UnprocessedParsedTerm | |
+parseHash = do | |
symbol "#" <* scn | |
upt <- parseSingleExpr :: TelomareParser UnprocessedParsedTerm | |
pure $ HashUP upt | |
-- |Parse a single expression. | |
parseSingleExpr :: TelomareParser UnprocessedParsedTerm | |
-parseSingleExpr = choice $ try <$> [ parseUnique | |
+parseSingleExpr = choice $ try <$> [ parseHash | |
, parseString | |
, parseNumber | |
, parsePair | |
@@ -448,6 +448,7 @@ makeLambda bindings str term1 = | |
v = vars term1 | |
unbound = (v \\ bindings') \\ Set.singleton str | |
+-- |Transformation from `UnprocessedParsedTerm` to `Term1` validating and inlining `VarUP`s | |
validateVariables :: [(String, UnprocessedParsedTerm)] -- ^ Prelude | |
-> UnprocessedParsedTerm | |
-> Either String Term1 | |
@@ -516,8 +517,8 @@ optimizeBuiltinFunctions = transform optimize where | |
-- |Process an `Term2` to have all `HashUP` replaced by a unique number. | |
-- The unique number is constructed by doing a SHA1 hash of the Term2 and | |
-- adding one for all consecutive HashUP's. | |
-generateAllUniques :: Term2 -> Term2 | |
-generateAllUniques = transform interm where | |
+generateAllHashes :: Term2 -> Term2 | |
+generateAllHashes = transform interm where | |
hash' :: ByteString -> Digest SHA256 | |
hash' = hash | |
term2Hash :: Term2 -> ByteString | |
@@ -529,10 +530,6 @@ generateAllUniques = transform interm where | |
THash term1 -> bs2Term2 . term2Hash $ term1 | |
x -> x | |
--- |All HashUP arguments of the form VarUP should be resolved | |
-resolveAllUniques :: UnprocessedParsedTerm -> UnprocessedParsedTerm | |
-resolveAllUniques = id | |
- | |
-- |Process an `UnprocessedParsedTerm` to a `Term3` with failing capability. | |
process :: [(String, UnprocessedParsedTerm)] -- ^Prelude | |
-> UnprocessedParsedTerm | |
@@ -542,10 +539,9 @@ process prelude upt = splitExpr <$> process2Term2 prelude upt | |
process2Term2 :: [(String, UnprocessedParsedTerm)] -- ^Prelude | |
-> UnprocessedParsedTerm | |
-> Either String Term2 | |
-process2Term2 prelude = fmap generateAllUniques | |
+process2Term2 prelude = fmap generateAllHashes | |
. debruijinize [] <=< validateVariables prelude | |
. optimizeBuiltinFunctions | |
- . resolveAllUniques | |
-- |Parse with specified prelude | |
parseWithPrelude :: [(String, UnprocessedParsedTerm)] -- ^Prelude | |
@@ -558,3 +554,11 @@ parseMain :: [(String, UnprocessedParsedTerm)] -- ^Prelude: [(VariableName, Bind | |
-> String -- ^Raw string to be parserd. | |
-> Either String Term3 -- ^Error on Left. | |
parseMain prelude s = parseWithPrelude prelude s >>= process prelude | |
+ | |
+ | |
+aux1 = unlines [ "let b = \\y -> y" | |
+ , "in (# b)" | |
+ ] | |
+aux2 = unlines [ "let a = \\x -> x" | |
+ , "in (# a)" | |
+ ] | |
diff --git a/src/Telomare/Possible.hs b/src/Telomare/Possible.hs | |
index fd8acf7..a78400a 100644 | |
--- a/src/Telomare/Possible.hs | |
+++ b/src/Telomare/Possible.hs | |
@@ -70,9 +70,12 @@ possibleString' x = case getFirstNonZero x of | |
type BasicPossible = PossibleExpr Void | |
-toPossible :: (Show a, Eq a, Show b, Eq b, Monad m) => (FragIndex -> FragExpr b) | |
- -> ((PossibleExpr a b -> FragExpr b -> m (PossibleExpr a b)) -> PossibleExpr a b-> PossibleExpr a b-> PossibleExpr a b -> m (PossibleExpr a b)) | |
- -> PossibleExpr a b -> FragExpr b -> m (PossibleExpr a b) | |
+toPossible :: (Show a, Eq a, Show b, Eq b, Monad m) | |
+ => (FragIndex -> FragExpr b) | |
+ -> ((PossibleExpr a b -> FragExpr b -> m (PossibleExpr a b)) -> PossibleExpr a b-> PossibleExpr a b-> PossibleExpr a b -> m (PossibleExpr a b)) | |
+ -> PossibleExpr a b | |
+ -> FragExpr b | |
+ -> m (PossibleExpr a b) | |
toPossible fragLookup setEval env = | |
let toPossible' = toPossible fragLookup setEval | |
recur = toPossible' env | |
diff --git a/telomare.cabal b/telomare.cabal | |
index 18fa38c..d92d5c3 100644 | |
--- a/telomare.cabal | |
+++ b/telomare.cabal | |
@@ -20,7 +20,6 @@ data-files: bench/MemoryBench/cases | |
library | |
hs-source-dirs: src | |
- , test | |
include-dirs: cbits/include | |
c-sources: cbits/Telomare.c | |
other-extensions: GADTs | |
@@ -44,7 +43,6 @@ library | |
, Telomare.TypeChecker | |
, Telomare.Serializer | |
, Telomare.Serializer.C | |
- , Common | |
build-depends: base | |
, base16-bytestring | |
, binary | |
@@ -77,7 +75,7 @@ library | |
extra-libraries: gc | |
, jumper | |
-- uncomment this line to get a cabal repl. Use appropiate complete path (will error with a relative path). | |
- -- extra-lib-dirs: /home/hhefesto/src/telomare/lib | |
+ extra-lib-dirs: /home/hhefesto/src/telomare/lib | |
default-language: Haskell2010 | |
ghc-options: -ddump-to-file -ddump-splices | |
diff --git a/test/Common.hs b/test/Common.hs | |
index 8513913..875c989 100644 | |
--- a/test/Common.hs | |
+++ b/test/Common.hs | |
@@ -297,3 +297,17 @@ instance Arbitrary Term1 where | |
TITE i t e -> i : t : e : [TITE ni nt ne | (ni, nt, ne) <- shrink (i,t,e)] | |
TPair a b -> a : b : [TPair na nb | (na, nb) <- shrink (a,b)] | |
TApp f i -> f : i : [TApp nf ni | (nf, ni) <- shrink (f,i)] | |
+ | |
+instance Arbitrary Term2 where | |
+ arbitrary = (arbitrary :: Gen Term1) | |
+ shrink = \case | |
+ TZero -> [] | |
+ TLimitedRecursion -> [] | |
+ TVar _ -> [] | |
+ TLeft x -> x : map TLeft (shrink x) | |
+ TRight x -> x : map TRight (shrink x) | |
+ TTrace x -> x : map TTrace (shrink x) | |
+ TLam v x -> x : map (TLam v) (shrink x) | |
+ TITE i t e -> i : t : e : [TITE ni nt ne | (ni, nt, ne) <- shrink (i,t,e)] | |
+ TPair a b -> a : b : [TPair na nb | (na, nb) <- shrink (a,b)] | |
+ TApp f i -> f : i : [TApp nf ni | (nf, ni) <- shrink (f,i)] | |
diff --git a/test/ParserTests.hs b/test/ParserTests.hs | |
index b6ee776..887dd71 100644 | |
--- a/test/ParserTests.hs | |
+++ b/test/ParserTests.hs | |
@@ -51,98 +51,82 @@ tests = testGroup "Tests" [unitTests, qcProps] | |
qcProps = testGroup "Property tests (QuickCheck)" | |
[ QC.testProperty "Arbitrary UnprocessedParsedTerm to test hash uniqueness of HashUP's" $ | |
\x -> | |
- containsHashUP x QC.==> checkAllUniques . generateAllUniques $ x | |
- , QC.testProperty "Have the total amount of HashUP + ListUP be equal to total ListUP after generateAllUniques" $ | |
+ containsTHash x QC.==> checkAllHashes . generateAllHashes $ x | |
+ , QC.testProperty "Have the total amount of HashUP + ListUP be equal to total ListUP after generateAllHashes" $ | |
\x -> | |
- containsHashUP x QC.==> checkNumberOfUniques x | |
- , QC.testProperty "See that generateAllUniques only changes HashUP to ListUP" $ | |
+ containsTHash x QC.==> checkNumberOfHashes x | |
+ , QC.testProperty "See that generateAllHashes only changes HashUP to ListUP" $ | |
\x -> | |
- containsHashUP x QC.==> onlyHashUPAndIntUP x | |
+ containsTHash x QC.==> onlyHashUPAndIntUP x | |
] | |
-checkNumberOfUniques :: UnprocessedParsedTerm -> Bool | |
-checkNumberOfUniques upt = let tupt = generateAllUniques upt | |
- in ((length $ upt ^.. (cosmos . _HashUP)) + (length $ upt ^.. (cosmos . _ListUP))) == (length $ tupt ^.. (cosmos . _ListUP)) | |
- | |
-containsHashUP :: UnprocessedParsedTerm -> Bool | |
-containsHashUP = \case | |
- HashUP _ -> True | |
- LetUP xs a -> containsHashUP a || (or $ (containsHashUP . snd) <$> xs) | |
- ITEUP a b c -> containsHashUP a || containsHashUP b || containsHashUP c | |
- ListUP ls -> or $ containsHashUP <$> ls | |
- PairUP a b -> containsHashUP a || containsHashUP b | |
- AppUP a b -> containsHashUP a || containsHashUP b | |
- CheckUP a b -> containsHashUP a || containsHashUP b | |
- LamUP _ a -> containsHashUP a | |
- LeftUP a -> containsHashUP a | |
- RightUP a -> containsHashUP a | |
- TraceUP a -> containsHashUP a | |
- x -> False | |
- | |
-onlyHashUPAndIntUP :: UnprocessedParsedTerm -> Bool | |
-onlyHashUPAndIntUP upt = let diffList = diffUPT (upt, generateAllUniques upt) | |
- isHashUP :: UnprocessedParsedTerm -> Bool | |
- isHashUP = \case | |
- HashUP _ -> True | |
- _ -> False | |
- isListUP :: UnprocessedParsedTerm -> Bool | |
- isListUP = \case | |
- ListUP _ -> True | |
- _ -> False | |
- in and $ fmap (isHashUP . fst) diffList ++ fmap (isListUP . snd) diffList | |
- | |
-diffUPT :: (UnprocessedParsedTerm, UnprocessedParsedTerm) -> [(UnprocessedParsedTerm, UnprocessedParsedTerm)] | |
-diffUPT = \case | |
- (ITEUP a b c, ITEUP a' b' c') -> diffUPT (a, a') ++ diffUPT (b, b') ++ diffUPT (c, c') | |
- (ListUP ls, ListUP ls') -> concat $ diffUPT <$> (zip ls ls') | |
- (PairUP a b, PairUP a' b') -> diffUPT (a, a') ++ diffUPT (b, b') | |
- (AppUP a b, AppUP a' b') -> diffUPT (a, a') ++ diffUPT (b, b') | |
- (CheckUP a b, CheckUP a' b') -> diffUPT (a, a') ++ diffUPT (b, b') | |
- (LamUP _ a, LamUP _ a') -> diffUPT (a, a') | |
- (LeftUP a, LeftUP a') -> diffUPT (a, a') | |
- (RightUP a, RightUP a') -> diffUPT (a, a') | |
- (TraceUP a, TraceUP a') -> diffUPT (a, a') | |
- (LetUP xs a, LetUP xs' a') -> diffUPT (a, a') ++ (concat $ diffUPT <$> zs) | |
- where ys = snd <$> xs | |
- ys'= snd <$> xs' | |
- zs = zip ys ys' | |
+checkNumberOfHashes :: Term2 -> Bool | |
+checkNumberOfHashes term2 = let tterm2 = generateAllHashes term2 | |
+ in (length (term2 ^.. (cosmos . _THash)) + length (term2 ^.. (cosmos . _TPair))) == length (tterm2 ^.. (cosmos . _TPair)) | |
+ | |
+containsTHash :: Term2 -> Bool | |
+containsTHash = \case | |
+ THash _ -> True | |
+ TITE a b c -> containsTHash a || containsTHash b || containsTHash c | |
+ TPair a b -> containsTHash a || containsTHash b | |
+ TApp a b -> containsTHash a || containsTHash b | |
+ TCheck a b -> containsTHash a || containsTHash b | |
+ TLam _ a -> containsTHash a | |
+ TLeft a -> containsTHash a | |
+ TRight a -> containsTHash a | |
+ TTrace a -> containsTHash a | |
+ x -> False | |
+ | |
+onlyHashUPAndIntUP :: Term2 -> Bool | |
+onlyHashUPAndIntUP term2 = let diffList = diffTerm2 (term2, generateAllHashes term2) | |
+ isHash :: Term2 -> Bool | |
+ isHash = \case | |
+ THash _ -> True | |
+ _ -> False | |
+ in and $ fmap (isHash . fst) diffList | |
+ | |
+diffTerm2 :: (Term2, Term2) -> [(Term2, Term2)] | |
+diffTerm2 = \case | |
+ (TITE a b c, TITE a' b' c') -> diffTerm2 (a, a') <> diffTerm2 (b, b') <> diffTerm2 (c, c') | |
+ (TPair a b, TPair a' b') -> diffTerm2 (a, a') <> diffTerm2 (b, b') | |
+ (TApp a b, TApp a' b') -> diffTerm2 (a, a') <> diffTerm2 (b, b') | |
+ (TCheck a b, TCheck a' b') -> diffTerm2 (a, a') <> diffTerm2 (b, b') | |
+ (TLam _ a, TLam _ a') -> diffTerm2 (a, a') | |
+ (TLeft a, TLeft a') -> diffTerm2 (a, a') | |
+ (TRight a, TRight a') -> diffTerm2 (a, a') | |
+ (TTrace a, TTrace a') -> diffTerm2 (a, a') | |
(x, x') | x /= x' -> [(x, x')] | |
_ -> [] | |
-checkAllUniques :: UnprocessedParsedTerm -> Bool | |
-checkAllUniques = noDups . allUniquesToIntUPList | |
+checkAllHashes :: Term2 -> Bool | |
+checkAllHashes = noDups . allHashesToTerm2 | |
noDups = not . f [] | |
where | |
f seen (x:xs) = x `elem` seen || f (x:seen) xs | |
f seen [] = False | |
-allUniquesToIntUPList :: UnprocessedParsedTerm -> [[UnprocessedParsedTerm]] | |
-allUniquesToIntUPList upt = | |
- let uptWithUniquesAsInts = generateAllUniques upt | |
- interm :: (UnprocessedParsedTerm, UnprocessedParsedTerm) -> [[UnprocessedParsedTerm]] | |
+allHashesToTerm2 :: Term2 -> [Term2] | |
+allHashesToTerm2 term2 = | |
+ let term2WithoutTHash = generateAllHashes term2 | |
+ interm :: (Term2, Term2) -> [Term2] | |
interm = \case | |
- (HashUP _ , ListUP x) -> [x] | |
- (ITEUP a b c, ITEUP a' b' c') -> interm (a, a') ++ interm (b, b') ++ interm (c, c') | |
- (ListUP ls, ListUP ls') -> concat $ interm <$> (zip ls ls') | |
- (PairUP a b, PairUP a' b') -> interm (a, a') ++ interm (b, b') | |
- (AppUP a b, AppUP a' b') -> interm (a, a') ++ interm (b, b') | |
- (CheckUP a b, CheckUP a' b') -> interm (a, a') ++ interm (b, b') | |
- (LamUP _ a, LamUP _ a') -> interm (a, a') | |
- (LeftUP a, LeftUP a') -> interm (a, a') | |
- (RightUP a, RightUP a') -> interm (a, a') | |
- (TraceUP a, TraceUP a') -> interm (a, a') | |
- (LetUP xs a, LetUP xs' a') -> interm (a, a') ++ (concat $ interm <$> zs) | |
- where ys = snd <$> xs | |
- ys'= snd <$> xs' | |
- zs = zip ys ys' | |
- (x, x') | x /= x' -> error "x and x' should be the same (inside of allUniquesToIntUPList, within interm)" | |
+ (THash _ , x) -> [x] | |
+ (TITE a b c, TITE a' b' c') -> interm (a, a') <> interm (b, b') <> interm (c, c') | |
+ (TPair a b, TPair a' b') -> interm (a, a') <> interm (b, b') | |
+ (TApp a b, TApp a' b') -> interm (a, a') <> interm (b, b') | |
+ (TCheck a b, TCheck a' b') -> interm (a, a') <> interm (b, b') | |
+ (TLam _ a, TLam _ a') -> interm (a, a') | |
+ (TLeft a, TLeft a') -> interm (a, a') | |
+ (TRight a, TRight a') -> interm (a, a') | |
+ (TTrace a, TTrace a') -> interm (a, a') | |
+ (x, x') | x /= x' -> error "x and x' should be the same (inside of allHashesToTerm2, within interm)" | |
(x, x') -> [] | |
- in curry interm upt uptWithUniquesAsInts | |
+ in curry interm term2 term2WithoutTHash | |
-- debruijinize [] <=< validateVariables prelude | |
-- . optimizeBuiltinFunctions | |
--- . generateAllUniques | |
+-- . generateAllHashes | |
aux1 = unlines [ "let a = \\y -> y" | |
, "in (# a)" | |
@@ -162,18 +146,19 @@ hashtest1 = unlines ["let var = 3", | |
" in (# var)"] | |
unitTests :: TestTree | |
unitTests = testGroup "Unit tests" | |
- [ testCase "different variable names get different hashes" $ do | |
- res1 <- extract <$> generateAllUniques <$> runTelomareParser parseLet hashtest0 | |
- res2 <- extract <$> generateAllUniques <$> runTelomareParser parseLet hashtest1 | |
- (res1 == res2) `compare` False @?= EQ | |
+ -- [ | |
+ -- testCase "different variable names get different hashes" $ do | |
+ -- res1 <- extract . generateAllHashes <$> runTelomareParser parseLet hashtest0 | |
+ -- res2 <- extract . generateAllHashes <$> runTelomareParser parseLet hashtest1 | |
+ -- (res1 == res2) `compare` False @?= EQ | |
-- #^This commmented test tests if two variables having the same value are assigned the same hash | |
--, | |
--testCase "same functions have the same hash" $ do | |
- -- res1 <- extract <$> generateAllUniques <$> runTelomareParser parseLet aux1 | |
- -- res2 <- extract <$> generateAllUniques <$> runTelomareParser parseLet aux2 | |
+ -- res1 <- extract <$> generateAllHashes <$> runTelomareParser parseLet aux1 | |
+ -- res2 <- extract <$> generateAllHashes <$> runTelomareParser parseLet aux2 | |
-- res1 `compare` res2 @?= EQ | |
- , testCase "parse uniqueUP" $ do | |
- res <- parseSuccessful parseUnique "# (\\x -> x)" | |
+ [ testCase "parse uniqueUP" $ do | |
+ res <- parseSuccessful parseHash "# (\\x -> x)" | |
res `compare` True @?= EQ | |
, testCase "Ad hoc user defined types success" $ do | |
res <- testUserDefAdHocTypes userDefAdHocTypesSuccess | |
@@ -354,7 +339,7 @@ testUserDefAdHocTypes input = do | |
Right p -> p | |
Left pe -> error pe | |
runMain :: String -> IO String | |
- runMain s = case compile <$> parseMain prelude s of | |
+ runMain s = case compileUnitTest <$> parseMain prelude s of | |
Left e -> error $ concat ["failed to parse ", s, " ", e] | |
Right (Right g) -> evalLoop_ g | |
Right z -> error $ "compilation failed somehow, with result " <> show z | |
@@ -824,8 +809,8 @@ testList5 = unlines $ | |
-- p str = State.runStateT $ parseMain prelude str | |
-- case runParser (dbg "debug" p) "" tictactoe of | |
-- Right (a, s) -> do | |
--- putStrLn ("Result: " ++ show a) | |
--- putStrLn ("Final state: " ++ show s) | |
+-- putStrLn ("Result: " <> show a) | |
+-- putStrLn ("Final state: " <> show s) | |
-- Left err -> putStr (errorBundlePretty err) | |
-- runTictactoe = do | |
@@ -834,11 +819,11 @@ testList5 = unlines $ | |
-- let | |
-- prelude = case parsePrelude preludeFile of | |
-- Right p -> p | |
--- Left pe -> error $ "woot2!!!" ++ getErrorString pe | |
+-- Left pe -> error $ "woot2!!!" <> getErrorString pe | |
-- putStrLn "Not broken till here." | |
-- case parseMain' prelude $ tictactoe of | |
-- Right x -> putStrLn . show $ x | |
--- Left err -> putStrLn $ "woot!!! " ++ getErrorString err | |
+-- Left err -> putStrLn $ "woot!!! " <> getErrorString err | |
-- -- |Parse main. | |
diff --git a/test/Spec.hs b/test/Spec.hs | |
index 86b98f2..48de6b2 100644 | |
--- a/test/Spec.hs | |
+++ b/test/Spec.hs | |
@@ -640,7 +640,7 @@ nexprTests = do | |
foreign import capi "gc.h GC_INIT" gcInit :: IO () | |
foreign import ccall "gc.h GC_allow_register_threads" gcAllowRegisterThreads :: IO () | |
-unitTest2' parse s r = it s $ case fmap compile (parse s) of | |
+unitTest2' parse s r = it s $ case fmap compileUnitTest (parse s) of | |
Left e -> expectationFailure $ concat ["failed to parse ", s, " ", show e] | |
Right (Right g) -> fmap (show . PrettyIExpr) (testEval g) >>= \r2 -> if r2 == r | |
then pure () |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment