├── .gitignore ├── Makefile ├── README.md ├── alb.cabal ├── cabal.project ├── doc ├── calling_from_c.txt ├── habit-aligned-mem-proposal.txt ├── index.txt ├── pipeline.pdf ├── pipeline.tex ├── pipeline.txt ├── primitives.txt └── tests.txt ├── examples ├── bst.hb ├── fib.hb ├── fibsigned.hb ├── gdtac.hb └── three.hb ├── lib ├── io.hb ├── list.hb ├── mem.hb ├── prelude.hb └── test.hb ├── libraries ├── README.md ├── indentation-core │ ├── CHANGELOG.md │ ├── LICENSE │ ├── README.md │ ├── Setup.hs │ ├── indentation-core.cabal │ └── src │ │ └── Text │ │ └── Parser │ │ └── Indentation │ │ └── Implementation.hs └── indentation-parsec │ ├── CHANGELOG.md │ ├── LICENSE │ ├── README.md │ ├── Setup.hs │ ├── indentation-parsec.cabal │ ├── src │ └── Text │ │ └── Parsec │ │ ├── Indentation.hs │ │ └── Indentation │ │ ├── Char.hs │ │ └── Token.hs │ └── tests │ ├── ParensParsec.hs │ └── all-tests.hs ├── perftest ├── .gitignore ├── Makefile ├── README ├── ackermann.hb ├── area1.hb ├── basicloop.hb ├── cheney.hb ├── diff.sh ├── eq.hb ├── eqloop.hb ├── md5.hb ├── md5demo.hb ├── monad1.hb ├── monad2.hb ├── monad3.hb ├── monad4.hb ├── mutualrecursion.hb ├── mutualrecursion.hs ├── neq.hb ├── neqloop.hb ├── newbool.hb ├── newboolperftest.hb ├── newbooltest.hb ├── nmeq.hb ├── nmneq.hb ├── prelude.hb ├── recurse.hb ├── shalloweq.hb ├── shallowneq.hb ├── shallowrecurse.hb ├── sortarea.hb ├── sortheap.hb └── test.sh ├── samples └── dtac.hb ├── src ├── Analyzer.hs ├── Analyzer │ ├── Desugaring.hs │ ├── Fixity.hs │ ├── Freshening.hs │ ├── FunctionalNotation.hs │ ├── LabeledFields.hs │ └── Tuples.hs ├── Common.hs ├── CompCert.hs ├── Driver.hs ├── Fidget │ └── Env.hs ├── Ilab.hs ├── LC.hs ├── Literate.lhs ├── MILTools.hs ├── Mon6a.lhs ├── Normalizer.hs ├── Normalizer │ ├── Eta.hs │ ├── Inliner.lhs │ └── Matches.lhs ├── Parser.hs ├── Parser │ ├── Lexer.hs │ └── Main.hs ├── Printer │ ├── Common.hs │ ├── IMPEG.hs │ ├── LambdaCaseAbstract.hs │ ├── PrettyMPEG.hs │ ├── Specialized.lhs │ ├── Surface.hs │ ├── WadlerLeijen.hs │ └── XMPEG.hs ├── Solver.hs ├── Solver │ ├── All.hs │ ├── Cycles.hs │ ├── Main.hs │ ├── Oracles.hs │ ├── PP.hs │ ├── Parser.hs │ ├── REPL.hs │ ├── Subst.hs │ ├── Syntax.hs │ ├── Tactics.hs │ ├── Trace.hs │ └── Validation.hs ├── Specializer.lhs ├── Syntax │ ├── Common.hs │ ├── IMPEG.hs │ ├── IMPEG │ │ ├── KSubst.hs │ │ └── TSubst.hs │ ├── MangleIds.hs │ ├── Specialized.lhs │ ├── Surface.hs │ ├── XMPEG.hs │ └── XMPEG │ │ └── TSubst.hs ├── Typechecker.hs ├── Typechecker │ ├── Cleanup.hs │ ├── KindInference.hs │ ├── LambdaCaseTyping.hs │ ├── TypeInference.hs │ └── TypeInference │ │ ├── Base.hs │ │ ├── Expr.hs │ │ ├── Instances.hs │ │ └── TopDecl.hs ├── Utils │ └── BDD.lhs └── albc │ ├── Albc.hs │ ├── LICENSE │ ├── Setup.hs │ └── albc.cabal ├── stack.yaml └── tests ├── Bench.hb ├── BigArray.hb ├── Lambda.hb ├── Makefile ├── Mersenne.hb ├── PatternMatchStr.hb ├── Solver └── RunTests.hs ├── State.hb ├── areas.hb ├── bubble.hb ├── bug0050.hb ├── bug0677.hb ├── bug25.hb ├── bugIxBound.hb ├── example-test.hb ├── fieldlabels.hb ├── flexPages_noLit.hb ├── foo.hb ├── fragments ├── assocTypes.lhb ├── bitdata.hb ├── caseExprs.lhb ├── caseFromTests.lhb ├── colonhash.hb ├── confusedJunk.hb ├── defaults.hb ├── doNotation.lhb ├── evcase.hb ├── flexpages.lhb ├── fundeps.hb ├── funnote.hb ├── ifExprs.lhb ├── kpoly.hb └── literals.lhb ├── from_c.hb ├── from_c_driver.c ├── habit_callbacks.c ├── io-test.hb ├── io.hb ├── largeword-driver.hb ├── largeword.hb ├── list.hb ├── listdriver.hb ├── local.hb ├── logical.hb ├── make_from_c.sh ├── map.hb ├── md5.hb ├── md5demo.hb ├── md5driver.hb ├── mem.hb ├── miniprelude.hb ├── minprel.hb ├── monad.hb ├── ondeckprelude.hb ├── opaque ├── Divisor.hb ├── Stack.hb └── Stack2.hb ├── overloaded.hb ├── patbind.hb ├── point.lhb ├── preltests.hb ├── prelude.hb ├── primclass.hb ├── primclass.lhb ├── prioset.lhb ├── punning.lhb ├── qualicon ├── bogus.hb ├── escape.hb ├── expr.hb ├── qprelude.hb ├── set.hb └── syn.hb ├── redblack.hb ├── repeatedType.hb ├── requirements.hb ├── simpleClass.hb ├── skip_typeNats_noLit.hb ├── solver ├── catalog ├── results │ ├── 2 │ ├── 3 │ ├── 5 │ ├── 6 │ ├── 8 │ ├── 9 │ ├── 2-p │ ├── 3-p │ ├── 5-p │ ├── 6-p │ ├── 8-p │ ├── 9-p │ ├── arith-p │ ├── assumption-cases │ ├── assumption-cases-p │ ├── cases │ ├── cases-p │ ├── cases2 │ ├── cases2-p │ ├── cyclic1 │ ├── cyclic1-p │ ├── dtac │ ├── dtac-p │ ├── fd2 │ ├── fd2-p │ ├── fd3 │ ├── fd3-p │ ├── fd3a │ ├── fd3b │ ├── fd3c │ ├── fd4 │ ├── fd4-p │ ├── funwithfds │ ├── funwithfds-p │ ├── generic │ ├── generic-p │ ├── generic2 │ ├── generic2-p │ ├── hlist │ ├── hlist-p │ ├── impr1 │ ├── impr1-p │ ├── impr10 │ ├── impr10-p │ ├── impr2 │ ├── impr2-p │ ├── impr2b │ ├── impr2b-p │ ├── impr4 │ ├── impr4-p │ ├── impr5 │ ├── impr5-p │ ├── impr6 │ ├── impr6-p │ ├── impr7 │ ├── impr7-p │ ├── impr8 │ ├── impr8-p │ ├── impr9 │ ├── impr9-p │ ├── log2 │ ├── log2-p │ ├── loop │ ├── loop-p │ ├── opaque1 │ ├── opaque1-p │ ├── oracle │ ├── oracle-p │ ├── peano │ ├── peano-p │ ├── primrq │ ├── rq1 │ ├── rq1-p │ ├── rq2 │ ├── rq2-p │ ├── rq3 │ ├── rq3-p │ ├── rq4 │ ├── rq4-p │ ├── simpl1 │ └── simpl1-p └── tests │ ├── 1 │ ├── 2 │ ├── 3 │ ├── 4 │ ├── 5 │ ├── 6 │ ├── 7 │ ├── 8 │ ├── 9 │ ├── Overlap.hs │ ├── assumption-cases │ ├── cases │ ├── cases2 │ ├── casesx │ ├── cycle │ ├── cyclic1 │ ├── dtac │ ├── dtac_tests │ ├── fd2 │ ├── fd3 │ ├── fd3a │ ├── fd3b │ ├── fd3c │ ├── fd4 │ ├── funwithfds │ ├── generic │ ├── generic2 │ ├── hlist │ ├── impr1 │ ├── impr10 │ ├── impr2 │ ├── impr2b │ ├── impr3 │ ├── impr4 │ ├── impr5 │ ├── impr6 │ ├── impr7 │ ├── impr8 │ ├── impr9 │ ├── log2 │ ├── loop │ ├── opaque1 │ ├── oracle_arithmetic │ ├── oracle_arithmetic_tests │ ├── peano │ ├── peano_tests │ ├── primrq │ ├── refine │ ├── rq1 │ ├── rq2 │ ├── rq3 │ ├── rq4 │ ├── rqfd.ilab │ ├── rvcoerce │ ├── simpl1 │ └── sort ├── struct.hb ├── structs.lhb ├── super.hb ├── synth.hb ├── test.hb ├── testHarness.hs ├── thih.hb ├── three.hb ├── tuples.hb ├── tuples2.hb ├── typeNats.lhb ├── typeNats_noLit.hb ├── typeSynOverlap.hb ├── unsz.hb └── zerobitdata.hb /.gitignore: -------------------------------------------------------------------------------- 1 | # Log files 2 | *.log 3 | *.err 4 | 5 | # Haskell specific directories 6 | dist/ 7 | dist-newstyle/ 8 | *.hi 9 | *.o 10 | 11 | # Build artifacts/executables 12 | obj/* 13 | *.exe 14 | *.out 15 | *.bat 16 | 17 | # Misc dot files 18 | .* 19 | 20 | # Cabal files 21 | cabal.project.local 22 | cabal.project.local\~* 23 | ./**/cabal.project.local 24 | 25 | # backup files 26 | ./**/*.*\~ -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | include tests/Makefile 2 | 3 | # executables to be produced 4 | TARGETS=install-ilab install-alb 5 | 6 | # This directory stores the executables for alb and ilab 7 | # This path should be added to $PATH or %PATH% 8 | BINDIR = $(HOME)/.local/bin 9 | 10 | .PHONY: all 11 | 12 | all: alb ilab tests-alb tests-ilab 13 | 14 | alb: 15 | cabal build --user alb 16 | 17 | ilab: 18 | cabal build --user ilab 19 | 20 | install-alb: alb tests-alb 21 | cabal install --user alb --symlink-bindir=$(BINDIR) 22 | 23 | install-ilab: ilab tests-ilab 24 | cabal install --user ilab --symlink-bindir=$(BINDIR) 25 | 26 | clean: 27 | rm -fr $(OBJDIR) .cabal-sandbox dist-newstyle dist $(BINDIR)/alb $(BINDIR)/ilab alb ilab 28 | rm -rf **/*.o 29 | rm -rf **/*.out 30 | rm -rf $(TESTS) 31 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: libraries/indentation-core 2 | , libraries/indentation-parsec 3 | , . 4 | -------------------------------------------------------------------------------- /doc/index.txt: -------------------------------------------------------------------------------- 1 | The documentation in this folder is organized as follows: 2 | 3 | pipeline.txt: Gives a short summary of what each pass is for 4 | Note: pipeline.tex is a slightly older and now out-of-date graphic of the pipeline. 5 | 6 | primitives.txt: Describes how to call C functions as primitives from Habit. 7 | 8 | calling_from_c.txt: Describes how to call Habit code from C 9 | 10 | tests.txt: Describes the testing framework and how to add new tests 11 | -------------------------------------------------------------------------------- /doc/pipeline.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/habit-lang/alb/67a5429f3685a010b4ac4e6f8392ec577fe2b28b/doc/pipeline.pdf -------------------------------------------------------------------------------- /doc/primitives.txt: -------------------------------------------------------------------------------- 1 | Habit allow the user to declare new primitive functions that are 2 | defined by arbitrary C functions. These primitive functions 3 | effectively use a basic FFI that operates as follows. An example of 4 | using such primitives is found habitat/compiler/tests/io.hb which 5 | declares the 'getchar', 'putchar' and 'fflush' primitives. 6 | 7 | In order to declare a primitive, one simply declares the type 8 | signature the Habit should see for the function and prefixes the 9 | signature with the keyword 'primitive'. For example, we declare the 10 | 'putchar' primitive with: 11 | 12 | primitive putchar :: Unsigned -> M Unsigned 13 | 14 | Note that the name 'putchar' correspond both to the name that Habit 15 | sees internally and to name of the external function that it will link 16 | to. (At some point in the future we may add a syntax so these can be 17 | different from each other.) 18 | 19 | At the Fidget level, the types of these functions are uncurried. 20 | Occurrences in of Fint, Fix and Fref in the type are all translated to 21 | CMInt (i.e., C integers), and functions return Funit are given a void 22 | return type. Any other types are disallowed. 23 | 24 | At the Habit level this means that the type of a primitive function is 25 | translated to a C type by first uncurrying the function type. 26 | 'Unsigned', 'Ix n', and 'Ref a' types are then translated to a C 27 | integer. A function that returns 'Unit' becomes a void function. 28 | 29 | The final wrinkle in this translation is that a function may be either 30 | monadic or non-monadic. For example 'putchar' returns 'M Unsigned'. 31 | Before translation to a C type, the 'M' will be stripped off so the C 32 | signature of the corresponding function is: 33 | 34 | int putchar(int); 35 | 36 | However, the 'M' does still have significance. If the 'M' is omitted 37 | then the function is treated as being pure, but if the 'M' is included 38 | then Habit knows that the primitive function has a side effect and 39 | will thus ensure that calls to the primitive are properly sequenced. 40 | For example, 'putchar' has an IO effect, and thus the 'M' needs to be 41 | included. However this 'M' does not show up in the C signature for 42 | the function. 43 | -------------------------------------------------------------------------------- /doc/tests.txt: -------------------------------------------------------------------------------- 1 | The habitat/compiler/tests folder contains a test suite that can be 2 | run simply by executing the Makefile in that directory as follows: 3 | 4 | $ cd habitat/compiler/tests 5 | $ make 6 | 7 | Adding a test to that test suite involves, first, creating a file for 8 | that test, and second, adding that test to the list of tests to be 9 | run. 10 | 11 | -------------------- 12 | Creating a Test File 13 | -------------------- 14 | 15 | The test harness fundamentally expects a testing program to be one 16 | that returns an exit code of zero when everything is okay and returns 17 | an exit code with the number of tests that failed when things go 18 | wrong. 19 | 20 | The 'test' library for habit helps in creating creating these files. 21 | To use it you must: 22 | - import the library with 'requires test' 23 | - call 'runTests' on a list of individual tests. Each individual 24 | test should be a monadic action of type "M Bool" that returns True 25 | if the test passes and False if the test fails. 26 | - return the result of 'runTests' from the main function. 27 | 28 | A trivial example of using the 'test' library is included the file 29 | 'habitat/compier/tests/example-test.hb' which is a good template to 30 | start from when writing your own tests. 31 | 32 | -------------------- 33 | Adding to the list of tests 34 | -------------------- 35 | 36 | In habitat/compiler/tests/Makefile there are two variables: 'TESTS' 37 | and 'BROKEN_TESTS'. To have the Makefile actually run your test you 38 | need to add your test to the list of files in 'TESTS' or 39 | 'BROKEN_TESTS'. The tests in 'TESTS' are run by default and are 40 | expected to succeed. On the other hand the tests in 'BROKEN_TESTS' 41 | are not run by default as they have known bugs and are expected to 42 | fail. 43 | 44 | Note that the filename you add to each of these variables is *not* the 45 | filename of the tests source code. Rather it is the name of the 46 | resulting executable. The other rules in the Makefile take care of 47 | turning your source file into an executable. 48 | -------------------------------------------------------------------------------- /examples/bst.hb: -------------------------------------------------------------------------------- 1 | requires prelude 2 | requires io 3 | 4 | data Ord a => BST a = Leaf | Node a (BST a) (BST a) 5 | 6 | empty :: BST a 7 | empty = Leaf 8 | 9 | insert :: a -> BST a -> BST a 10 | insert x Leaf = Node x Leaf Leaf 11 | insert x t@(Node y l r) 12 | | x == y = t 13 | | x < y = Node y (insert x l) r 14 | | x > y = Node y l (insert x r) 15 | 16 | tree1 = insert (1 :: Unsigned) (insert 2 (insert 3 empty)) 17 | tree2 = insert (2 :: Signed) (insert 4 (insert (negate 2) empty)) 18 | -- Should fail: 19 | -- three3 = insert (id :: Unsigned -> Unsigned) empty 20 | 21 | printInOrder Leaf = return () 22 | printInOrder (Node x l r) = do printInOrder l 23 | putint (unsigned x) 24 | putStr " " 25 | printInOrder r 26 | 27 | class Functor f 28 | where fmap :: (a -> b) -> f a -> f b 29 | 30 | -- To avoid tedium, assuming that f is monotonic... 31 | instance Functor BST 32 | where fmap f Leaf = Leaf 33 | fmap f (Node y l r) = Node (f y) (fmap f l) (fmap f r) 34 | 35 | telem :: a -> BST a -> Bool 36 | telem x Leaf = False 37 | telem x (Node y l r) 38 | | x == y = True 39 | | x < y = telem x l 40 | | x > y = telem x r 41 | 42 | allIn :: BST a -> BST a -> Bool 43 | allIn Leaf _ = True 44 | allIn (Node x l r) t = telem x t && allIn l t && allIn r t 45 | 46 | instance Eq (BST a) 47 | where t == u = allIn t u && allIn u t 48 | 49 | main = do printInOrder tree1 50 | putLine 51 | printInOrder tree2 52 | putLine 53 | printInOrder (fmap (1 +) tree1) 54 | putLine 55 | if fmap (1 +) tree2 == tree2 then putint 0 else putint 1 -------------------------------------------------------------------------------- /examples/fib.hb: -------------------------------------------------------------------------------- 1 | requires prelude 2 | requires io 3 | 4 | fib :: Unsigned -> Unsigned 5 | fib 0 = 1 6 | fib 1 = 1 7 | fib n = fib (n - 1) + fib (n - 2) 8 | 9 | main :: M Unsigned 10 | main = do x <- return () 11 | putint (fib 15) 12 | return (fib 15) 13 | -------------------------------------------------------------------------------- /examples/fibsigned.hb: -------------------------------------------------------------------------------- 1 | requires prelude 2 | requires io 3 | 4 | fib :: Signed -> Signed 5 | fib n 6 | | n < 2 = n 7 | | otherwise = fib (n - 1) + fib (n - 2) 8 | 9 | main :: M Unsigned 10 | main = do x <- return () 11 | putint (unsigned (fib 15)) 12 | return (unsigned (fib 15)) 13 | -------------------------------------------------------------------------------- /lib/io.hb: -------------------------------------------------------------------------------- 1 | requires prelude 2 | requires list 3 | 4 | -- Perhaps these types could be updated? I'm guessing that putchar should really return unit, and 5 | -- fflush doesn't need an argument? 6 | 7 | primitive getchar :: M Unsigned -- really should be Signed for -1 8 | primitive putchar :: Unsigned -> M Unsigned 9 | primitive fflush :: Unsigned -> M Unsigned 10 | 11 | flush :: M () 12 | flush = do 13 | b <- return True 14 | fflush 0 15 | return () 16 | 17 | getint :: M Unsigned 18 | getint = do x0 <- getchar 19 | if x0 == (negate 1) 20 | then return (negate 1) 21 | else do x1 <- getchar 22 | if x1 == (negate 1) 23 | then return (negate 1) 24 | else do x2 <- getchar 25 | if x2 == (negate 1) 26 | then return (negate 1) 27 | else do x3 <- getchar 28 | if x3 == (negate 1) 29 | then return (negate 1) 30 | else return (x3 `shiftL` 24 + x2 `shiftL` 16 + x1 `shiftL` 8 + x0) 31 | 32 | putint :: Unsigned -> M () 33 | putint d | d < 10 = do putchar (d + 0x30); return () 34 | | True = do putint (div10 d); putint (mod10 d) 35 | where mod10 :: Unsigned -> Unsigned 36 | mod10 x = unsigned (modIx x :: Ix 10) 37 | 38 | div10 :: Unsigned -> Unsigned 39 | div10 x | x < 10 = 0 40 | | True = f 1 41 | where f k = if x < 100 * k || k >= maxK then k + div10 (x - (10 * k)) else f (k * 10) 42 | maxK = 10000000 43 | 44 | putHexChar :: Unsigned -> M Unsigned 45 | putHexChar d | d < 0xa = putchar (d + 0x30) 46 | | True = putchar (d + 0x37) 47 | 48 | putHexInt :: Unsigned -> M () 49 | putHexInt d | d < 16 = do putHexChar d; return () 50 | | True = do putHexInt (d `shiftR` 4); putHexInt (d .&. 0xF) 51 | 52 | putLine :: M Unsigned 53 | putLine = do 54 | x <- return () 55 | putchar 0x0A 56 | 57 | readInts :: M (List (Bit 32)) 58 | readInts = do 59 | x <- getint 60 | if x == (negate 1) then return Nil else do { xs <- readInts; return (Cons x.bits xs) } 61 | 62 | 63 | putStr :: List Unsigned -> M Unsigned 64 | putStr Nil = return (0) 65 | putStr (Cons x xs) = do putchar x 66 | putStr xs 67 | -------------------------------------------------------------------------------- /lib/mem.hb: -------------------------------------------------------------------------------- 1 | requires prelude 2 | 3 | readRef = primReadRefStored 4 | writeRef = primWriteRefStored 5 | 6 | 7 | primitive primReadRefStored :: Ref (Stored a) -> M a 8 | primitive primWriteRefStored :: Ref (Stored a) -> a -> M () 9 | 10 | -- class MemMonad m | Monad m 11 | -- where memZero :: ARef l a -> m () 12 | -- memCopy :: ARef l a -> ARef l' a -> m () 13 | -- readRef :: ARef l a -> m (ValIn a) 14 | -- writeRef :: ARef l a -> ValIn a -> m () 15 | -- 16 | -- instance MemMonad M 17 | -- where memZero = primMemZero 18 | -- memCopy = primMemCopy 19 | -- readRef = primReadRef 20 | -- writeRef = primWriteRef 21 | -- 22 | -- primitive primMemZero :: ARef l a -> M () 23 | -- primitive primMemCopy :: ARef l a -> ARef l' a -> M () 24 | -- primitive primReadRef :: ARef l a -> M (ValIn a) 25 | -- primitive primWriteRef :: ARef l a -> ValIn a -> M () -------------------------------------------------------------------------------- /lib/test.hb: -------------------------------------------------------------------------------- 1 | requires prelude 2 | requires list 3 | requires io 4 | 5 | equalM x m = do 6 | m' <- m 7 | return (x == m') 8 | 9 | runTests :: List (M Bool) -> M Unsigned 10 | runTests xs = f 0 0 xs where 11 | passChar = 0x2E 12 | failChar = 0x58 13 | f :: Unsigned -> Unsigned -> List (M Bool) -> M Unsigned 14 | f pass total Nil = do 15 | putchar 0x20 -- space 16 | putchar 0x5B -- [ 17 | putint pass 18 | putchar 0x20 -- space 19 | putchar 0x6F -- o 20 | putchar 0x66 -- f 21 | putchar 0x20 -- space 22 | putint total 23 | putchar 0x20 -- space 24 | putchar 0x74 -- t 25 | putchar 0x65 -- e 26 | putchar 0x73 -- s 27 | putchar 0x74 -- t 28 | putchar 0x73 -- s 29 | putchar 0x20 -- space 30 | putchar 0x70 -- p 31 | putchar 0x61 -- a 32 | putchar 0x73 -- s 33 | putchar 0x73 -- s 34 | putchar 0x5D -- ] 35 | putchar 0x0A -- \n 36 | return (total - pass) 37 | f pass total (Cons m ms) = do 38 | pass' <- if<- m then do putchar passChar; return (pass+1) else do putchar failChar; return pass 39 | flush 40 | f pass' (total+1) ms 41 | -------------------------------------------------------------------------------- /libraries/README.md: -------------------------------------------------------------------------------- 1 | Alb depends on the following 2 external libraries: 2 | 3 | 1. indentation-core 4 | 2. indentation-parsec 5 | 6 | However, they have not been maintained on hackage in the recent past. 7 | As a workaround they have been added here. 8 | 9 | Incase you need to add more libraries (hackage packages), 10 | you can add a new folder under `alb/libraries` and then add the package path in `alb/cabal.project` 11 | under `packages` stanza. Don't forget to add the dependency in `alb/alb.cabal` 12 | -------------------------------------------------------------------------------- /libraries/indentation-core/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # 0.0.0.2 2 | 3 | * Bump `base` for GHC 8.6.1 (and 8.4.3) 4 | 5 | # 0.0.0.1 6 | 7 | * Bump `base` bounds to support GHC 8.2.1 8 | 9 | # 0.0 10 | 11 | * Split `indentation` into separate `indentation-core`, `indentation-parsec` and `indentation-trifecta` packages. 12 | Keep the original `indentation` for backward compatability and as a general roll-up package. 13 | -------------------------------------------------------------------------------- /libraries/indentation-core/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Michael D. Adams 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | 1. Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | 2. Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | 3. Neither the name of the copyright holder nor the names of its contributors 15 | may be used to endorse or promote products derived from this software without 16 | specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 19 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /libraries/indentation-core/README.md: -------------------------------------------------------------------------------- 1 | # Combinator libraries for indentation-sensitive parsing (core library) 2 | 3 | `indentation-core` contains the shared core implementation of 4 | indentation parsing based on: 5 | __Michael D. Adams and Ömer S. Ağacan__. 6 | Indentation-sensitive parsing for Parsec. 7 | In *Proceedings of the 2014 ACM SIGPLAN Symposium on Haskell*, 8 | Haskell ’14, pages 121–132. 9 | ACM, New York, NY, USA, September 2014. ISBN 978-1-4503-3041-1. 10 | [doi:10.1145/2633357.2633369](http://dx.doi.org/10.1145/2633357.2633369). 11 | 12 | To add indentation parsing to your project, use: 13 | * [`indentation-parsec`](https://hackage.haskell.org/packages/indentation-parsec) for [Parsec](https://hackage.haskell.org/packages/parsec), or 14 | * [`indentation-trifecta`](https://hackage.haskell.org/packages/indentation-parsec) for [Trifecta](https://hackage.haskell.org/packages/trifecta) 15 | 16 | The [`indentation`](https://hackage.haskell.org/packages/indentation) 17 | package is a rollup package re-exporting the modules from all the 18 | above packages for backward compatability with earlier versions of 19 | `indentation`. 20 | -------------------------------------------------------------------------------- /libraries/indentation-core/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /libraries/indentation-core/indentation-core.cabal: -------------------------------------------------------------------------------- 1 | name: indentation-core 2 | version: 0.0.0.3 3 | synopsis: Indentation sensitive parsing combinators core library 4 | description: Indentation sensitive parsing combinators core library 5 | . 6 | This is the core for the indentation package. 7 | For common use, consider one of the front-ends: 8 | indentation-parsec or indentation-trifecta. For 9 | both, or for backward compatability, install 10 | indentation. 11 | 12 | license: BSD3 13 | license-file: LICENSE 14 | author: Michael D. Adams 15 | maintainer: Ömer Sinan Ağacan 16 | Aleksey Kliger 17 | category: Parsing 18 | build-type: Simple 19 | cabal-version: >=1.10 20 | extra-source-files: CHANGELOG.md 21 | 22 | homepage: https://github.com/adamsmd/indentation 23 | bug-reports: https://github.com/adamsmd/indentation/issues 24 | tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1, GHC == 8.2.1, GHC == 8.4.3, GHC == 8.6.1, GHC == 8.10.1 25 | 26 | source-repository head 27 | type: git 28 | location: https://github.com/adamsmd/indentation.git 29 | 30 | library 31 | hs-source-dirs: src 32 | exposed-modules: Text.Parser.Indentation.Implementation 33 | build-depends: base >=4.6, 34 | mtl >=2.1 35 | 36 | default-language: Haskell2010 37 | 38 | ghc-options: -Wall 39 | -------------------------------------------------------------------------------- /libraries/indentation-parsec/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # 0.0.0.2 2 | 3 | * Bump `base` bounds to support GHC 8.6.1 (and 8.4.3) 4 | 5 | # 0.0.0.1 6 | 7 | * Bump `base` bounds to support GHC 8.2.1 8 | 9 | # 0.0 10 | 11 | * Split `indentation` into separate `indentation-core`, `indentation-parsec` and `indentation-trifecta` packages. 12 | Keep the original `indentation` for backward compatability and as a general roll-up package. 13 | -------------------------------------------------------------------------------- /libraries/indentation-parsec/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Michael D. Adams 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | 1. Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | 2. Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | 3. Neither the name of the copyright holder nor the names of its contributors 15 | may be used to endorse or promote products derived from this software without 16 | specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 19 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /libraries/indentation-parsec/README.md: -------------------------------------------------------------------------------- 1 | # Combinator libraries for indentation-sensitive parsing (Parsec frontend) 2 | 3 | This repository contains Haskell libraries for indentation-sensitive parsing with Parsec. 4 | 5 | For the Trifecta frontend, see [`indentation-trifecta`](https://hackage.haskell.org/packages/indentation-trifecta) 6 | -------------------------------------------------------------------------------- /libraries/indentation-parsec/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /libraries/indentation-parsec/src/Text/Parsec/Indentation/Char.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-} 2 | module Text.Parsec.Indentation.Char where 3 | 4 | import Text.Parsec.Prim (ParsecT, mkPT, runParsecT, 5 | Stream(..), 6 | Consumed(..), Reply(..), 7 | State(..)) 8 | import Text.Parsec.Pos (sourceColumn) 9 | import Text.Parser.Indentation.Implementation (Indentation) 10 | 11 | ---------------- 12 | -- Unicode char 13 | -- newtype UnicodeIndentStream 14 | 15 | ---------------- 16 | -- Based on Char 17 | {-# INLINE mkCharIndentStream #-} 18 | mkCharIndentStream :: s -> CharIndentStream s 19 | mkCharIndentStream s = CharIndentStream 1 s 20 | data CharIndentStream s = CharIndentStream { charIndentStreamColumn :: {-# UNPACK #-} !Indentation, 21 | charIndentStreamStream :: !s } deriving (Show) 22 | 23 | instance (Stream s m Char) => Stream (CharIndentStream s) m (Char, Indentation) where 24 | uncons (CharIndentStream i s) = do 25 | x <- uncons s 26 | case x of 27 | Nothing -> return Nothing 28 | Just (c, cs) -> return (Just ((c, i), CharIndentStream (updateColumn i c) cs)) 29 | 30 | {-# INLINE updateColumn #-} 31 | updateColumn :: Integral a => a -> Char -> a 32 | updateColumn _ '\n' = 1 33 | updateColumn i '\t' = i + 8 - ((i-1) `mod` 8) 34 | updateColumn i _ = i + 1 35 | 36 | {-# INLINE charIndentStreamParser #-} 37 | charIndentStreamParser :: (Monad m) => ParsecT s u m t -> ParsecT (CharIndentStream s) u m (t, Indentation) 38 | charIndentStreamParser p = mkPT $ \state -> 39 | let go (Ok a state' e) = return (Ok (a, sourceColumn $ statePos state) (state' { stateInput = CharIndentStream (sourceColumn $ statePos state') (stateInput state') }) e) 40 | go (Error e) = return (Error e) 41 | in runParsecT p (state { stateInput = charIndentStreamStream (stateInput state) }) 42 | >>= consumed (return . Consumed . go) (return . Empty . go) 43 | 44 | {-# INLINE consumed #-} 45 | consumed :: (Monad m) => (a -> m b) -> (a -> m b) -> Consumed (m a) -> m b 46 | consumed c _ (Consumed m) = m >>= c 47 | consumed _ e (Empty m) = m >>= e 48 | -------------------------------------------------------------------------------- /libraries/indentation-parsec/tests/all-tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Main where 3 | 4 | import Test.Tasty (defaultMain, testGroup) 5 | import qualified ParensParsec 6 | 7 | main = 8 | defaultMain $ testGroup "All tests" $ 9 | [ 10 | ParensParsec.allTests 11 | ] 12 | -------------------------------------------------------------------------------- /perftest/.gitignore: -------------------------------------------------------------------------------- 1 | #Git ignore file for the perftest work, necessary since I generate files that are handcrafted elsewhere 2 | *.s 3 | *.out 4 | *.out1 5 | *.o 6 | *.fidget 7 | -------------------------------------------------------------------------------- /perftest/README: -------------------------------------------------------------------------------- 1 | These are some performance analysis code done to see if there were any obvious performance errors. 2 | 3 | The C and ML code is a baseline and in general corresponds to a Habit file of the same name (or it should 4 | 5 | BUILD 6 | --------- 7 | make -j should build all the .out files, .s files and .fidget files. Fidget and .s are left for analysis 8 | 9 | make Test builds a file named TestOut from the script test.sh which just executes every program and shows it's name next to the execution time 10 | make TestHard does the same thing but runs every test 10 times. 11 | 12 | make clean cleans the folder of everything (including TestOut files). 13 | 14 | NOTES 15 | --------- 16 | 17 | The Makefile, while verbose, has some documentation on what the different files do (the different files evolved fast enough to make documenting difficult. Exact details may be out of date) 18 | 19 | 20 | Still trying to figure out how to get symbols to resolve. 21 | 22 | ackermann is actually pretty interesting 23 | 24 | -------------------------------------------------------------------------------- /perftest/ackermann.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | requires test 3 | --This file has several different versions of the ackermann 4 | --function, as it's a somewhat complex function that can 5 | --reveal issues in code (static analyzers can't deal with it 6 | --very well in my experience) 7 | -- 8 | --It's shown some problems with allocation lifetime 9 | 10 | --Main function just calls one of the functions 11 | main::M Unsigned 12 | main = do x <- return (ackermanntest 4 4) 13 | return x 14 | 15 | --An explecit version, no sugar 16 | ackermann :: Unsigned -> Unsigned -> Unsigned 17 | ackermann m n = case (m,n) of (0,x) -> x+1 18 | (x,0) -> ackermann (x-1) 1 19 | (x,y) -> ackermann (x-1) (ackermann x (y-1)) 20 | 21 | --A somewhat sugared version 22 | ackermanntest :: Unsigned -> Unsigned -> Unsigned 23 | ackermanntest m n | m == 0 = n+1 24 | | n == 0 = ackermanntest (m-1) 1 25 | | m > 0 && n > 0 = ackermanntest (m-1) (ackermann m (n-1)) 26 | 27 | 28 | 29 | -------------------------------------------------------------------------------- /perftest/area1.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | requires test 3 | --This tests a naive recursion to see if tail call works 4 | --Also does some checking on how good the dead code eliminator is 5 | --and generally tests the performance of "function call" 6 | 7 | --Main function, does very little 8 | main :: M Unsigned 9 | main = do x <- return (bigrecurser (10000)) 10 | return x 11 | 12 | area a1 <- initStored 3 :: Ref (Stored Unsigned) 13 | --recurses acc times, then returns three 14 | bigrecurser :: Unsigned -> Unsigned 15 | bigrecurser acc = case acc of 0 -> 3 16 | x -> (bigrecurser (x-1)) 17 | -------------------------------------------------------------------------------- /perftest/basicloop.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | requires test 3 | --This tests a naive recursion to see if tail call works 4 | --Also does some checking on how good the dead code eliminator is 5 | --and generally tests the performance of "function call" 6 | 7 | --Main function, does very little 8 | main :: M Unsigned 9 | main = do x <- return (bigrecurser (1000000000 * 10)) 10 | return x 11 | 12 | --recurses acc times, then returns three 13 | bigrecurser :: Unsigned -> Unsigned 14 | bigrecurser acc = case acc of 0 -> 3 15 | x -> (bigrecurser (x-1)) 16 | -------------------------------------------------------------------------------- /perftest/cheney.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | requires test 3 | --tests basic allocation works 4 | --tests rough perforrmance of allocation of 5 | --lists (head allocation 6 | 7 | --drives functions 8 | main:: M Unsigned 9 | main = do v <- return (loop 1000 3) 10 | return v 11 | 12 | --allocates a bunch of integers toa list and then discards the list 13 | --returning the head of the list (which is 3) 14 | allocateLots:: List Unsigned -> Unsigned -> Unsigned 15 | allocateLots acc acc2 = case (acc2) of 1000 -> head acc 16 | x -> allocateLots (Cons 3 acc) (x+1) 17 | 18 | --naive loop that calls the allocater function a whole bunch of times 19 | --the let i and j is to study life time of the lists (seems to be working) 20 | loop:: Unsigned -> Unsigned -> Unsigned 21 | loop acc retval = case acc of 0 -> retval 22 | x -> let i = allocateLots Nil 0 in 23 | let j = allocateLots Nil 0 in 24 | loop (acc-1) (i+j) 25 | -------------------------------------------------------------------------------- /perftest/diff.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | rm results.txt 4 | touch results.txt 5 | 6 | for i in `ls testfolder2` 7 | do 8 | echo "$i" 9 | wc testfolder2/$i 10 | wc testfolder/$i 11 | done 12 | 13 | return 0 14 | -------------------------------------------------------------------------------- /perftest/eq.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | requires test 3 | 4 | main = do x <- runTests (map (equalM 3) (Cons (eqtester 1000) Nil)) 5 | return x 6 | 7 | eqtester:: Unsigned -> M Unsigned 8 | eqtester acc = if acc == 1000 then return 3 else return 5 9 | 10 | 11 | 12 | -------------------------------------------------------------------------------- /perftest/eqloop.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | requires test 3 | 4 | main :: M Unsigned 5 | main = do x <- return (bigrecurser (1000000000 * 10)) 6 | return x 7 | 8 | bigrecurser :: Unsigned -> Unsigned 9 | bigrecurser acc = if (acc == 0) then 3 else bigrecurser (acc-1) 10 | -------------------------------------------------------------------------------- /perftest/md5demo.hb: -------------------------------------------------------------------------------- 1 | requires md5 2 | requires miniprelude 3 | requires test 4 | requires ondeckprelude 5 | requires io 6 | 7 | main :: M Unsigned 8 | main = do 9 | x <- readInts 10 | case <- md5 x of 11 | MD5Digest (MD5Par a b c d) -> 12 | do putHexInt (fromBits (swapEndian a)) 13 | putchar 0x20 14 | putHexInt (fromBits (swapEndian b)) 15 | putchar 0x20 16 | putHexInt (fromBits (swapEndian c)) 17 | putchar 0x20 18 | putHexInt (fromBits (swapEndian d)) 19 | putchar 0x0A 20 | return (0 :: Unsigned) 21 | -------------------------------------------------------------------------------- /perftest/monad1.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | requires test 3 | 4 | main :: M Unsigned 5 | main = do x <- testmonad1 (1000) 6 | y <- testmonad2 (100) 7 | z <- testmonad3 (1000) 8 | a <- testmonad4 (102) 9 | return (x+y+a) 10 | 11 | testmonad1:: Unsigned -> M Unsigned 12 | testmonad1 x = return 5 13 | 14 | testmonad2:: Unsigned -> M Unsigned 15 | testmonad2 x = do i <- return x 16 | return 6 17 | 18 | testmonad3:: Unsigned -> M Unsigned 19 | testmonad3 x = (return x) >>= (\z -> return 7) 20 | 21 | testmonad4:: Unsigned -> M Unsigned 22 | testmonad4 x = do i <- testmonad1 x 23 | j <- testmonad2 x 24 | return (i+j) 25 | -------------------------------------------------------------------------------- /perftest/monad2.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | requires test 3 | 4 | main :: M Unsigned 5 | main = do x <- testmonad1 (1000) 6 | y <- testmonad2 (100) 7 | z <- testmonad3 (1000) 8 | a <- testmonad4 (102) 9 | b <- testmonad4 (102) 10 | return (x+x+x+x+x) 11 | 12 | testmonad1:: Unsigned -> M Unsigned 13 | testmonad1 x = return 5 14 | 15 | testmonad2:: Unsigned -> M Unsigned 16 | testmonad2 x = do i <- return x 17 | return 6 18 | 19 | testmonad3:: Unsigned -> M Unsigned 20 | testmonad3 x = (return x) >>= (\z -> return 7) 21 | 22 | testmonad4:: Unsigned -> M Unsigned 23 | testmonad4 x = do i <- testmonad1 x 24 | j <- testmonad2 x 25 | k <- testmonad2 x 26 | return (i+j+k) 27 | -------------------------------------------------------------------------------- /perftest/monad3.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | requires test 3 | 4 | main :: M Unsigned 5 | main = do x <- testmonad1 (1000) 6 | y <- testmonad2 (x) 7 | -- z <- testmonad3 (1000) 8 | -- a <- testmonad4 (102) 9 | -- b <- testmonad4 (102) 10 | return (x+y+x+y+x) 11 | 12 | testmonad1:: Unsigned -> M Unsigned 13 | testmonad1 x = return 5 14 | 15 | testmonad2:: Unsigned -> M Unsigned 16 | testmonad2 x = if x == 4 then return 5 else return 6 17 | 18 | testmonad3:: Unsigned -> M Unsigned 19 | testmonad3 x = (return x) >>= \z -> return 7 20 | 21 | testmonad4:: Unsigned -> M Unsigned 22 | testmonad4 x = do i <- testmonad1 x 23 | j <- testmonad2 x 24 | k <- testmonad2 x 25 | return (i+j+k) 26 | -------------------------------------------------------------------------------- /perftest/monad4.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | requires test 3 | 4 | main :: M Unsigned 5 | main = do x <- testmonad1 (1000) 6 | y <- testmonad2 (x) 7 | -- z <- testmonad3 (1000) 8 | -- a <- testmonad4 (102) 9 | -- b <- testmonad4 (102) 10 | return ((((x+y)+x)+y)+x) 11 | 12 | testmonad1:: Unsigned -> M Unsigned 13 | testmonad1 x = return 5 14 | 15 | testmonad2:: Unsigned -> M Unsigned 16 | testmonad2 x = if x == 4 then return 5 else return 6 17 | 18 | testmonad3:: Unsigned -> M Unsigned 19 | testmonad3 x = (return x) >>= (\z -> return 7) 20 | 21 | testmonad4:: Unsigned -> M Unsigned 22 | testmonad4 x = do i <- testmonad1 x 23 | j <- testmonad2 x 24 | k <- testmonad2 x 25 | return (i+j+k) 26 | -------------------------------------------------------------------------------- /perftest/mutualrecursion.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | requires test 3 | --This tests a naive recursion to see if tail call works 4 | --Also does some checking on how good the dead code eliminator is 5 | --and generally tests the performance of "function call" 6 | 7 | --Main function, does very little 8 | main :: M Unsigned 9 | main = do x <- return (loop1 (1000000000 )) 10 | return x 11 | 12 | --recurses acc times, then returns three 13 | loop1:: Unsigned -> Unsigned 14 | loop1 acc = case acc of 0 -> 0 15 | x -> (loop2 (x-1)) 16 | 17 | --recurses acc times, then returns three 18 | loop2:: Unsigned -> Unsigned 19 | loop2 acc = case acc of 0 -> 0 20 | x -> (loop1 (x-1)) 21 | -------------------------------------------------------------------------------- /perftest/mutualrecursion.hs: -------------------------------------------------------------------------------- 1 | --This tests a naive recursion to see if tail call works 2 | --Also does some checking on how good the dead code eliminator is 3 | --and generally tests the performance of "function call" 4 | 5 | --Main function, does very little 6 | main = do x <- return (loop1 (1000000000 )) 7 | return x 8 | 9 | --recurses acc times, then returns three 10 | loop1 acc = case acc of 0 -> 0 11 | x -> (loop2 (x-1)) 12 | 13 | --recurses acc times, then returns three 14 | loop2 acc = case acc of 0 -> 0 15 | x -> (loop1 (x-1)) 16 | -------------------------------------------------------------------------------- /perftest/neq.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | requires test 3 | 4 | main = do x <- runTests (map (equalM 3) (Cons (eqtester 1000) Nil)) 5 | return x 6 | 7 | eqtester:: Unsigned -> M Unsigned 8 | eqtester acc = if acc /= 1000 then return 5 else return 3 9 | 10 | 11 | 12 | -------------------------------------------------------------------------------- /perftest/neqloop.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | requires test 3 | 4 | main :: M Unsigned 5 | main = do x <- return (bigrecurser (1000000000 * 10)) 6 | return x 7 | 8 | bigrecurser :: Unsigned -> Unsigned 9 | bigrecurser acc = if (acc /= 0) then bigrecurser (acc-1) else 3 10 | -------------------------------------------------------------------------------- /perftest/newbool.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | 3 | myNot :: Bool -> Bool 4 | myNot x = case x of True -> False 5 | False -> True 6 | -------------------------------------------------------------------------------- /perftest/newboolperftest.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | requires test 3 | requires newbool 4 | 5 | main:: M Unsigned 6 | main = do v <- return (eqtester 5 209563) 7 | return v 8 | 9 | eqtester:: Unsigned-> Unsigned -> Unsigned 10 | eqtester input acc = case acc of 0 -> if myNot(acc == 1000) then 5 else 3 11 | x -> eqtester input (acc-1) 12 | 13 | 14 | 15 | -------------------------------------------------------------------------------- /perftest/newbooltest.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | requires test 3 | requires newbool 4 | 5 | main:: M Unsigned 6 | main = do v <- return (eqtester 5) 7 | return v 8 | 9 | eqtester:: Unsigned -> Unsigned 10 | eqtester acc = if myNot(acc == 1000) then 5 else 3 11 | 12 | 13 | 14 | -------------------------------------------------------------------------------- /perftest/nmeq.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | requires test 3 | 4 | main:: M Unsigned 5 | main = do v <- return (eqtester 5) 6 | return v 7 | 8 | eqtester:: Unsigned -> Unsigned 9 | eqtester acc = if acc == 1000 then 5 else 3 10 | 11 | 12 | 13 | -------------------------------------------------------------------------------- /perftest/nmneq.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | requires test 3 | 4 | main:: M Unsigned 5 | main = do v <- return (eqtester 5) 6 | return v 7 | 8 | eqtester:: Unsigned -> Unsigned 9 | eqtester acc = if acc /= 1000 then 5 else 3 10 | 11 | 12 | 13 | -------------------------------------------------------------------------------- /perftest/recurse.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | requires test 3 | 4 | main = do x <- runTests (map (equalM 3) (Cons (bigrecurser 1000000000) Nil)) 5 | return x 6 | 7 | bigrecurser :: Unsigned -> M Unsigned 8 | bigrecurser acc = case acc of 0 -> return 3 9 | x -> (bigrecurser (x-1)) 10 | 11 | 12 | 13 | -------------------------------------------------------------------------------- /perftest/shalloweq.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | requires test 3 | 4 | main :: M Unsigned 5 | main = do x <- return (recurse1 10) 6 | return x 7 | 8 | recurse1 :: Unsigned -> Unsigned 9 | recurse1 acc = case acc of 0 -> 3 10 | x -> if (recurse2 10) == (recurse1 (x-1)) then 4 else 3 11 | 12 | recurse2 :: Unsigned -> Unsigned 13 | recurse2 acc = case acc of 0 -> 3 14 | x -> if (recurse3 10) == (recurse2 (x-1)) then 4 else 3 15 | 16 | recurse3 :: Unsigned -> Unsigned 17 | recurse3 acc = case acc of 0 -> 3 18 | x -> if (recurse4 10) == (recurse3 (x-1)) then 4 else 3 19 | 20 | recurse4 :: Unsigned -> Unsigned 21 | recurse4 acc = case acc of 0 -> 3 22 | x -> if (recurse5 10) == (recurse4 (x-1)) then 4 else 3 23 | 24 | recurse5 :: Unsigned -> Unsigned 25 | recurse5 acc = case acc of 0 -> 3 26 | x -> if (recurse6 10) == (recurse5 (x-1)) then 4 else 3 27 | 28 | recurse6 :: Unsigned -> Unsigned 29 | recurse6 acc = case acc of 0 -> 3 30 | x -> if (recurse7 10) == (recurse6 (x-1)) then 4 else 3 31 | 32 | recurse7 :: Unsigned -> Unsigned 33 | recurse7 acc = case acc of 0 -> 3 34 | x -> if (recurse8 10) == (recurse7 (x-1)) then 4 else 3 35 | 36 | recurse8 :: Unsigned -> Unsigned 37 | recurse8 acc = case acc of 0 -> 3 38 | x -> if (recurseLast 10) == (recurse8 (x-1)) then 4 else 3 39 | 40 | recurseLast :: Unsigned -> Unsigned 41 | recurseLast acc = case acc of 0 -> 3 42 | x -> (recurseLast (x-1)) 43 | -------------------------------------------------------------------------------- /perftest/shallowneq.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | requires test 3 | 4 | main :: M Unsigned 5 | main = do x <- return (recurse1 10) 6 | return x 7 | 8 | recurse1 :: Unsigned -> Unsigned 9 | recurse1 acc = case acc of 0 -> 3 10 | x -> if (recurse2 10) /= (recurse1 (x-1)) then 4 else 3 11 | 12 | recurse2 :: Unsigned -> Unsigned 13 | recurse2 acc = case acc of 0 -> 3 14 | x -> if (recurse3 10) /= (recurse2 (x-1)) then 4 else 3 15 | 16 | recurse3 :: Unsigned -> Unsigned 17 | recurse3 acc = case acc of 0 -> 3 18 | x -> if (recurse4 10) /= (recurse3 (x-1)) then 4 else 3 19 | 20 | recurse4 :: Unsigned -> Unsigned 21 | recurse4 acc = case acc of 0 -> 3 22 | x -> if (recurse5 10) /= (recurse4 (x-1)) then 4 else 3 23 | 24 | recurse5 :: Unsigned -> Unsigned 25 | recurse5 acc = case acc of 0 -> 3 26 | x -> if (recurse6 10) /= (recurse5 (x-1)) then 4 else 3 27 | 28 | recurse6 :: Unsigned -> Unsigned 29 | recurse6 acc = case acc of 0 -> 3 30 | x -> if (recurse7 10) /= (recurse6 (x-1)) then 4 else 3 31 | 32 | recurse7 :: Unsigned -> Unsigned 33 | recurse7 acc = case acc of 0 -> 3 34 | x -> if (recurse8 10) /= (recurse7 (x-1)) then 4 else 3 35 | 36 | recurse8 :: Unsigned -> Unsigned 37 | recurse8 acc = case acc of 0 -> 3 38 | x -> if (recurseLast 10) /= (recurse8 (x-1)) then 4 else 3 39 | 40 | recurseLast :: Unsigned -> Unsigned 41 | recurseLast acc = case acc of 0 -> 3 42 | x -> (recurseLast (x-1)) 43 | -------------------------------------------------------------------------------- /perftest/shallowrecurse.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | requires test 3 | 4 | main :: M Unsigned 5 | main = do x <- return (recurser1 10) 6 | return x 7 | 8 | recurser1 :: Unsigned -> Unsigned 9 | recurser1 acc = case acc of 0 -> 3 10 | x -> (recurse2 10) + (recurser1 (x-1)) 11 | 12 | recurse2 :: Unsigned -> Unsigned 13 | recurse2 acc = case acc of 0 -> 3 14 | x -> (recurse3 10) + (recurse2 (x-1)) 15 | 16 | recurse3 :: Unsigned -> Unsigned 17 | recurse3 acc = case acc of 0 -> 3 18 | x -> (recurse4 10) + (recurse3 (x-1)) 19 | 20 | recurse4 :: Unsigned -> Unsigned 21 | recurse4 acc = case acc of 0 -> 3 22 | x -> (recurse5 10) + (recurse4 (x-1)) 23 | 24 | recurse5 :: Unsigned -> Unsigned 25 | recurse5 acc = case acc of 0 -> 3 26 | x -> (recurse6 10) + (recurse5 (x-1)) 27 | 28 | recurse6 :: Unsigned -> Unsigned 29 | recurse6 acc = case acc of 0 -> 3 30 | x -> (recurse7 10) + (recurse6 (x-1)) 31 | 32 | recurse7 :: Unsigned -> Unsigned 33 | recurse7 acc = case acc of 0 -> 3 34 | x -> (recurseLast 10) + (recurse7 (x-1)) 35 | 36 | recurseLast :: Unsigned -> Unsigned 37 | recurseLast acc = case acc of 0 -> 3 38 | x -> (recurseLast (x-1)) 39 | 40 | 41 | 42 | 43 | -------------------------------------------------------------------------------- /perftest/sortarea.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | requires test 3 | --This tests a naive recursion to see if tail call works 4 | --Also does some checking on how good the dead code eliminator is 5 | --and generally tests the performance of "function call" 6 | 7 | --Main function, does very little 8 | main :: M Unsigned 9 | main = do x <- return (bigrecurser (10000)) 10 | return x 11 | 12 | area a1 <- initArray (\x -> initStored (3)) :: Ref (Array 1000 (Stored Unsigned)) 13 | 14 | --bubblesort- 15 | -- for(int i = 0; i< length of array; i++) 16 | -- for (int j = 0; j < length of array-1; j++) 17 | -- if(array[j]>array[j+1]) 18 | -- { 19 | -- int temp = array[j]; 20 | -- array[j]=array[j+1]; 21 | -- array[j+1]=temp; 22 | -- } 23 | -- 24 | -- Note-THis is quite inefficient, doesn't break if there are no swaps 25 | 26 | --inner for loop 27 | bubblesort'iter :: Ref (Array 1000 (Stored Unsigned)) -> Unsigned -> Ref (Array 1000 (Stored Unsigned)) 28 | bubblesort'iter axs i = case (i == 999) of True -> axs 29 | False -> bubblesort'iter (if (readRef (axs @ i) > readRef (axs @ (i+1))) then (let temp = readRef (axs @ i) 30 | in let foo = writeRef (axs @ (i)) (readRef (axs @ (i+1)) 31 | in writeRef (axs @ (i+1)) (temp)) else axs) (i+1) 32 | 33 | --outer for loop 34 | bubblesort' :: Ref (Array 1000 (Stored Unsigned)) -> Unsigned -> Ref (Array 1000 (Stored Unsigned)) 35 | bubblesort' xs i = case (i == 1000) of True -> xs 36 | False -> (bubblesort' (bubblesort'iter xs 0) (i + 1)) 37 | 38 | 39 | bubblesort :: Ref (Array 1000 (Stored Unsigned)) -> Ref (Array 1000 (Stored Unsigned)) 40 | bubblesort xs = bubblesort' xs 0 41 | 42 | --recurses acc times, then returns three 43 | bigrecurser :: Unsigned -> Unsigned 44 | bigrecurser acc = case acc of 0 -> 3 45 | x -> (bigrecurser (x-1)) 46 | -------------------------------------------------------------------------------- /perftest/sortheap.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | requires test 3 | --This tests a naive recursion to see if tail call works 4 | --Also does some checking on how good the dead code eliminator is 5 | --and generally tests the performance of "function call" 6 | 7 | --Main function, does very little 8 | main :: M Unsigned 9 | main = do x <- return (bigrecurser (10000)) 10 | return x 11 | 12 | bubblesort'iter :: List Unsigned -> List Unsigned 13 | bubblesort'iter (Cons x (Cons y (Cons xs Nil))) = case (x > y) of True -> (Cons y (bubblesort'iter (Cons x (Cons xs Nil)))) 14 | False -> (Cons x (bubblesort'iter (Cons y (Cons xs Nil)))) 15 | 16 | bubblesort'iter :: List Unsigned -> List Unsigned 17 | bubblesort'iter (Cons x (Cons y Nil)) = (Cons x (Cons y Nil)) 18 | 19 | bubblesort'iter :: List Unsigned -> List Unsigned 20 | bubblesort'iter (Cons x Nil) = (Cons x Nil) 21 | 22 | bubblesort' :: List Unsigned -> Unsigned -> List Unsigned 23 | bubblesort' xs i = case (i == length xs) of True -> xs 24 | False -> (bubblesort' (bubblesort'iter xs) (i + 1)) 25 | 26 | bubblesort :: List Unsigned -> List Unsigned 27 | bubblesort xs = bubblesort' xs 0 28 | 29 | area a1 <- initStored 3 :: Ref (Stored Unsigned) 30 | --recurses acc times, then returns three 31 | bigrecurser :: Unsigned -> Unsigned 32 | bigrecurser acc = case acc of 0 -> 3 33 | x -> (bigrecurser (x-1)) 34 | -------------------------------------------------------------------------------- /perftest/test.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | rm results.txt 4 | touch results.txt 5 | 6 | for i in `ls *.out` 7 | do 8 | echo "--------------------\n" >> results.txt 9 | echo "$i\n" >> results.txt 10 | time -v ./$i 2>> results.txt >> results.txt 11 | done 12 | 13 | return 0 14 | -------------------------------------------------------------------------------- /src/Analyzer.hs: -------------------------------------------------------------------------------- 1 | module Analyzer 2 | ( emptyFixities 3 | , module Analyzer.FunctionalNotation 4 | , module Analyzer.Desugaring 5 | , module Analyzer.Fixity 6 | , module Analyzer.LabeledFields 7 | , module Analyzer.Tuples 8 | , module Analyzer.Freshening) where 9 | 10 | import Analyzer.FunctionalNotation 11 | import Analyzer.Desugaring 12 | import Analyzer.Fixity 13 | import Analyzer.Freshening 14 | import Analyzer.LabeledFields 15 | import Analyzer.Tuples 16 | import Syntax.Surface 17 | -------------------------------------------------------------------------------- /src/CompCert.hs: -------------------------------------------------------------------------------- 1 | module CompCert (CompCertOptions(..), compile, defaultCompCertOptions) where 2 | 3 | import Data.List 4 | import Fidget.AST 5 | import Fidget.Pretty (pprogram) 6 | import System.Process 7 | import System.Exit 8 | import System.FilePath 9 | import System.IO 10 | 11 | -- Options for invoking the CompCert C compiler 12 | data CompCertOptions = CCO { root :: String, 13 | ccompExe :: String, 14 | harness :: String, 15 | gc :: String, 16 | otherOptions :: String, 17 | fake :: Bool } 18 | 19 | 20 | defaultCompCertOptions = CCO { root = ".", 21 | ccompExe = "ccomp", 22 | harness = "test" "fidget" "harness.c", 23 | gc = "runtime" "gc" "cheney.o", 24 | otherOptions = "", 25 | fake = False } 26 | 27 | compile :: CompCertOptions -> String -> Program -> IO () 28 | compile cco outputFileName prog = 29 | do writeFile fidgetFileName (show (pprogram prog)) 30 | let ccompCmd = intercalate " " [ root cco ccompExe cco, 31 | "-L" ++ (root cco "lib" "compcert"), 32 | "-o " ++ outputFileName, 33 | fidgetFileName, 34 | root cco harness cco, 35 | root cco gc cco, 36 | otherOptions cco ] 37 | if fake cco 38 | then putStrLn ccompCmd 39 | else do exitCode <- system ccompCmd 40 | if exitCode /= ExitSuccess 41 | then hPutStrLn stderr ("ccomp invocation failed (" ++ show exitCode ++ ")") 42 | else return () 43 | where fidgetFileName = replaceExtension outputFileName "fidget" 44 | -------------------------------------------------------------------------------- /src/Fidget/Env.hs: -------------------------------------------------------------------------------- 1 | module Fidget.Env where 2 | 3 | {- Environments -} 4 | {- A completely simplistic implementation just for now -} 5 | 6 | {- Env's are the running environment of the fidget interpreter? 7 | - this is basically a naive key value pair, keys are type a, values are type 8 | - b. Empty env is the empty list of key value pairs, lookup either finds the value associated with a key, or errors 9 | - extend adds a new key to the dictionary-} 10 | data Env a b = Env [(a,b)] 11 | 12 | empty_env :: Eq a => Env a b 13 | empty_env = Env [] 14 | 15 | lookup_env :: (Eq a,Show a) => Env a b -> a -> b -- may error 16 | lookup_env (Env []) a = error ("lookup_env failed:" ++ (show a)) 17 | lookup_env (Env ((a,b):e)) a' = if a == a' then b else lookup_env (Env e) a' 18 | 19 | extend_env :: Eq a => Env a b -> a -> b -> Env a b 20 | extend_env (Env e) a b = Env ((a,b):e) 21 | -------------------------------------------------------------------------------- /src/Ilab.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Solver.REPL as R 4 | 5 | main = R.main -------------------------------------------------------------------------------- /src/Normalizer.hs: -------------------------------------------------------------------------------- 1 | module Normalizer () where 2 | 3 | import Common 4 | import Normalizer.EtaInit 5 | import Normalizer.Inliner 6 | import Normalizer.PatternMatchCompiler 7 | -------------------------------------------------------------------------------- /src/Normalizer/Eta.hs: -------------------------------------------------------------------------------- 1 | module Normalizer.Eta where 2 | 3 | import Syntax.Specialized 4 | 5 | import Data.Generics 6 | 7 | 8 | etaExpandDefn :: Defn -> Defn 9 | etaExpandDefn d@(Defn _ _ (Left _)) = d 10 | etaExpandDefn d@(Defn id (Forall [] [] ty) (Right (Gen tvars evars e))) = 11 | case e of 12 | ELam{} -> d 13 | _ -> case ty of 14 | TyApp (TyApp (TyCon (Kinded "->" _)) dom) _ -> 15 | Defn id (Forall [] [] ty) (Right (Gen tvars evars (ELam "$a" dom (EApp e (ELamVar "$a"))))) 16 | _ -> d 17 | 18 | etaExpand :: Specialized -> Specialized 19 | etaExpand = everywhere (mkT etaExpandDefn) 20 | -------------------------------------------------------------------------------- /src/Printer/Specialized.lhs: -------------------------------------------------------------------------------- 1 | > module Printer.Specialized (module Printer.XMPEG, module Printer.Specialized) where 2 | 3 | > import Printer.Common 4 | > import Printer.XMPEG 5 | > import Syntax.Specialized 6 | 7 | > instance Printable Specialized where 8 | > ppr (Specialized topdecls entries decls) 9 | > = vcat (punctuate line [ppr topdecls, 10 | > ppr decls, 11 | > text "entry points:" <+> cat (punctuate (comma <> space) (map (ppr . fst) entries))]) 12 | 13 | > {- The definitions of Primtives and DApp are now local to Specializer.lhs 14 | > instance Printable Primitives where 15 | > ppr (Primitives ps) 16 | > = vcat ({-punctuate line-} [ text "primitive:" <+> symbol id <+> text "=" <+> ppr d | (d, id) <- ps ]) 17 | 18 | > instance Printable DApp where 19 | > ppr (DApp id ts ds) = atPrecedence 9 $ 20 | > cat (punctuate space (symbol id <> braces (cat (punctuate comma (map ppr ts))) 21 | > : map (withPrecedence 10 . ppr) ds)) 22 | > -} 23 | -------------------------------------------------------------------------------- /src/Solver/All.hs: -------------------------------------------------------------------------------- 1 | module Solver.All where 2 | 3 | import Solver.Main 4 | import Solver.REPL 5 | import Solver.Subst 6 | import Solver.Syntax 7 | import Solver.Tactics 8 | import Solver.Parser 9 | import Solver.PP 10 | import Solver.Validation 11 | 12 | import Control.Monad 13 | import Control.Monad.State 14 | import Data.List 15 | import Debug.Trace 16 | import Prelude hiding (even, odd) 17 | 18 | -------------------------------------------------------------------------------- 19 | -- Testing 20 | 21 | ty = q' typ 22 | p = q' predicate 23 | qp = q' qpred 24 | ax = q' axiom 25 | fd = q' funDepRule 26 | rq = q' requirement 27 | 28 | s :: StateT Int (Either String) t -> Either String t 29 | s x = evalStateT x (0 :: Int) 30 | 31 | -------------------------------------------------------------------------------- 32 | 33 | dtac = [ax "In f f; In f (Plus g h) if In f g; In f (Plus g h) if In f h; In f g fails"] 34 | dtac2 = [ax "In f f; In f (Plus g h) fails if In f g, In f h; In f (Plus g h) if In f g; In f (Plus g h) if In f h; In f g fails"] 35 | dtac3 = [ ax "In f f; In f (Plus g h) if In f g; In f (Plus g h) if In f h; In f g fails" 36 | , ax "UniqueIn f f; UniqueIn f (Plus g h) if UniqueIn f g, In f h fails; UniqueIn f (Plus g h) if UniqueIn f h, In f g fails; UniqueIn f g fails" ] 37 | 38 | ---------------------------------------------------------------------------------------------------- 39 | 40 | even = ax "Even Z; Even (S n) if Odd n; Even n fails" 41 | odd = ax "Odd (S Z); Odd (S n) if Even n; Odd n fails" 42 | 43 | evenf = ax "EvenF Z True; EvenF (S n) True if OddF n True; EvenF n False" 44 | oddf = ax "OddF (S n) True if EvenF n True; OddF n False" 45 | 46 | evenOddFDs = [ ("EvenF", [[0] :~> [1]]), ("OddF", [[0] :~> [1]]) ] 47 | evenOddAxs = [even, odd, evenf, oddf] -------------------------------------------------------------------------------- /src/Solver/Cycles.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | module Solver.Cycles (cyclic) where 3 | 4 | import Control.Monad.State 5 | import Data.Maybe 6 | import Solver.PP 7 | import Solver.Syntax 8 | import Solver.Trace 9 | 10 | import GHC.Base (liftM2) 11 | 12 | newtype M t = M { runM :: State [(Id, [Id])] t } 13 | deriving (Functor, Applicative, Monad, MonadState [(Id, [Id])]) 14 | 15 | cyclic :: [Proof] -> Bool 16 | cyclic ps = evalState (runM (anyM cyclic' ps)) [] 17 | 18 | cyclic' (PAx v _ _ _ ps) = 19 | do assumes v vs 20 | as <- concatMapM assumedBy vs 21 | b <- anyM cyclic' ps 22 | traceIf (v `elem` vs || v `elem` as) ("Cyclic proof for: " ++ ppx v) $ 23 | return (v `elem` vs || v `elem` as || b) 24 | where vs = concatMap assumptionsIn ps 25 | cyclic' (PCases v cs) = 26 | do assumes v vs 27 | as <- concatMapM assumedBy vs 28 | b <- anyM cyclic' ps 29 | traceIf (v `elem` vs || v `elem` as) ("Cyclic proof for: " ++ ppx v) $ 30 | return (v `elem` vs || v `elem` as || b) 31 | where ps = [pr | (_, _, pr) <- cs] 32 | vs = concatMap assumptionsIn ps 33 | cyclic' (PComputedCases {}) = return False 34 | cyclic' (PAssump v v') 35 | | v == v' = return False 36 | | otherwise = do assumes v [v'] 37 | vs <- assumedBy v' 38 | traceIf (v `elem` vs) ("Cyclic proof for: " ++ ppx v) $ 39 | return (v `elem` vs) 40 | cyclic' (PRequired v _ ps) = 41 | do assumes v vs 42 | as <- concatMapM assumedBy vs 43 | b <- anyM cyclic' ps 44 | traceIf (v `elem` vs || v `elem` as) ("Cyclic proof for: " ++ ppx v) $ 45 | return (v `elem` vs || v `elem` as || b) 46 | where vs = concatMap assumptionsIn ps 47 | cyclic' (PClause v _ _ ps) = 48 | do assumes v vs 49 | as <- concatMapM assumedBy vs 50 | b <- anyM cyclic' ps 51 | traceIf (v `elem` vs || v `elem` as) ("Cyclic proof for: " ++ ppx v) $ 52 | return (v `elem` vs || v `elem` as || b) 53 | where vs = concatMap assumptionsIn ps 54 | cyclic' (PFrom v p p') = liftM2 (||) (cyclic' p) (cyclic' p') 55 | cyclic' (PSkip _ (_, p)) = cyclic' p 56 | cyclic' PInapplicable = return False 57 | cyclic' PExFalso = return False 58 | 59 | anyM :: (Functor m, Monad m) => (t -> m Bool) -> [t] -> m Bool 60 | anyM f xs = or `fmap` mapM f xs 61 | 62 | assumes :: Id -> [Id] -> M () 63 | assumes id ids = modify (\ps -> (id, ids) : ps) 64 | 65 | assumedBy :: Id -> M [Id] 66 | assumedBy id = gets (fromMaybe [] . lookup id) 67 | -------------------------------------------------------------------------------- /src/Solver/Trace.hs: -------------------------------------------------------------------------------- 1 | module Solver.Trace where 2 | 3 | import Control.Monad 4 | import Data.IORef 5 | import Data.List (intercalate) 6 | import qualified Data.IntSet as Set 7 | import qualified Debug.Trace as Trace 8 | import System.Exit 9 | import System.IO 10 | import System.IO.Unsafe 11 | 12 | {-# NOINLINE trace #-} 13 | {-# NOINLINE traceInput #-} 14 | {-# NOINLINE doTrace #-} 15 | {-# NOINLINE doTraceInput #-} 16 | 17 | trace, traceInput :: String -> a -> a 18 | doTrace, doTraceInput :: IORef Bool 19 | 20 | doTrace = unsafePerformIO (newIORef False) 21 | doTraceInput = unsafePerformIO (newIORef False) 22 | 23 | trace_ bref s x = unsafePerformIO (do b <- readIORef bref 24 | when b (Trace.traceIO s) 25 | return x) 26 | 27 | trace = trace_ doTrace 28 | traceInput = trace_ doTraceInput 29 | 30 | traceIf :: Bool -> String -> a -> a 31 | traceIf True s x = trace s x 32 | traceIf False _ x = x 33 | 34 | {-# NOINLINE check #-} 35 | {-# NOINLINE doCheck #-} 36 | {-# NOINLINE checkSolverTreeDepth #-} 37 | {-# NOINLINE checkSimplificationIterations #-} 38 | 39 | doCheck = unsafePerformIO (newIORef True) 40 | checkSolverTreeDepth = unsafePerformIO (newIORef 200) 41 | checkSimplificationIterations = unsafePerformIO (newIORef 20) 42 | checkTrailLength = unsafePerformIO (newIORef (1000 :: Int)) 43 | 44 | check :: IORef t -> (t -> Bool) -> String -> a -> a 45 | check ref pred failMsg success = 46 | unsafePerformIO (do b <- readIORef doCheck 47 | if b 48 | then do v <- readIORef ref 49 | if pred v then fail else return success 50 | else return success) 51 | where fail = do hPutStr stderr ("=== SOLVER CHECK FAILED ===\n" ++ failMsg) 52 | hFlush stderr 53 | exitFailure 54 | 55 | showSet :: Set.IntSet -> String 56 | showSet s = "{" ++ intercalate ", " (map show (Set.toList s)) ++ "}" 57 | -------------------------------------------------------------------------------- /src/Syntax/Specialized.lhs: -------------------------------------------------------------------------------- 1 | > {-# LANGUAGE DeriveDataTypeable #-} 2 | > module Syntax.Specialized (module Syntax.XMPEG, module Syntax.Specialized) where 3 | 4 | > import Data.Generics 5 | > import Syntax.XMPEG 6 | 7 | A specialized program provides a specialized list of top decls, an expression 8 | corresponding to the program entry point, a list of specialized value decls, 9 | and a list of the required primitives. 10 | 11 | > data Specialized = Specialized (TopDecls Type) [(Expr, Bool)] Decls 12 | > deriving (Data, Typeable) 13 | -------------------------------------------------------------------------------- /src/Typechecker.hs: -------------------------------------------------------------------------------- 1 | module Typechecker (inferKinds, inferTypes, cleanupProgram, emptyKindInferenceState, emptyTypeInferenceState) where 2 | 3 | import Typechecker.Cleanup 4 | import Typechecker.TypeInference.Instances 5 | import Typechecker.KindInference 6 | import Typechecker.TypeInference -------------------------------------------------------------------------------- /src/Typechecker/LambdaCaseTyping.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Typechecker.LambdaCaseTyping where 3 | 4 | import Syntax.Common 5 | import Syntax.LambdaCase 6 | import Typechecker.LambdaCasePrims 7 | import Printer.LambdaCase 8 | import Fidget.Env 9 | 10 | -- Split off fun type args 11 | uncurry_type :: Type -> ([Type],Type) 12 | uncurry_type (TyApp (TyApp (TyCon (Kinded "->" _)) t1) t2) = (t1:ts',r) 13 | where (ts',r) = uncurry_type t2 14 | uncurry_type t = ([],t) 15 | 16 | -- Build fully-saturated type from type constructor name and parameter instances 17 | type_from_tcon :: Id -> [Type] -> Type 18 | type_from_tcon d ts = 19 | tapplyn (TyCon (Kinded d (foldr ( \_ k -> KStar `KFun` k) KStar ts))) ts 20 | 21 | -- Build environment of typing info for data constructors. 22 | -- Maps (dcon id,instantiating types) to full dcon type 23 | build_dcon_tcon_env :: [TopDecl] -> Env (Id,[Type]) Type 24 | build_dcon_tcon_env tds = foldr build empty_env tds 25 | where build :: TopDecl -> Env (Id,[Type]) Type -> Env (Id,[Type]) Type 26 | build (Datatype tcon ts cs) env = 27 | foldr (\ (dcon,argts) env -> 28 | extend_env env (dcon,ts) 29 | (foldr fun (type_from_tcon tcon ts) argts)) env cs 30 | build (Bitdatatype tcon _ cs) env = 31 | foldr (\ (dcon,_) env -> 32 | extend_env env (dcon,[]) 33 | (fun (bitdatacase tcon dcon) (type_from_tcon tcon []))) env cs 34 | build _ env = env -- for now 35 | 36 | -- Type reconstruction 37 | type_of :: Expr -> Type 38 | type_of (EVar x t) = t 39 | type_of (EBits n s) = bits (TyLit (fromIntegral s)) -- not sure how this will translate 40 | type_of (ECon c ts t) = t 41 | type_of (ELam _ t e) = t `fun` type_of e 42 | type_of (ELet _ e) = type_of e 43 | type_of (ECase _ (Alt _ _ _ e:_)) = type_of e 44 | type_of (EApp e1 e2) = 45 | case type_of e1 of 46 | TyApp (TyApp (TyCon (Kinded "->" _)) t1) t2 -> t2 47 | _ -> error $ "impossible type_of " ++ show (ppr e1) ++ ":" ++ show (ppr (type_of e1)) 48 | type_of (EFatbar e1 _) = type_of e1 49 | type_of (EBind _ _ _ e) = type_of e 50 | -------------------------------------------------------------------------------- /src/Typechecker/TypeInference.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | module Typechecker.TypeInference (inferTypes, emptyTypeInferenceState, ClassEnv(..), Binding(..), to, (@@), doTrace) where 3 | 4 | import Common 5 | import Control.Monad.State 6 | import Data.Map (Map) 7 | import qualified Data.Map as Map 8 | import Solver (SolverEnv) 9 | import Syntax.Common 10 | import Syntax.IMPEG 11 | import Syntax.IMPEG.TSubst (emptyUnifier) 12 | import qualified Syntax.XMPEG as X 13 | 14 | import Typechecker.TypeInference.Base 15 | import Typechecker.TypeInference.Expr 16 | import Typechecker.TypeInference.Instances 17 | import Typechecker.TypeInference.TopDecl 18 | 19 | ---------------------------------------------------------------------------------------------------- 20 | 21 | type TcPassState = (ClassEnv, TyEnv, CtorEnv, BitdataCtorEnv, BitdataBDDEnv, StructRegionEnv, [RequirementT]) 22 | 23 | emptyTypeInferenceState :: TcPassState 24 | emptyTypeInferenceState = ( ClassEnv ([], [], [], Map.empty, []) Map.empty Map.empty Map.empty 25 | , Map.empty -- type environment 26 | , Map.empty -- constructor environment 27 | , Map.empty -- bitdata constructor environment 28 | , Map.empty -- bitdata BDDs environment 29 | , Map.empty -- structure environment 30 | , [] 31 | ) 32 | 33 | inferTypes :: Has s TcPassState => String -> Pass s (Program Pred KId KId) (X.Program KId, (Map Id (X.Scheme X.Type, Int), SolverEnv)) 34 | inferTypes fn = up (\p -> PassM (StateT (\globals@(classEnv, tyEnv, ctorEnv, bitdataCtors, bitdataBDDs, structRegions, requirementTemplates) -> 35 | do ((p', xctors, tyEnv'), TcState _ ctorEnv' classEnv' _ _ bitdataCtors' bitdataBDDs' structRegions' requirementTemplates') <- 36 | runStateT (runM (checkProgram fn p)) 37 | (TcState tyEnv ctorEnv classEnv ([], []) emptyUnifier bitdataCtors bitdataBDDs structRegions requirementTemplates) 38 | return ((p', (xctors, solverEnvironment classEnv')), 39 | (classEnv', Map.union tyEnv tyEnv', ctorEnv', bitdataCtors', bitdataBDDs', structRegions', requirementTemplates'))))) 40 | -------------------------------------------------------------------------------- /src/albc/LICENSE: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/habit-lang/alb/67a5429f3685a010b4ac4e6f8392ec577fe2b28b/src/albc/LICENSE -------------------------------------------------------------------------------- /src/albc/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /src/albc/albc.cabal: -------------------------------------------------------------------------------- 1 | -- albc.cabal auto-generated by cabal init. For additional options, 2 | -- see 3 | -- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. 4 | -- The name of the package. 5 | Name: albc 6 | 7 | -- The package version. See the Haskell package versioning policy 8 | -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for 9 | -- standards guiding when and how versions should be incremented. 10 | Version: 0.1 11 | 12 | -- A short (one-line) description of the package. 13 | Synopsis: A wrapper for the alb and ccomp compilation chain for Habit 14 | 15 | -- A longer description of the package. 16 | -- Description: 17 | 18 | -- The license under which the package is released. 19 | License: OtherLicense 20 | 21 | -- The file containing the license text. 22 | License-file: LICENSE 23 | 24 | -- The package author(s). 25 | Author: Thomas M. DuBuisson 26 | 27 | -- An email address to which users can send suggestions, bug reports, 28 | -- and patches. 29 | Maintainer: Thomas.DuBuisson@gmail.com 30 | 31 | -- A copyright notice. 32 | -- Copyright: 33 | 34 | Category: Development 35 | 36 | Build-type: Simple 37 | 38 | -- Extra files to be distributed with the package, such as examples or 39 | -- a README. 40 | -- Extra-source-files: 41 | 42 | -- Constraint on the version of Cabal needed to build this package. 43 | Cabal-version: >=1.2 44 | 45 | 46 | Executable albc 47 | -- .hs or .lhs file containing the Main module. 48 | Main-is: Albc.hs 49 | 50 | -- Packages needed in order to build this package. 51 | Build-depends: base, directory, filepath, cmdargs, process, temporary, configurator, text 52 | 53 | -- Modules not exported by this package. 54 | -- Other-modules: 55 | 56 | -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. 57 | -- Build-tools: 58 | 59 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-9.0 2 | packages: 3 | - '.' 4 | extra-deps: 5 | - indentation-0.3.0.1 6 | - indentation-core-0.0 7 | - indentation-parsec-0.0 8 | - indentation-trifecta-0.0 9 | - trifecta-1.5.2 10 | -------------------------------------------------------------------------------- /tests/Bench.hb: -------------------------------------------------------------------------------- 1 | -- a very simple loop for playing with Fidget optimizations 2 | 3 | requires miniprelude 4 | 5 | area a <- (initStored 0) :: Ref (Stored Unsigned) 6 | 7 | loop :: Unsigned -> Ref (Stored Unsigned) -> M () 8 | loop 0 _ = return () 9 | loop n a = do i <- readRef a 10 | writeRef a (i + 1) 11 | loop (n - 1) a 12 | 13 | -- nesting loops in hopes of avoiding blowing the stack 14 | big_loop :: Unsigned -> Ref (Stored Unsigned) -> M () 15 | big_loop 0 _ = return () 16 | big_loop n a = do loop 10000 a 17 | big_loop (n-1) a 18 | 19 | main :: M Unsigned 20 | main = do big_loop 10000 a 21 | return 3 22 | 23 | -------------------------------------------------------------------------------- /tests/BigArray.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | requires test 3 | 4 | 5 | 6 | area big <- (initArray (\x -> initStored 42)) :: Ref( Array 16384 (Stored Unsigned)) 7 | 8 | 9 | main = do 10 | x <- runTests (Cons main0 Nil) 11 | return x 12 | 13 | main0 :: M Bool 14 | main0 = do x <- readRef (big @ 1024) 15 | return (x == 42) 16 | 17 | -------------------------------------------------------------------------------- /tests/Lambda.hb: -------------------------------------------------------------------------------- 1 | requires prelude 2 | -- requires test 3 | 4 | data Ty = TyNat | TyFun Ty Ty 5 | 6 | instance Eq Ty where 7 | TyNat == TyNat = True 8 | TyNat == _ = False 9 | _ == TyNat = False 10 | TyFun t1 t2 == TyFun t1' t2' = (t1 == t1') && (t2 == t2') 11 | 12 | data Lam = Var Unsigned | Abs Ty Lam | App Lam Lam | Zero | Suc Lam 13 | data List a = Nil | Cons a (List a) 14 | 15 | type Env = List Ty 16 | 17 | env_lookup :: List a -> Unsigned -> Maybe a 18 | env_lookup Nil i = Nothing 19 | env_lookup (Cons x xs) i | i == 0 = Just x 20 | | True = env_lookup xs (i - 1) 21 | 22 | typecheck :: Env -> Lam -> Maybe Ty 23 | typecheck e (Var i) = env_lookup e i 24 | typecheck e Zero = return TyNat 25 | typecheck e (Suc l) = do 26 | t <- typecheck e l 27 | case t of 28 | TyNat -> return TyNat 29 | _ -> Nothing 30 | typecheck e (App l l') = do 31 | t <- typecheck e l 32 | t' <- typecheck e l' 33 | case t of 34 | TyFun t1 t2 -> if t' == t1 then return t2 else Nothing 35 | _ -> Nothing 36 | typecheck e (Abs t1 l) = do 37 | t2 <- typecheck (Cons t1 e) l 38 | return (TyFun t1 t2) 39 | 40 | -- main :: M Unsigned 41 | -- main = do 42 | -- x <- runTests (Cons (return (Just (TyFun TyNat TyNat) == typecheck Nil (Abs TyNat (Var 0)))) Nil) 43 | -- return x 44 | 45 | main = Just (TyFun TyNat TyNat) == typecheck Nil (Abs TyNat (Var 0)) -------------------------------------------------------------------------------- /tests/PatternMatchStr.hb: -------------------------------------------------------------------------------- 1 | requires prelude 2 | requires list 3 | requires io 4 | 5 | pat :: List Unsigned -> M Unsigned 6 | 7 | pat "hello" = putStr "hello" 8 | pat _ = putStr "world" 9 | 10 | main :: M Unsigned 11 | main = do pat "hello" 12 | pat "asldfjla" 13 | return (0) 14 | -------------------------------------------------------------------------------- /tests/State.hb: -------------------------------------------------------------------------------- 1 | -- requires prelude 2 | requires test 3 | 4 | data State s a = S (s -> (a, s)) 5 | 6 | instance Monad (State s) where 7 | return a = S (\ s -> (a, s)) 8 | (S m) >>= f = S (\s -> case m s of 9 | (a, s') -> case f a of 10 | S f' -> f' s') 11 | 12 | get :: Unit -> State s s 13 | get _ = S (\s -> (s, s)) 14 | 15 | put :: s -> State s () 16 | put s = S (\s' -> ((), s)) 17 | 18 | type MyS s = State Unsigned s 19 | 20 | incr :: Unit -> MyS () 21 | incr _ = do 22 | s <- get () 23 | put (s + 1) 24 | 25 | execState :: State s a -> s -> s 26 | execState (S f) s = case f s of 27 | (_, s') -> s' 28 | 29 | evalState :: State s a -> s -> a 30 | evalState (S f) s = case f s of 31 | (a, _) -> a 32 | 33 | main :: M Unsigned 34 | main = do 35 | x <- runTests (Cons (return (1 == evalState (incr () >>= (\ x -> get ())) 0)) Nil) 36 | return x 37 | 38 | 39 | -- main = 1 == evalState (incr () >>= (\ x -> get ())) 0 -------------------------------------------------------------------------------- /tests/areas.hb: -------------------------------------------------------------------------------- 1 | -- TODO: compilation fails with alb: type_prim undefined prim name:primStructInit, ... 2 | requires miniprelude 3 | requires ondeckprelude 4 | 5 | struct S [ x, y, z :: Stored Unsigned ] 6 | deriving (NullInit, NoInit) 7 | 8 | {- 9 | baz = S [ x <- initialize | y <- initialize | z <- initialize ] 10 | -} 11 | 12 | area test <- nullInit :: ARef 4 S 13 | 14 | myInit :: Init S 15 | myInit = nullInit 16 | 17 | struct S0 [ x, y, z :: Stored Unsigned ] 18 | struct S1/12 [ x, y, z :: Stored Unsigned ] 19 | struct S2/(8+4) [ x, y, z :: Stored Unsigned ] 20 | struct S3/(3*4) [ x, y, z :: Stored Unsigned ] 21 | struct S4/((1+2)*(1+1+1+1)) 22 | [ x, y, z :: Stored Unsigned ] 23 | type SLength = 6 * 2 24 | struct S5/SLength 25 | [ x, y, z :: Stored Unsigned ] 26 | --The following should not be valid! 27 | --struct S6/n [ x, y, z :: Stored Unsigned ] 28 | --struct S7/(n + m) [ x, y, z :: Stored Unsigned ] 29 | 30 | struct R [ u <- primInitS0 :: S0 | v :: Stored Unsigned | w :: S0 ] 31 | struct R1 [ u :: S0 | Stored Unsigned | w :: S0 ] 32 | 33 | struct T [ left :: Array 10 (Stored Unsigned) 34 | | right :: Array 2 (Array 4 (Stored Unsigned)) ] 35 | 36 | ----area foo :: ARef 8 (Array 12 (Stored Unsigned)) 37 | ----area bar <- primInitS0 :: ARef 4 S0 38 | 39 | primitive primInitS0 :: Init S0 40 | 41 | -- rejected, correctly: (multiple fields called x, y) 42 | -- struct U [ x :: Stored Unsigned | x :: Stored Unsigned | y :: Stored Unsigned | x :: Stored Unsigned | y :: Stored Unsigned ] 43 | 44 | -- rejected, correctly: (multiple fields called x) 45 | -- bitdata V = HJ [ x :: Bit 5 | x :: Bit 4 ] 46 | 47 | bitdata V = HJ [ x :: Bit 5 | xy :: Bit 4 ] 48 | 49 | -- Rejected: there are no fields called z for constructor HJ 50 | -- t1 = HJ [ xy = B1010 | x = B10101 | z = B11 ] 51 | 52 | -- Rejected: multiple 53 | -- t2 = HJ [ xy = B1010 | x = B10101 | x = B11111 ] 54 | -- t3 = HJ [ xy = B1010 | x = B11111 | x = B10101 ] 55 | 56 | main = id True 57 | -------------------------------------------------------------------------------- /tests/bubble.hb: -------------------------------------------------------------------------------- 1 | -- Work in progress.... 2 | requires miniprelude 3 | 4 | swap :: Storable a => Ref (Stored a) -> Ref (Stored a) -> M () 5 | swap l r = do temp <- readRef l 6 | readRef r >>= writeRef l 7 | writeRef r temp 8 | 9 | 10 | for :: Index n => (Ix n) -> (Ix n) -> ((Ix n) -> M ()) -> M () 11 | for i j f | i == j = f i 12 | | i < j = do f i 13 | case (incIx i) of 14 | Just i' -> for i' j f 15 | Nothing -> return () -------------------------------------------------------------------------------- /tests/bug0050.hb: -------------------------------------------------------------------------------- 1 | -- Bug #50: The primMaybeIx LC->Fidget rule doesn't always match 2 | 3 | requires miniprelude 4 | requires test 5 | 6 | area a <- (initArray (\ix -> 0)) :: ARef 1 (Array 64 (Stored (Ix 32))) 7 | 8 | main0 :: M Bool 9 | main0 = do 10 | case maybeIx 0 of 11 | Nothing -> return 0 12 | Just i' -> readRef (a @ i') 13 | return True 14 | 15 | main = do 16 | x <- runTests (Cons (main0) Nil) 17 | return x 18 | -------------------------------------------------------------------------------- /tests/bug0677.hb: -------------------------------------------------------------------------------- 1 | -- Bug #677: Specializer generates "Prelude.(!!): index too large" 2 | requires miniprelude 3 | 4 | main _ = id True 5 | -------------------------------------------------------------------------------- /tests/bug25.hb: -------------------------------------------------------------------------------- 1 | f x = incIx x 2 | 3 | main = f (1 :: Ix 256) -------------------------------------------------------------------------------- /tests/bugIxBound.hb: -------------------------------------------------------------------------------- 1 | -- Bug #51: Using Bounded (Ix n) causes a type error 2 | 3 | requires prelude 4 | requires test 5 | 6 | main = do 7 | x <- runTests (Cons (return (2 == unsigned (maxBound :: Ix 3))) Nil) 8 | return x 9 | -------------------------------------------------------------------------------- /tests/example-test.hb: -------------------------------------------------------------------------------- 1 | requires test 2 | 3 | -- To write a test, make your "main" look like this and add the file 4 | -- to "TESTS" in the "Makefile". runTests expects a list of "M Bool" 5 | -- that return True if the test passes and False if the test fails. 6 | 7 | main = do 8 | x <- runTests (Cons (return True) (Cons (return (True == True)) Nil)) 9 | return x 10 | -------------------------------------------------------------------------------- /tests/fieldlabels.hb: -------------------------------------------------------------------------------- 1 | requires prelude 2 | 3 | data Foo = Foo[cake :: Foo | isFrosty :: Bool] 4 | | Bar Unsigned 5 | 6 | foo = Foo[isFrosty = True | cake = Foo[isFrosty = False | cake = Foo (Bar 1) False]] 7 | 8 | bar Foo[isFrosty = x | cake = Foo[cake = Foo y z]] = 9 | Foo[isFrosty = x && z | cake = y] -------------------------------------------------------------------------------- /tests/flexPages_noLit.hb: -------------------------------------------------------------------------------- 1 | -- ### Flexpage data type and operations: 2 | 3 | type WordSize = 32 4 | type ByteSize = 8 5 | 6 | 7 | -- Permissions: 8 | 9 | bitdata Perms/3 = Perms [ r, w, x :: Bit 1 ] 10 | 11 | nilPerms :: Perms 12 | nilPerms = Perms [ r=B0 | w=B0 | x=B0 ] 13 | 14 | allPerms :: Perms 15 | allPerms = Perms [ r=B1 | w=B1 | x=B1 ] 16 | 17 | 18 | -- Flexpages: 19 | 20 | bitdata Fpage/WordSize 21 | = Fpage [ base :: Bit 22 | size :: Bit 6 | B0 | perms :: Perms ] 22 | 23 | 24 | fpageSize :: Fpage -> Bit 6 25 | fpageSize fp = fpsize fp.size 26 | 27 | fpsize :: Bit 6 -> Bit 6 28 | fpsize n 29 | | n==1 || n==32 = 32 30 | | n<12 || n>32 = 0 31 | | otherwise = n 32 | 33 | 34 | fpageMask :: Fpage -> Unsigned 35 | fpageMask fp = fpmask fp.size 36 | 37 | fpmask :: Bit 6 -> Unsigned 38 | fpmask n 39 | | n==1 || n==32 = not 0 40 | | n<12 || n>32 = 0 41 | | otherwise = (1 << n) - 1 42 | 43 | -- It would be nice to have *fpmask* and *fpsize* compiled into 44 | -- lookup tables. 45 | 46 | 47 | -- Nil and complete flexpages: 48 | 49 | nilFpage :: Fpage 50 | nilFpage = Fpage [ base=0 | size=0 | perms=nilPerms ] 51 | 52 | isNil :: Fpage -> Bool 53 | isNil fp = fpageMask fp == 0 54 | 55 | completeFpage :: Perms -> Fpage 56 | completeFpage p = Fpage [ base=0 | size=1 | perms=p ] 57 | 58 | isComplete :: Fpage -> Bool 59 | isComplete fp = not (fpageMask fp) == 0 60 | 61 | 62 | -- Flexpage address ranges: 63 | 64 | fpageStart :: Fpage -> Unsigned 65 | fpageStart fp = (fp.base # 0) .&. not (fpageMask fp) 66 | 67 | fpageEnd :: Fpage -> Unsigned 68 | fpageEnd fp = (fp.base # 0) .|. fpageMask fp 69 | 70 | 71 | inside :: Fpage -> Fpage -> Bool 72 | fp1 `inside` fp2 = (fpageStart fp1 <= fpageStart fp2) 73 | && (fpageEnd fp2 <= fpageEnd fp1) 74 | 75 | overlaps :: Fpage -> Fpage -> Bool 76 | fp1 `overlaps` fp2 = not (fp1 `disjoint` fp2) 77 | 78 | disjoint :: Fpage -> Fpage -> Bool 79 | fp1` disjoint` fp2 = (fp1 `before` fp2) || (fp2 `before` fp1) 80 | 81 | before :: Fpage -> Fpage -> Bool 82 | fp1 `before` fp2 = fpageEnd fp1 < fpageStart fp2 83 | 84 | 85 | -- Trimming flexpages: 86 | 87 | trimFpage :: Fpage -> Unsigned -> Fpage -> Fpage 88 | trimFpage big base small 89 | = small [ base = (big.base .&. not bmask) .|. (base .&. bmask .&. not smask) ] 90 | where (bmask # _ ) = fpageMask big 91 | (smask # _ ) = fpageMask small 92 | 93 | 94 | -------------------------------------------------------------------------------- /tests/foo.hb: -------------------------------------------------------------------------------- 1 | requires prelude 2 | requires test 3 | 4 | main = do 5 | x <- runTests (Cons (equalM 3 main4) (Cons (equalM 3 main5) Nil)) 6 | return x 7 | 8 | -- This works: 9 | 10 | m4 :: () -> Unsigned 11 | m4 _ = 3 12 | 13 | main4 :: M Unsigned 14 | main4 = do x <- return (m4 ()) 15 | return x 16 | 17 | -- This fails: 18 | 19 | m5 :: () -> Unsigned 20 | m5 () = 3 21 | 22 | main5 :: M Unsigned 23 | main5 = do x <- return (m5 ()) 24 | return x 25 | -------------------------------------------------------------------------------- /tests/fragments/assocTypes.lhb: -------------------------------------------------------------------------------- 1 | ### Associated types, superclasses, functional notation (Graph library example): 2 | 3 | > requires prelude 4 | > requires list 5 | 6 | > class Edge (g :: *) (e :: *) | g -> e 7 | > class Vertex (g :: *) (v :: *) | g -> v 8 | 9 | > --class Graph g requires Edge g e, Vertex g v where ... 10 | > class Graph g 11 | > where src, tgt :: Edge g -> g -> Vertex g 12 | 13 | > class IncidenceGraph g | Graph g 14 | > where out_edges :: Vertex g -> g -> List (Edge g) 15 | > out_degree :: Vertex g -> g -> Unsigned 16 | 17 | > class BidirectionalGraph g | IncidenceGraph g 18 | > where in_edges :: Vertex g -> g -> List (Edge g) 19 | > in_degree :: Vertex g -> g -> Unsigned 20 | > degree :: Vertex g -> g -> Unsigned 21 | 22 | > class AdjacencyGraph g | Graph g 23 | > where adjacent_vertices :: Vertex g -> g -> List (Vertex g) 24 | 25 | > class VertexListGraph g | Graph g 26 | > where vertices :: g -> List (Vertex g) 27 | > num_vertices :: g -> Unsigned 28 | 29 | > class EdgeListGraph g | Graph g 30 | > where edges :: g -> List (Edge g) 31 | > num_edges :: g -> Unsigned 32 | -------------------------------------------------------------------------------- /tests/fragments/bitdata.hb: -------------------------------------------------------------------------------- 1 | requires prelude 2 | 3 | bitdata Foo = Foo [ x = 0 :: Unsigned ] 4 | | Bar [ y :: Bit 16 | z :: Bit 16 ] 5 | 6 | bitdata Baz = Baz [ x :: Foo ] 7 | | Quux [ y :: Unsigned ] 8 | 9 | bitdata Solo = S [ x :: Baz ] 10 | 11 | type Nibble = Bit 8 12 | 13 | bitdata Bozo = Bozo [ x, y :: Nibble ] 14 | 15 | x = Foo [] 16 | v = Foo 17 | --w = Bar [] 18 | z = Bar [y = 0 | z = 0] 19 | y = Foo [x = 0] 20 | 21 | 22 | f x = case x of 23 | Foo [x] -> Foo [x = x + 1] 24 | Bar [y = a | z = b] -> Bar [y = a | z = a + b] 25 | 26 | g x = case x of 27 | Foo r -> Foo [x = r.x + 1] 28 | Bar r -> Bar [y = r.y | z = r.y + r.z] 29 | -------------------------------------------------------------------------------- /tests/fragments/caseExprs.lhb: -------------------------------------------------------------------------------- 1 | ### Some examples using case expressions: 2 | 3 | > requires prelude 4 | 5 | > data List a = Nil | Cons a (List a) 6 | > Nil ++ ys = ys 7 | > Cons x xs ++ ys = Cons x (xs ++ ys) 8 | > instance Monad List 9 | > where return x = Cons x Nil 10 | > Nil >>= _ = Nil 11 | > Cons x xs >>= f = f x ++ (xs >>= f) 12 | 13 | otherwise = otherwise 14 | 15 | > map f xs = case xs of 16 | > Nil -> Nil 17 | > (Cons x xs) -> Cons (f x) (map f xs) 18 | 19 | > map1 f xs = case xs of 20 | > Nil -> Nil 21 | > Cons x xs -> Cons (f x) (map1 f xs) 22 | 23 | > map2 f xs = case xs of 24 | > Nil -> Nil 25 | > x `Cons` xs -> f x `Cons` map2 f xs 26 | 27 | > mapM f xs = case xs of 28 | > Nil -> return Nil 29 | > Cons x xs -> do y <- f x 30 | > ys <- mapM f xs 31 | > return (Cons y ys) 32 | 33 | > foo xs = case<- xs of 34 | > Nil -> Nil 35 | > Cons y ys -> append y ys 36 | 37 | > append xs ys = 38 | > case xs 39 | > of Nil -> Nil 40 | > Cons x xs -> Cons x (append xs ys) 41 | 42 | return :: a -> p a 43 | return = return 44 | 45 | > filter p xs = case xs of 46 | > Nil -> Nil 47 | > Cons y ys | p y -> Cons y rest 48 | > | otherwise -> rest 49 | > where rest = filter p ys 50 | -------------------------------------------------------------------------------- /tests/fragments/caseFromTests.lhb: -------------------------------------------------------------------------------- 1 | > requires prelude 2 | 3 | > f p q r = case x <- p of 4 | > True -> q x 5 | > r x 6 | > _ -> r x 7 | > q x 8 | 9 | > g c p = case<- c of 10 | > True -> p 11 | 12 | > h c d p = case<- c of 13 | > True -> case<- d of 14 | > True -> p 15 | 16 | > i x y z = case x of 17 | > True -> y 18 | > False -> case y of 19 | > True -> z 20 | > False -> y 21 | 22 | > j x p = do case<- x of 23 | > True -> p 24 | > case<- x of 25 | > False -> p 26 | > p 27 | -------------------------------------------------------------------------------- /tests/fragments/colonhash.hb: -------------------------------------------------------------------------------- 1 | requires prelude 2 | 3 | foo :: Bit 8 -> Bit 12 4 | foo ((x :: Bit 6) :# y) = x :# x 5 | 6 | upper (x :# y) = x 7 | 8 | upper6 :: Bit 12 -> Bit 6 9 | upper6 = upper 10 | 11 | bar ((x :: Bit 6) :# y) = x :# x 12 | 13 | baz (x :# y) = f x :# y 14 | where f :: Bit 4 -> Bit 4 15 | f x = x 16 | -------------------------------------------------------------------------------- /tests/fragments/confusedJunk.hb: -------------------------------------------------------------------------------- 1 | requires prelude 2 | 3 | bitdata Vals = V [ x :: Bit 2 | B001 | y :: Perms ] 4 | | W [ u :: Bit 2 | B010 | B111 ] 5 | 6 | bitdata Perms = Perms [ r, w, x :: Bit 1 ] 7 | 8 | bitdata Whittle = None [ B00000 ] 9 | | Some [ x :: Bit 4 | B0 ] 10 | | Many [ y :: Bit 4 | B0 ] 11 | deriving ToBits, FromBits 12 | 13 | bitdata Toys = T [ x :: Bit 2 | B001 | y :: Ix 6 ] 14 | 15 | bitdata Frank = Jet [ engine :: Bit 4 ] 16 | | Turbo [ prop :: Bit 1 | B010 ] 17 | | Glider [ span :: Bit 2 | other :: Odd ] 18 | deriving ToBits, FromBits 19 | 20 | bitdata Odd = A [ B00 ] 21 | | B [ B11 ] 22 | deriving ToBits, FromBits 23 | -------------------------------------------------------------------------------- /tests/fragments/defaults.hb: -------------------------------------------------------------------------------- 1 | requires prelude 2 | requires list 3 | 4 | class Eq2 t 5 | where eq, neq :: t -> t -> Bool 6 | neq x y = not (eq x y) 7 | 8 | -- an implicitly typed, recursive, overloaded, function binding: 9 | member x Nil = False 10 | member x (Cons y ys) | eq x y = True 11 | | otherwise = member x ys 12 | 13 | instance Eq2 Bool 14 | where eq True True = True 15 | eq False False = True 16 | eq _ _ = False 17 | 18 | instance Eq2 (List t) if Eq2 t 19 | where eq Nil Nil = True 20 | eq (Cons x xs) (Cons y ys) = if eq x y then eq xs ys else False 21 | eq _ _ = False 22 | 23 | class Integral (t :: *) 24 | class Fractional (t :: *) 25 | class RealFrac t | Fractional t 26 | where floor :: Integral u => t -> u 27 | 28 | data Float 29 | instance Fractional Float 30 | instance RealFrac Float 31 | where floor = floatFloor 32 | 33 | primitive floatFloor :: Integral u => Float -> u 34 | 35 | xor x y = neq x y 36 | 37 | main = eq (eq (Cons True (Cons False Nil)) Nil) 38 | (member True (Cons False Nil)) 39 | 40 | nestedLists = Cons (Cons True Nil) Nil 41 | -------------------------------------------------------------------------------- /tests/fragments/doNotation.lhb: -------------------------------------------------------------------------------- 1 | ### Some examples using do notation: 2 | 3 | > requires prelude 4 | 5 | > test = test -- Dummy test 6 | 7 | > proc0 = do proc1 8 | > proc2 9 | > proc3 10 | 11 | > proc1 = do x <- proc2 12 | > y <- proc3 13 | > z <- proc2 14 | > return (x, y, z) 15 | 16 | > proc2 = if<- test then 17 | > proc3 18 | > proc3 19 | > else 20 | > proc3 21 | > proc3 22 | 23 | Variations on indentation; shouldn't be relevant here anyway because we're 24 | not inside an if: 25 | 26 | > proc2a = if<- test then 27 | > proc3 28 | > proc3 29 | > else 30 | > proc3 31 | > proc3 32 | 33 | > proc2b = if<- test 34 | > then 35 | > proc3 36 | > proc3 37 | > else 38 | > proc3 39 | > proc3 40 | 41 | > proc3 = do x <- test -- don't expect this to terminate! :-) 42 | > if x then 43 | > proc3 44 | > proc3 45 | > else 46 | > proc3 47 | > proc3 48 | 49 | Indentation variations: 50 | 51 | > proc3a = do x <- test -- don't expect this to terminate! :-) 52 | > if x then 53 | > proc3 54 | > proc3 55 | > else 56 | > proc3 57 | > proc3 58 | 59 | > proc3b = do x <- test -- don't expect this to terminate! :-) 60 | > if x 61 | > then 62 | > proc3 63 | > proc3 64 | > else 65 | > proc3 66 | > proc3 67 | 68 | > (f >=> g) x = do y <- f x; g y 69 | 70 | > proc4 = do do proc3 71 | > proc3 72 | > proc2 73 | > do proc3 74 | > proc3 75 | > proc4 76 | -------------------------------------------------------------------------------- /tests/fragments/evcase.hb: -------------------------------------------------------------------------------- 1 | requires prelude 2 | 3 | class C t 4 | where foo :: t -> t 5 | 6 | class D t 7 | where bar :: t -> t 8 | 9 | class E t 10 | where baz :: t -> t 11 | 12 | instance D t if C t 13 | where bar = foo 14 | else D t fails 15 | 16 | instance E t if C t 17 | where baz = foo 18 | 19 | f :: D t => t -> t 20 | f = baz 21 | 22 | instance C Bool 23 | where foo = not 24 | 25 | main = f False -------------------------------------------------------------------------------- /tests/fragments/fundeps.hb: -------------------------------------------------------------------------------- 1 | requires prelude 2 | requires list 3 | 4 | data Int 5 | 6 | class F (a :: *) = (b :: *) 7 | where foo :: a -> b 8 | 9 | instance F Int = Bool 10 | where foo _ = True 11 | 12 | instance F Bool = _ 13 | where foo = primFoo 14 | 15 | primitive primFoo :: Bool -> F Bool 16 | 17 | instance F (List t) = List u if F t = u 18 | where foo (Cons x xs) = Cons (foo x) Nil 19 | 20 | notb True = False 21 | notb False = True 22 | 23 | g :: F Int b => b -> b 24 | g x = notb x 25 | 26 | h :: F Int b => b -> b 27 | h = notb 28 | 29 | class Equal t u | t -> u, u -> t 30 | where ident :: t -> u 31 | 32 | instance Equal t t 33 | where ident x = x 34 | 35 | r :: t -> t 36 | r x = ident x 37 | 38 | s :: Equal t u => t -> u 39 | s x = x -------------------------------------------------------------------------------- /tests/fragments/funnote.hb: -------------------------------------------------------------------------------- 1 | requires prelude 2 | 3 | class T x | -> x 4 | where f :: x 5 | 6 | instance T Unsigned 7 | where f = 0 8 | 9 | g :: T 10 | g = f 11 | {- 12 | class S x 13 | where h :: x 14 | 15 | j :: S 16 | j = h 17 | -} 18 | class A x y | x -> y 19 | 20 | instance A x Unsigned 21 | 22 | i :: A T 23 | i = g 24 | 25 | j :: A t = b => b 26 | j = g 27 | 28 | k :: A t b => b 29 | k = g 30 | 31 | {- 32 | l :: A t b c => c 33 | l = g 34 | -} -------------------------------------------------------------------------------- /tests/fragments/ifExprs.lhb: -------------------------------------------------------------------------------- 1 | ### Examples using if then else expressions: 2 | 3 | > cond0 x y = if x then 1 else 2 4 | > cond1 x y = if x then if y then 1 else 2 else 3 5 | > cond2 x y = if x then 1 else if y then 2 else 3 6 | > cond3 x y = if x then 7 | > if y then 1 else 2 8 | > else 9 | > if y then 3 else 4 10 | 11 | Error cases (misformed conditionals): 12 | 13 | > cand0 x y = if x then 1 14 | > cand1 x y = if x then if y then 1 else 2 15 | > cand2 x y = if x else if y else 3 16 | > cand3 x y = if x then 17 | > else 18 | > if y then 3 else 4 19 | > cand4 x y = if x else 2 20 | > cand5 x y = if x 21 | > cand6 x y = if then else 22 | 23 | > id x = x -- A test line that should be accepted without errors; 24 | > -- checks that we recovered ok from above errors ... 25 | 26 | -------------------------------------------------------------------------------- /tests/fragments/kpoly.hb: -------------------------------------------------------------------------------- 1 | requires prelude 2 | 3 | class t == u | t -> u, u -> t 4 | 5 | instance t == t 6 | 7 | f :: (t == u) => t v -> u v 8 | f x = x 9 | 10 | g :: (t == u) => t -> u 11 | g x = x 12 | 13 | g' :: (f == g, t == u) => f t -> g u 14 | g' x = x 15 | 16 | data Q t u = Q (t u) 17 | 18 | data Lab (l :: lab) = TheLab 19 | 20 | data T = C (Q Maybe Unsigned) | D (Q Lab "foo") 21 | 22 | data TheNat (n :: nat) = TheNat 23 | 24 | h :: Q TheNat 2 25 | h = Q TheNat 26 | 27 | j :: Q Maybe Unsigned 28 | j = Q Nothing 29 | 30 | k :: (Q TheNat 2, Q Maybe Unsigned) 31 | k = (h, j) 32 | 33 | data Either t u = Left t | Right u 34 | 35 | l :: Q (Either Unsigned) Unsigned 36 | l = Q (Left 1) 37 | 38 | m :: Q (Q Maybe) Unsigned 39 | m = Q (Q Nothing) 40 | 41 | -- Kind errors 42 | 43 | -- err :: Q Unsigned Unsigned 44 | -- err = Q 1 45 | 46 | -- err2 :: Q Either Unsigned 47 | -- err2 = Q (Left 1) 48 | 49 | -- data U (t :: k) = U (t Unsigned) 50 | 51 | -- class D (t :: k) 52 | -- where foo :: t u -> Unsigned 53 | 54 | class (t :: k) =:= (u :: k) | t -> u, u -> t 55 | instance t =:= t 56 | 57 | -- This shouldn't work 58 | -- ff :: (t =:= u) => t v -> u -> u 59 | -- ff x y = y 60 | 61 | gg :: (t =:= u, v =:= w) => t v -> u w 62 | gg x = x 63 | 64 | hh :: (t == Unsigned) => Proxy (t :: k) -> Unsigned 65 | hh _ = 0 66 | 67 | -- This doesn't work either: =:= insists on arguments of the same kind, whereas == is just 68 | -- falsifiable for arguments of different kinds. 69 | -- jj :: (t =:= Unsigned) => Proxy (t :: k) -> Unsigned 70 | -- jj _ = 0 71 | -------------------------------------------------------------------------------- /tests/fragments/literals.lhb: -------------------------------------------------------------------------------- 1 | ### More literal tests: 2 | 3 | > requires prelude 4 | 5 | Miscellaneous bit vector literals: 6 | 7 | > a0 :: Bit 2 8 | > a0 = B00 9 | 10 | > a1 :: Bit 3 11 | > a1 = B_101 12 | 13 | > a2 :: Bit 5 14 | > a2 = B10101 15 | 16 | > a3 :: Bit 9 17 | > a3 = O377 18 | 19 | > a4 :: Bit 8 20 | > a4 = Xff 21 | 22 | > a5 :: Bit 4 23 | > a5 = B0101 24 | 25 | > a6 :: Bit 8 26 | > a6 = B_1111_0000 27 | 28 | > a7 :: Bit 32 29 | > a7 = X_FfFf_0000 30 | 31 | Miscellaneous int literals: 32 | 33 | > b0 :: Bit 0b1101 34 | > b0 = 0b00 35 | 36 | > b1 :: Bit 0x3 37 | > b1 = 0b_101 38 | 39 | > b2 :: Bit 0o10 40 | > b2 = 0b10101 41 | 42 | > b3 :: Bit 0x8 43 | > b3 = 0o377 44 | 45 | > b4 :: Bit 0b_10_0000 46 | > b4 = 0xff 47 | 48 | > b5 :: Bit 3 49 | > b5 = 0b0101 50 | 51 | > b6 :: Bit 0o10 52 | > b6 = 0b_1111_0000 53 | 54 | > b7 :: Bit 0x20 55 | > b7 = 0X_FfFf_0000 56 | -------------------------------------------------------------------------------- /tests/from_c.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | requires list 3 | requires io 4 | 5 | area counter <- (initStored 3) :: Ref (Stored Unsigned) 6 | 7 | incArea :: M Unsigned 8 | incArea = do 9 | v <- readRef counter 10 | writeRef counter (v + 1) 11 | return v 12 | 13 | inc :: Unsigned -> Unsigned -> M Unsigned 14 | inc x y = return (0x10000 * x + y + 1) 15 | 16 | incPure :: Unsigned -> Unsigned -> Unsigned 17 | incPure x y = 0x10000 * x + y + 1 18 | 19 | main :: M Unsigned 20 | main = do 21 | x <- return 0 22 | return x 23 | -------------------------------------------------------------------------------- /tests/from_c_driver.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | extern int main0(void); 5 | extern unsigned inc(void * /*gc roots*/, unsigned /*int32*/, unsigned /*int32*/, unsigned /*unit*/); 6 | extern unsigned incPure(void * /*gc roots*/, unsigned /*int32*/, unsigned /*int32*/); 7 | extern unsigned incArea(void * /*gc roots*/, unsigned /*unit*/); 8 | 9 | int main () { 10 | printf("Starting initialization\n"); 11 | main0(); // Calls "main" from Habit. Needed to triggar GC initialization. 12 | printf("Finished initialization\n"); 13 | printf("Monadic:%x\n", inc(NULL,0x40,0x30,0)); 14 | printf("Pure:%x\n", incPure(NULL,0x40,0x30)); 15 | printf("Area:%x\n", incArea(NULL,0x20)); 16 | printf("Area:%x\n", incArea(NULL,0x20)); 17 | printf("Area:%x\n", incArea(NULL,0x20)); 18 | printf("Area:%x\n", incArea(NULL,0x20)); 19 | return 0; 20 | } 21 | -------------------------------------------------------------------------------- /tests/io-test.hb: -------------------------------------------------------------------------------- 1 | requires prelude 2 | requires io 3 | 4 | main :: M Unsigned 5 | main = do 6 | putchar 72; putchar 105; putchar 10 -- "Hi\n" 7 | putint (negate 1) 8 | putchar 0x0A 9 | putint 0 10 | putchar 0x0A 11 | putint 9 12 | putchar 0x0A 13 | putint 10 14 | putchar 0x0A 15 | putint 99 16 | putchar 0x0A 17 | putint 100 18 | putchar 0x0A 19 | putint 123 20 | putchar 0x0A 21 | putint 4294 22 | putchar 0x0A 23 | putint 42949 24 | putchar 0x0A 25 | putint 429496 26 | putchar 0x0A 27 | putint 4294967 28 | putchar 0x0A 29 | putint 42949672 30 | putchar 0x0A 31 | putint 429496729 32 | putchar 0x0A 33 | putint 4294967295 34 | putchar 0x0A 35 | return 0 36 | -------------------------------------------------------------------------------- /tests/io.hb: -------------------------------------------------------------------------------- 1 | requires prelude 2 | requires list 3 | 4 | -- Perhaps these types could be updated? I'm guessing that putchar should really return unit, and 5 | -- fflush doesn't need an argument? 6 | 7 | primitive getchar :: M Unsigned -- really should be Signed for -1 8 | primitive putchar :: Unsigned -> M Unsigned 9 | primitive fflush :: Unsigned -> M Unsigned 10 | 11 | flush :: M () 12 | flush = do 13 | b <- return True 14 | fflush 0 15 | return () 16 | 17 | getint :: M Unsigned 18 | getint = do x0 <- getchar 19 | if x0 == (negate 1) 20 | then return (negate 1) 21 | else do x1 <- getchar 22 | if x1 == (negate 1) 23 | then return (negate 1) 24 | else do x2 <- getchar 25 | if x2 == (negate 1) 26 | then return (negate 1) 27 | else do x3 <- getchar 28 | if x3 == (negate 1) 29 | then return (negate 1) 30 | else return (x3 `shiftL` 24 + x2 `shiftL` 16 + x1 `shiftL` 8 + x0) 31 | 32 | putint :: Unsigned -> M () 33 | putint d | d < 10 = do putchar (d + 0x30); return () 34 | | True = do putint (div10 d); putint (mod10 d) 35 | where mod10 :: Unsigned -> Unsigned 36 | mod10 x = unsigned (modIx x :: Ix 10) 37 | 38 | div10 :: Unsigned -> Unsigned 39 | div10 x | x < 10 = 0 40 | | True = f 1 41 | where f k = if x < 100 * k || k >= maxK then k + div10 (x - (10 * k)) else f (k * 10) 42 | maxK = 10000000 43 | 44 | putHexChar :: Unsigned -> M Unsigned 45 | putHexChar d | d < 0xa = putchar (d + 0x30) 46 | | True = putchar (d + 0x37) 47 | 48 | putHexInt :: Unsigned -> M () 49 | putHexInt d | d < 16 = do putHexChar d; return () 50 | | True = do putHexInt (d `shiftR` 4); putHexInt (d .&. 0xF) 51 | 52 | putLine :: M Unsigned 53 | putLine = do 54 | x <- return () 55 | putchar 0x0A 56 | 57 | readInts :: M (List (Bit 32)) 58 | readInts = do 59 | x <- getint 60 | if x == (negate 1) then return Nil else do { xs <- readInts; return (Cons x.bits xs) } 61 | 62 | 63 | putStr :: List Unsigned -> M Unsigned 64 | putStr Nil = return (0) 65 | putStr (Cons x xs) = do putchar x 66 | putStr xs 67 | -------------------------------------------------------------------------------- /tests/largeword-driver.hb: -------------------------------------------------------------------------------- 1 | requires prelude 2 | requires largeword 3 | requires test 4 | 5 | main :: M Unsigned 6 | main = do 7 | x <- runTests (Cons (do x <- return (bit 4504 :: Word8192) 8 | y <- return (bit 4505 :: Word8192) 9 | return (((y + x) - y) == x)) Nil) 10 | return x 11 | -------------------------------------------------------------------------------- /tests/listdriver.hb: -------------------------------------------------------------------------------- 1 | requires list 2 | requires test 3 | 4 | main = do 5 | x <- runTests (Cons main0 (Cons main1 (Cons main2 (Cons main3 (Cons main4 6 | (Cons main5 (Cons main6 (Cons main7 (Cons main8 Nil))))))))) 7 | return x 8 | 9 | main0 :: M Bool 10 | main0 = do x <- return (False == (null (Cons (0::Unsigned) Nil))) 11 | return x 12 | 13 | succ x = x + 1 14 | 15 | upto :: Unsigned -> List Unsigned 16 | upto n = iterate n succ 0 17 | 18 | lensucc _ y = y + 1 19 | 20 | len = foldr lensucc 0 21 | 22 | main1 :: M Bool 23 | main1 = do x <- return (100 == (length (upto 100))) 24 | return x 25 | 26 | main2 :: M Bool 27 | main2 = do x <- return (99 == (last (upto 100))) 28 | return x 29 | 30 | main3 :: M Bool 31 | main3 = do x <- return ((100::Unsigned) == (len (upto 100))) 32 | return x 33 | 34 | main4 :: M Bool 35 | main4 = do x <- return (0 == (length (upto 0))) 36 | return x 37 | 38 | main5 :: M Bool 39 | main5 = do x <- return (1 == (length (upto 1))) 40 | return x 41 | 42 | -- This one dies in backend: 43 | 44 | main6 :: M Bool 45 | main6 = do x <- return 46 | (and (Cons (upto 100 == upto 100) 47 | (Cons (upto 100 == reverse (reverse (upto 100))) 48 | (Cons (sum (upto 100) == sum (reverse (upto 100))) 49 | (Cons (upto 100 == foldr Cons Nil (upto 100)) 50 | Nil))))) 51 | return x 52 | 53 | bug1 :: M Bool 54 | bug1 = do x <- return (upto 100 == foldr Cons Nil (upto 100)) 55 | return x 56 | 57 | -- This one succeeds: 58 | 59 | main7 :: M Bool 60 | main7 = do x <- return 61 | (and (Cons (upto 100 == upto 100) 62 | (Cons (upto 100 == reverse (reverse (upto 100))) 63 | (Cons (sum (upto 100) == sum (reverse (upto 100))) 64 | Nil)))) 65 | return x 66 | 67 | singleton x = Cons x Nil 68 | el x = elem x (upto 100) 69 | 70 | main8 :: M Bool 71 | main8 = do x <- return 72 | (and 73 | (Cons (100 == length (upto 100)) 74 | (Cons (99 == last (upto 100)) 75 | (Cons (upto 100 == upto 100) 76 | (Cons (upto 100 /= (reverse (upto 100))) 77 | (Cons (upto 100 == reverse (reverse (upto 100))) 78 | (Cons (sum (upto 100) == sum (reverse (upto 100))) 79 | (Cons (upto 100 == concat (map singleton (upto 100))) 80 | (Cons (False == elem 100 (upto 100)) 81 | (Cons (True == and (map el (upto 100))) 82 | Nil)))))))))) 83 | return x 84 | -------------------------------------------------------------------------------- /tests/local.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | 3 | data Pair t = Pair t t 4 | 5 | h x z = 6 | let f y = Pair x y 7 | in f z 8 | 9 | g :: a -> (a -> Pair a) 10 | g x z = 11 | let f y = Pair x y 12 | in f z 13 | -------------------------------------------------------------------------------- /tests/logical.hb: -------------------------------------------------------------------------------- 1 | data Bool = False | True 2 | 3 | f x y z = x && y || z -------------------------------------------------------------------------------- /tests/make_from_c.sh: -------------------------------------------------------------------------------- 1 | ../alb -f main from_c.hb -o from_c.fidget -O2 \ 2 | --export=inc,inc --export=incPure,incPure --export=incArea,incArea --print-export-signatures && \ 3 | ../../../compcert1.11-hasp/ccomp -o from_c.out from_c.fidget from_c_driver.c habit_callbacks.c ../../../compcert1.11-hasp/runtime/gc/cheney.o 4 | -------------------------------------------------------------------------------- /tests/md5demo.hb: -------------------------------------------------------------------------------- 1 | requires md5 2 | requires miniprelude 3 | requires test 4 | requires ondeckprelude 5 | requires io 6 | 7 | main :: M Unsigned 8 | main = do 9 | x <- readInts 10 | case <- md5 x of 11 | MD5Digest (MD5Par a b c d) -> 12 | do putHexInt (fromBits (swapEndian a)) 13 | putchar 0x20 14 | putHexInt (fromBits (swapEndian b)) 15 | putchar 0x20 16 | putHexInt (fromBits (swapEndian c)) 17 | putchar 0x20 18 | putHexInt (fromBits (swapEndian d)) 19 | putchar 0x0A 20 | return (0 :: Unsigned) 21 | -------------------------------------------------------------------------------- /tests/md5driver.hb: -------------------------------------------------------------------------------- 1 | requires md5 2 | requires miniprelude 3 | requires test 4 | requires ondeckprelude 5 | 6 | dgst a b c d = MD5Digest (MD5Par (swapEndian a) (swapEndian b) (swapEndian c) (swapEndian d)) 7 | 8 | kat1 = do 9 | b <- md5 Nil 10 | return (b == dgst 0xd41d8cd9 0x8f00b204 0xe9800998 0xecf8427e) 11 | 12 | kat2 = do 13 | b <- md5 (Cons 97 Nil) 14 | return (b == dgst 0x332ce785 0xe973574a 0x1c5fdaf3 0xeee3f083) 15 | 16 | kat3 = do 17 | b <- md5 (Cons 0x50534148 Nil) -- "HASP" 18 | return (b == dgst 0xa1a2740e 0x202e3bad 0x0abe31f1 0x67cab851) 19 | 20 | main :: M Unsigned 21 | main = do 22 | x <- runTests 23 | (Cons kat1 24 | (Cons kat2 25 | (Cons kat3 26 | Nil))) 27 | return x 28 | -------------------------------------------------------------------------------- /tests/mem.hb: -------------------------------------------------------------------------------- 1 | requires prelude 2 | 3 | readRef = primReadRefStored 4 | writeRef = primWriteRefStored 5 | 6 | 7 | primitive primReadRefStored :: Ref (Stored a) -> M a 8 | primitive primWriteRefStored :: Ref (Stored a) -> a -> M () 9 | 10 | -- class MemMonad m | Monad m 11 | -- where memZero :: ARef l a -> m () 12 | -- memCopy :: ARef l a -> ARef l' a -> m () 13 | -- readRef :: ARef l a -> m (ValIn a) 14 | -- writeRef :: ARef l a -> ValIn a -> m () 15 | -- 16 | -- instance MemMonad M 17 | -- where memZero = primMemZero 18 | -- memCopy = primMemCopy 19 | -- readRef = primReadRef 20 | -- writeRef = primWriteRef 21 | -- 22 | -- primitive primMemZero :: ARef l a -> M () 23 | -- primitive primMemCopy :: ARef l a -> ARef l' a -> M () 24 | -- primitive primReadRef :: ARef l a -> M (ValIn a) 25 | -- primitive primWriteRef :: ARef l a -> ValIn a -> M () -------------------------------------------------------------------------------- /tests/monad.hb: -------------------------------------------------------------------------------- 1 | class Functor f 2 | where fmap :: (a -> b) -> f a -> f b 3 | 4 | class Monad m | Functor m 5 | where return :: a -> m a 6 | (>>=) :: m a -> (a -> m b) -> m b -------------------------------------------------------------------------------- /tests/ondeckprelude.hb: -------------------------------------------------------------------------------- 1 | -- A temporary place for things that might belong in the prelude 2 | 3 | requires prelude 4 | 5 | -- instance NoInit (Stored Unsigned) 6 | -- where noInit = primNoInitStored 7 | 8 | infixl 8 bitShiftL, bitShiftR 9 | 10 | class BitwiseShift a where 11 | bitShiftL :: a -> Ix (BitSize a) -> a 12 | bitShiftR :: a -> Ix (BitSize a) -> a 13 | 14 | instance BitwiseShift (Bit n) if Width n 15 | where bitShiftL x y = primBitShiftL x y 16 | bitShiftR x y = primBitShiftRu x y 17 | 18 | instance BitwiseShift Unsigned 19 | where bitShiftL x y = Unsigned [bits = bitShiftL x.bits y] 20 | bitShiftR x y = Unsigned [bits = bitShiftR x.bits y] 21 | 22 | instance BitwiseShift (Ix p) if Index p, 2^n = p 23 | where bitShiftL x y = primIxShiftL x y 24 | bitShiftR x y = primIxShiftR x y 25 | 26 | odd :: (BitManip t, BitSize t n, 0 < n) => t -> Bool 27 | odd x = testBit x 0 28 | 29 | even :: (BitManip t, BitSize t n, 0 < n) => t -> Bool 30 | even x = not (odd x) 31 | 32 | instance ToUnsigned Bool where 33 | unsigned True = 1 34 | unsigned False = 0 35 | 36 | -- This is useless until we support top-level non-functional decls 37 | instance Bounded Unsigned where 38 | minBound = 0 39 | maxBound = not minBound 40 | 41 | -- Haskell's (^) implementation, a direct rip-off 42 | -- see the Glasgow Haskell Compiler License (BSD style) 43 | (^) :: Unsigned -> Unsigned -> Unsigned 44 | x0 ^ y0 | y0 < 0 = 0 -- error "Negative exponent" 45 | | y0 == 0 = 1 46 | | True = f x0 y0 47 | where quot = div 48 | -- f : x0 ^ y0 = x ^ y 49 | f x y | even y = f (x * x) (y `quot` 2) 50 | | y == 1 = x 51 | | True = g (x * x) ((y - 1) `quot` 2) x 52 | -- g : x0 ^ y0 = (x ^ y) * z 53 | g x y z | even y = g (x * x) (y `quot` 2) z 54 | | y == 1 = x * z 55 | | True = g (x * x) ((y - 1) `quot` 2) (x * z) 56 | 57 | -- Some temporary functions while we lack NonZero. 58 | div :: Unsigned -> Unsigned -> Unsigned 59 | div x y 60 | | x < y = 0 61 | | True = f 0 y 62 | where 63 | f :: Unsigned -> Unsigned -> Unsigned 64 | f n k = if x < 2 * k || k >= maxK then bit (modIx n) + div (x - k) y 65 | else f (n + 1) (2 * k) 66 | where maxK :: Unsigned 67 | maxK = bit (bitSize k) 68 | 69 | rem :: Unsigned -> Unsigned -> Unsigned 70 | rem x y = x - (x `div` y) * y 71 | 72 | swapEndian :: (FromBits x, ToBits x, BitSize x 32) => x -> x 73 | swapEndian x = 74 | let a = toBits x 75 | b0 = (a .&. 0xFF) `bitShiftL` 24 76 | b1 = (a .&. 0xFF00) `bitShiftL` 8 77 | b2 = (a .&. 0xFF0000) `bitShiftR` 8 78 | b3 = (a .&. 0xFF000000) `bitShiftR` 24 79 | in fromBits (b0 .|. b1 .|. b2 .|. b3) 80 | -------------------------------------------------------------------------------- /tests/opaque/Divisor.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | 3 | class C t u | t -> u, opaque u 4 | where m :: t -> Maybe u 5 | n :: t -> u -> t 6 | 7 | instance C Unsigned Unsigned 8 | where m 0 = Nothing 9 | m x = Just x 10 | n x y = x * y 11 | 12 | f :: Unsigned -> Unsigned 13 | f x = case m x of 14 | Nothing -> x 15 | Just y -> n x y 16 | 17 | g :: C Unsigned Unsigned => Unsigned -> Unsigned 18 | g x = n x 0 19 | 20 | -- Error! 21 | -- g' :: Unsigned -> Unsigned 22 | -- g' x = n x 0 23 | 24 | h :: C Unsigned t => Unsigned -> Maybe t 25 | h x = m (x + 1) 26 | 27 | -- Error! 28 | -- h' :: Unsigned -> Maybe Unsigned 29 | -- h' x = m (x + 1) -------------------------------------------------------------------------------- /tests/opaque/Stack.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude, list 2 | 3 | opaque type Stack t = List t 4 | where new :: List t -> Stack t 5 | new xs = xs 6 | 7 | push :: t -> Stack t -> Stack t 8 | push x xs = Cons x xs 9 | 10 | pop :: Stack t -> Maybe (t, Stack t) 11 | pop Nil = Nothing 12 | pop (Cons x xs) = Just (x, xs) 13 | 14 | top :: Stack t -> Maybe t 15 | top Nil = Nothing 16 | top (Cons x xs) = Just x 17 | 18 | f :: Eq t => t -> List t -> Bool 19 | f x xs = 20 | case pop s of 21 | Nothing -> False 22 | Just (y, s') -> 23 | case top s' of 24 | Nothing -> False 25 | Just y' -> y == y' 26 | where s = push x (push x (new xs)) 27 | -------------------------------------------------------------------------------- /tests/opaque/Stack2.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude, list 2 | 3 | class Stack t = u | u -> t, opaque u 4 | where new :: List t -> u 5 | push :: t -> u -> u 6 | pop :: u -> Maybe (t, u) 7 | top :: u -> Maybe t 8 | 9 | instance Stack t (List t) 10 | where new xs = xs 11 | 12 | push x xs = Cons x xs 13 | 14 | pop Nil = Nothing 15 | pop (Cons x xs) = Just (x, xs) 16 | 17 | top Nil = Nothing 18 | top (Cons x _) = Just x 19 | 20 | f :: t -> t -> List t -> t 21 | f x y xs = case pop (push x (push x (new xs))) of 22 | Nothing -> y 23 | Just (_, s) -> 24 | case pop s of 25 | Nothing -> y 26 | Just (z, _) -> z 27 | 28 | 29 | g :: Eq t => t -> List t -> Bool 30 | g x xs = 31 | let s = push x (push x (new xs)) in 32 | case pop s of 33 | Nothing -> False 34 | Just (y, s') -> 35 | case top s' of 36 | Nothing -> False 37 | Just y' -> y == y' 38 | -------------------------------------------------------------------------------- /tests/overloaded.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | 3 | class C t 4 | where f :: t -> t 5 | 6 | g :: C t => t -> t 7 | g x = f (f x) 8 | 9 | h x = f (f x) 10 | 11 | j x = j (h x) 12 | j' x = h (j' x) 13 | 14 | k x = k (h (k x)) 15 | 16 | class F a b | a -> b 17 | where q :: a -> b 18 | 19 | primitive type (Int :: *) 20 | primitive type (Float :: *) 21 | primitive zero :: Float 22 | 23 | instance F Int Bool 24 | where q _ = True 25 | 26 | instance F Bool Float 27 | where q _ = zero 28 | 29 | r :: (F a b, F b c) => a -> c 30 | r x = q (q x) 31 | 32 | s x = q (q x) 33 | 34 | t :: Int -> Float 35 | t = s 36 | 37 | class D a 38 | where m :: C b => a -> b 39 | 40 | -------------------------------------------------------------------------------- /tests/patbind.hb: -------------------------------------------------------------------------------- 1 | data Pair x y = Pair x y 2 | 3 | Pair x y = Pair True False 4 | 5 | Pair f g | True = Pair (\x -> x) (\x -> True) 6 | 7 | -- w :: Unsigned 8 | -- Pair z w = Pair False 0 9 | 10 | -- Pair ff gg = Pair (\x y -> x == y) (\x y -> x < y) 11 | 12 | data DictEq t = DictEq (t -> t -> Bool) (t -> t -> Bool) 13 | DictEq fff ggg = DictEq ((==) :: Bool -> Bool -> Bool) (/=) 14 | 15 | 16 | 17 | 18 | 19 | main = fff True False && ggg False False 20 | 21 | -------------------------------------------------------------------------------- /tests/point.lhb: -------------------------------------------------------------------------------- 1 | > requires miniprelude 2 | 3 | Some simple examples: 4 | 5 | > struct Point [ x, y :: Stored Unsigned ] 6 | 7 | > area origin <- Point [ x <- 0 | y <- 0 ] :: Ref Point 8 | > area onetwo <- Point [ x <- 1 | y <- 2 ] :: Ref Point 9 | > area twoone <- myInit :: Ref Point 10 | > where myInit = initPoint 2 1 11 | 12 | > initPoint :: Unsigned -> Unsigned -> Init Point 13 | > initPoint u v = Point [ x <- initStored u | y <- initStored v ] 14 | 15 | > three = do p <- readRef twoone.x 16 | > return (p + 1) 17 | 18 | > main = do x <- readRef onetwo.x 19 | > y <- readRef onetwo.y 20 | > return (x + y) 21 | 22 | Some examples as tests of the mechanisms for computing area sizes: 23 | 24 | > {- 25 | > struct S0 [ x, y, z :: Stored Unsigned ] 26 | > struct S1/12 [ x, y, z :: Stored Unsigned ] 27 | > struct S2/(8+4) [ x, y, z :: Stored Unsigned ] 28 | > struct S3/(3*4) [ x, y, z :: Stored Unsigned ] 29 | > struct S4/((1+2)*(1+1+1+1)) 30 | > [ x, y, z :: Stored Unsigned ] 31 | > type SLength = 6 * 2 32 | > struct S5/SLength 33 | > [ x, y, z :: Stored Unsigned ] 34 | > -} 35 | -------------------------------------------------------------------------------- /tests/preltests.hb: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------- 2 | requires prelude 3 | 4 | -- Misc Test Code/Staging --------------------------------------- 5 | 6 | data Wrap a = MkWrap a 7 | deriving (Bounded, Num, Boolean, Ord, Eq) 8 | 9 | data Bar = A | B | C 10 | deriving Eq, Ord, Bounded 11 | 12 | data Foo = X Bar -- Bar 13 | deriving Bounded, Eq, Ord 14 | 15 | x = maxBound :: Foo 16 | 17 | instance Num Bar 18 | where x + y = A 19 | x - y = B 20 | x * y = C 21 | negate x = x 22 | 23 | data List a = Nil | Cons a (List a) 24 | deriving Eq, Ord 25 | 26 | data Quad a b c d = Quad a b c d 27 | deriving Eq, Ord, Bounded 28 | 29 | type Three = 3 30 | bitdata Test /Three = MkBits [ value :: Ix 6 ] 31 | deriving (ToBits) 32 | 33 | test :: Test -> Test 34 | test t = case incIx t.value of 35 | Nothing -> MkBits [value=0] 36 | Just i -> MkBits [value=i] 37 | 38 | ----------------------------------------------------------------- 39 | -------------------------------------------------------------------------------- /tests/primclass.hb: -------------------------------------------------------------------------------- 1 | primitive type Bit (n :: nat) 2 | primitive bits :: Bit n 3 | 4 | primitive class (+) (a :: nat) (b :: nat) (c :: nat) | a b -> c, a c -> b, b c -> a 5 | 6 | g :: Bit n -> Bit m -> Bit (n + m) 7 | g x y = bits 8 | 9 | q :: Bit 4 10 | q = bits 11 | 12 | r :: Bit 5 13 | r = bits 14 | 15 | s = g q r 16 | 17 | 18 | {- Things that should fail: 19 | 20 | data Maybe t = Just t | Nothing 21 | 22 | h :: Bit n -> Maybe n 23 | h x = h x 24 | 25 | instance Maybe m + Maybe n = Maybe (m + n) 26 | 27 | -} -------------------------------------------------------------------------------- /tests/primclass.lhb: -------------------------------------------------------------------------------- 1 | > primitive type Bit (n :: nat) 2 | > primitive bits :: Bit n 3 | 4 | > primitive class (+) (a :: nat) (b :: nat) (c :: nat) | a b -> c, a c -> b, b c -> a 5 | 6 | > g :: Bit n -> Bit m -> Bit (n + m) 7 | > g x y = bits 8 | 9 | > q :: Bit 4 10 | > q = bits 11 | 12 | > r :: Bit 5 13 | > r = bits 14 | 15 | > s = g q r 16 | 17 | Things that should fail: 18 | 19 | data Maybe t = Just t | Nothing 20 | 21 | h :: Bit n -> Maybe n 22 | h x = h x 23 | 24 | instance Maybe m + Maybe n = Maybe (m + n) 25 | -------------------------------------------------------------------------------- /tests/punning.lhb: -------------------------------------------------------------------------------- 1 | Basic tests for punning: 2 | 3 | > requires miniprelude 4 | 5 | > bitdata Byte = B [ val :: Bit 8 ] 6 | 7 | > f val = B [val] 8 | > g B[val] = val 9 | > h b = case b of 10 | > B[val] -> val 11 | 12 | > bitdata T = T [ x :: Bit 8 | yzt :: Byte3 ] 13 | > bitdata Byte3 = B3 [ y, z, t :: Byte ] 14 | 15 | > p B3[y|z|t] = B3 [t|z|y] 16 | > q x T[yzt] = T[x | yzt = p yzt] 17 | 18 | -------------------------------------------------------------------------------- /tests/qualicon/bogus.hb: -------------------------------------------------------------------------------- 1 | requires qprelude, ondeckprelude 2 | 3 | data T a = C Unsigned if a == Bool 4 | | D a 5 | 6 | -- f :: T a -> Bool -> Bool 7 | f (C n) r = n > 0 8 | f (D _) r = pmNot r 9 | 10 | g :: T a -> a -> a 11 | g (C n) r = n > 0 12 | g (D _) r = r -------------------------------------------------------------------------------- /tests/qualicon/escape.hb: -------------------------------------------------------------------------------- 1 | requires qprelude 2 | 3 | class F (a :: *) (b :: *) | a -> b 4 | 5 | data T a = MkT b if F a b 6 | 7 | f :: T a -> T a 8 | f (MkT b) = MkT b 9 | 10 | g :: (F a b, F a' b) => T a -> T a' 11 | g (MkT b) = MkT b 12 | 13 | -- These should not typecheck: 14 | -- 15 | -- h :: F a' b => T a -> T a' 16 | -- h (MkT b) = MkT b 17 | -- 18 | -- j :: T a -> T a' 19 | -- j (MkT b) = MkT b 20 | 21 | -- Neither should these 22 | -- 23 | -- data U (a :: *) = C Bool 24 | -- | D b 25 | -- 26 | -- bitdata B = B [ x :: t ] 27 | 28 | data Equ a b = Refl if a == b 29 | 30 | h z x y = 31 | j z x y 32 | (case z of 33 | Refl -> x < y) 34 | 35 | j :: Equ a b -> a -> b -> c -> c 36 | j x y z w = w -------------------------------------------------------------------------------- /tests/qualicon/expr.hb: -------------------------------------------------------------------------------- 1 | requires qprelude 2 | 3 | 4 | data Expr t = IntConst Unsigned if t == Unsigned 5 | | IsZero (Expr Unsigned) if t == Bool 6 | | Sum (Expr Unsigned) (Expr Unsigned) if t == Unsigned 7 | | BoolConst Bool if t == Bool 8 | | And (Expr Bool) (Expr Bool) if t == Bool 9 | | If (Expr Bool) (Expr t) (Expr t) 10 | | Pair (Expr u) (Expr u') if t == (u,u') 11 | 12 | -- These next two lines require existentials 13 | -- | Fst (Expr (u, u')) if t == u 14 | -- | Snd (Expr (u, u')) if t == u' 15 | 16 | 17 | c0 = IntConst 0 18 | c1 = IntConst 1 19 | 20 | e0 = If (IsZero c0) c0 c1 21 | e1 = If (IsZero c1) c0 c1 22 | e2 = If (And (IsZero c0) (IsZero c1)) c0 (Sum c0 c1) 23 | e3 = Pair c0 (IsZero c0) 24 | e4 x = Sum c0 x 25 | e5 x = Pair c0 x 26 | 27 | -- b0 = If c0 c0 c1 28 | -- b1 = Sum (And (IsZero c0) (IsZero c1)) c1 29 | -- b2 = And (Sum c0 c1) (BoolConst True) 30 | 31 | eval :: Expr t -> t 32 | eval (IntConst u) = u 33 | eval (IsZero e) = eval e == 0 34 | eval (Sum e e') = eval e + eval e' 35 | eval (BoolConst b) = b 36 | eval (If e e' e'') = if eval e then eval e' else eval e'' 37 | eval (Pair e e') = (eval e, eval e') 38 | 39 | -- As above 40 | -- eval (Fst e) = fst (eval e) 41 | -- eval (Snd e) = snd (eval e) 42 | 43 | x0 = eval e0 44 | x1 = eval e1 45 | x2 = eval e2 46 | x3 = eval e3 47 | 48 | test = (e0, e1, e2, e3, e4 e0, e5 e1, 49 | x0, x1, x2, x3) 50 | 51 | -------------------------------------------------------------------------------- /tests/qualicon/qprelude.hb: -------------------------------------------------------------------------------- 1 | requires prelude 2 | 3 | class (t :: *) == (u :: *) | t -> u, u -> t 4 | instance t == t 5 | -------------------------------------------------------------------------------- /tests/qualicon/set.hb: -------------------------------------------------------------------------------- 1 | requires qprelude 2 | requires ondeckprelude 3 | 4 | data Set t = Empty if Ord t 5 | | Branch t (Set t) (Set t) if Ord t 6 | 7 | m0, m1 :: Set Unsigned 8 | m0 = Empty 9 | m1 = Branch 5 (Branch 1 Empty Empty) (Branch 8 (Branch 6 Empty Empty) (Branch 10 Empty Empty)) 10 | 11 | -- data UnOrdered = T | U 12 | -- 13 | -- m2 :: Set UnOrdered 14 | -- m2 = Branch T (Branch U Empty Empty) Empty 15 | 16 | insert :: t -> Set t -> Set t 17 | insert t Empty = Branch t Empty Empty 18 | insert t (Branch t' left right) | t < t' = Branch t' (insert t left) right 19 | | True = Branch t' left (insert t right) 20 | 21 | elem :: t -> Set t -> Bool 22 | elem t Empty = False 23 | elem t (Branch t' left right) | t == t' = True 24 | | t < t' = elem t left 25 | | True = elem t right 26 | 27 | x = elem 4 (insert 6 m1) -------------------------------------------------------------------------------- /tests/qualicon/syn.hb: -------------------------------------------------------------------------------- 1 | requires qprelude 2 | 3 | type HWord = Bit 16 4 | type Word = Bit 32 5 | 6 | primitive (:#) :: Bit m -> Bit n -> Bit (m + n) 7 | 8 | padHigh :: HWord -> Word 9 | padHigh low = 0 :# low 10 | 11 | padLow :: HWord -> Word 12 | padLow high = high :# 0 13 | 14 | data Foo = Foo HWord HWord 15 | 16 | build :: Foo -> Word 17 | build (Foo high low) = high :# low 18 | 19 | getHigh (Foo high _) = high 20 | getLow (Foo _ low) = low 21 | 22 | getHigh' :: Foo -> HWord 23 | getHigh' (Foo high _) = high 24 | 25 | bitdata FooB = FooB [ low = 0, high :: HWord ] 26 | 27 | buildb :: FooB -> Word 28 | buildb (FooB r) = r.high :# r.low 29 | 30 | getHighb (FooB r) = r.high 31 | getLowb (FooB r) = r.low 32 | 33 | getHighb' :: FooB -> HWord 34 | getHighb' (FooB r) = r.high 35 | 36 | struct FooS [ low <- 0, high :: Stored HWord ] 37 | 38 | getHighS r = readRef (r.low) 39 | 40 | getHighS' :: Ref FooS -> M HWord 41 | getHighS' r = readRef (r.low) -------------------------------------------------------------------------------- /tests/repeatedType.hb: -------------------------------------------------------------------------------- 1 | data List t = Nil | Cons t (List t) 2 | data List t = Null | InsertHead t (List t) -------------------------------------------------------------------------------- /tests/requirements.hb: -------------------------------------------------------------------------------- 1 | requires prelude 2 | requires test 3 | 4 | -- Transitive closure of a class: 5 | class To t u 6 | where to :: t -> u 7 | 8 | require To t v if To t u, To u v 9 | 10 | instance To Unsigned (Bit 32) 11 | where to x = x.bits 12 | 13 | instance To Bool Unsigned 14 | where to True = 1 15 | to False = 0 16 | 17 | -- To test: comment out the following instance. Should fail to compile 18 | instance To Bool (Bit 32) 19 | where to True = 0b1 20 | to False = 0b0 21 | 22 | -- Divisor-like class. Missing a few operations 23 | class DivisorLike t u | t -> u 24 | 25 | require NumLit n u if NumLit n t, DivisorLike t u, 0 < n 26 | 27 | -- Fake a non-zero type 28 | data NZU = NZU Unsigned 29 | 30 | instance DivisorLike Unsigned NZU 31 | 32 | -- To test: comment out the following instance. Should fail to compile: 33 | instance NumLit n NZU if NumLit n Unsigned, 0 < n 34 | where fromLiteral x = NZU (fromLiteral x) 35 | 36 | -- Requirements don't have to be for predicates of the form C vs: 37 | 38 | class C t 39 | where foo :: t -> Unsigned 40 | class D t 41 | where bar :: t -> Unsigned 42 | 43 | require D t if C (Maybe t) 44 | 45 | instance C Unsigned 46 | where foo x = x 47 | 48 | instance C (Maybe Bool) 49 | where foo _ = 1 50 | -- To test: comment out the following instance. 51 | instance D Bool 52 | where bar x = foo (Just x) 53 | 54 | f :: C (Maybe t) => t -> Unsigned 55 | f x = bar x + foo (Just x) 56 | 57 | main = do x <- runTests (Cons (return (f True == 2)) Nil) 58 | return x -------------------------------------------------------------------------------- /tests/simpleClass.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | 3 | class C (a :: type) where 4 | c :: a -> a 5 | 6 | class M0 (m :: type -> type) where 7 | m0 :: a -> m a 8 | 9 | class M1 (m :: type -> *) where 10 | m1 :: a -> m a 11 | 12 | class M2 (m :: * -> type) where 13 | m2 :: a -> m a 14 | 15 | class M3 (m :: * -> *) where 16 | m3 :: a -> m a 17 | 18 | -------------------------------------------------------------------------------- /tests/solver/results/2: -------------------------------------------------------------------------------- 1 | [Integral Int] : Yes 2 | [Fractional Int] : [Fractional Int] remaining. 3 | [Integral Float] : No 4 | [Eq Int] : Yes 5 | [Eq (List Int)] : Yes 6 | [Eq (List (List Int))] : Yes 7 | [Eq (Fun a b)] : No 8 | [Eq (List (List (Fun a b)))] : [Eq (List (List (Fun a b)))] remaining. 9 | [Eq (List (List Bool))] : [Eq (List (List Bool))] remaining. 10 | -------------------------------------------------------------------------------- /tests/solver/results/2-p: -------------------------------------------------------------------------------- 1 | [Integral Int] : Yes [$a:integral_int!0{}()] 2 | [Fractional Int] : [$a:Fractional Int] remaining. [] 3 | [Integral Float] : No 4 | [Eq Int] : Yes [$a:eq_int!0{}()] 5 | [Eq (List Int)] : Yes [$a:eq_int!1{Int}(g$7:eq_int!0{}())] 6 | [Eq (List (List Int))] : Yes [$a:eq_int!1{List Int}(g$7:eq_int!1{Int}(g$e:eq_int!0{}()))] 7 | [Eq (Fun a b)] : No 8 | [Eq (List (List (Fun a b)))] : [$a:Eq (List (List (Fun a b)))] remaining. [] 9 | [Eq (List (List Bool))] : [$a:Eq (List (List Bool))] remaining. [] 10 | -------------------------------------------------------------------------------- /tests/solver/results/3: -------------------------------------------------------------------------------- 1 | [F Int Int] : Yes 2 | [F Int Bool] : No 3 | [C x y z] : Yes 4 | -------------------------------------------------------------------------------- /tests/solver/results/3-p: -------------------------------------------------------------------------------- 1 | [F Int Int] : Yes [$a:f_t_t!0{Int}()] 2 | [F Int Bool] : No 3 | [C x y z] : Yes [$a:cases {[x :-> y] -> [z :-> True] c_t_t_true!0{x}(); [] -> [z :-> False] c_t_t_true!1{x, y}()}] 4 | -------------------------------------------------------------------------------- /tests/solver/results/5: -------------------------------------------------------------------------------- 1 | [F Int Bool] : Yes 2 | [F Int t] : Yes (improved to [F Int Bool]) 3 | [F Float Int] : Yes 4 | [F Float t] : Yes (improved to [F Float Int]) 5 | [F Float Bool] : No 6 | [F Float Bool fails] : Yes 7 | -------------------------------------------------------------------------------- /tests/solver/results/5-p: -------------------------------------------------------------------------------- 1 | [F Int Bool] : Yes [$a:f_int_bool{}()] 2 | [F Int t] : Yes [$a:f_int_bool{}()] (improved to [F Int Bool]) 3 | [F Float Int] : Yes [$a:f_t_int_if_c_t{Float}(g$3:c_float{}())] 4 | [F Float t] : Yes [$a:f_t_int_if_c_t{Float}(g$3:c_float{}())] (improved to [F Float Int]) 5 | [F Float Bool] : No 6 | [F Float Bool fails] : Yes [$a:f_t_int_if_c_t{Float}(g$2:c_float{}())] 7 | -------------------------------------------------------------------------------- /tests/solver/results/6: -------------------------------------------------------------------------------- 1 | [F Int t] : Yes (improved to [F Int Bool]) 2 | [G Int Float fails] : Yes 3 | -------------------------------------------------------------------------------- /tests/solver/results/6-p: -------------------------------------------------------------------------------- 1 | [F Int t] : Yes [$a:f_t_u_if_c_t_u{Int, t$4}(g$5:c_int_bool{}())] (improved to [F Int Bool]) 2 | [G Int Float fails] : Yes [$a:g_int_bool_fails!1{}()] 3 | -------------------------------------------------------------------------------- /tests/solver/results/8: -------------------------------------------------------------------------------- 1 | [Eq T T] : Yes 2 | [Eq T U] : No 3 | [Eq T t] : Yes (improved to [Eq T T]) 4 | [Eq t T] : Yes (improved to [Eq T T]) 5 | [Eq t u] : Yes (improved to [Eq u u]) 6 | [Eq t u] if Eq u t : Yes (improved to [Eq t t] if Eq t t) 7 | [Eq t v] if Eq t u, Eq u v : Yes (improved to [Eq v v] if Eq v v, Eq v v) 8 | [C t u v] if Eq t u : Yes (improved to [C u u True] if Eq u u) 9 | -------------------------------------------------------------------------------- /tests/solver/results/8-p: -------------------------------------------------------------------------------- 1 | [Eq T T] : Yes [$a:eq_t_t{T}()] 2 | [Eq T U] : No 3 | [Eq T t] : Yes [$a:eq_t_t{T}()] (improved to [Eq T T]) 4 | [Eq t T] : Yes [$a:eq_t_t{T}()] (improved to [Eq T T]) 5 | [Eq t u] : Yes [$a:eq_t_t{u}()] (improved to [Eq u u]) 6 | [Eq t u] if Eq u t : Yes [$b:assumption($a)] (improved to [Eq t t] if Eq t t) 7 | [Eq t v] if Eq t u, Eq u v : Yes [$c:assumption($b)] (improved to [Eq v v] if Eq v v, Eq v v) 8 | [C t u v] if Eq t u : Yes [$b:c_t_t_true!0{u}()] (improved to [C u u True] if Eq u u) 9 | -------------------------------------------------------------------------------- /tests/solver/results/9: -------------------------------------------------------------------------------- 1 | [C U] : Yes 2 | [C t, == t U] : Yes (improved to [C U, == U U]) 3 | [== t U, C t] : Yes (improved to [== U U, C U]) 4 | [C1 t, == t (Maybe T)] : Yes (improved to [C1 (Maybe T), == (Maybe T) (Maybe T)]) 5 | -------------------------------------------------------------------------------- /tests/solver/results/9-p: -------------------------------------------------------------------------------- 1 | [C U] : Yes [$a:c_t_if_d_t!2{}[0:g$5:d_u_fails{}()]()] 2 | [C t, == t U] : Yes [$a:c_t_if_d_t!2{}[0:g$7:d_u_fails{}()](), $b:==_t_t{U}()] (improved to [C U, == U U]) 3 | [== t U, C t] : Yes [$a:==_t_t{U}(), $b:c_t_if_d_t!2{}[0:g$7:d_u_fails{}()]()] (improved to [== U U, C U]) 4 | [C1 t, == t (Maybe T)] : Yes [$a:c1_t!0{t}(), $b:==_t_t{Maybe T}()] (improved to [C1 (Maybe T), == (Maybe T) (Maybe T)]) 5 | -------------------------------------------------------------------------------- /tests/solver/results/assumption-cases: -------------------------------------------------------------------------------- 1 | [C t] : [D t] remaining. 2 | [C t, E t] : [D t] remaining. 3 | [E t] if C t : Yes 4 | [F t u, D t, D u] : [D u] remaining. (improved to [F u u, D u, D u]) 5 | [D t, D u] if F t u : Yes (improved to [D u, D u] if F u u) 6 | [D t, D u] if G t u True : Yes (improved to [D t, D t] if G t t True) 7 | [D t, D u] if G t u False : [D t, D u] remaining. 8 | [+ x y 32] if <= x 32 : Yes 9 | -------------------------------------------------------------------------------- /tests/solver/results/assumption-cases-p: -------------------------------------------------------------------------------- 1 | [C t] : [g$5:D t] remaining. [c_t_if_d_t!0{t}(g$5:assumption(g$5))] 2 | [C t, E t] : [g$7:D t] remaining. [c_t_if_d_t!0{t}(g$7:assumption(g$7)), $b:e_t_if_d_t{t}(g$8:assumption(g$7))] 3 | [E t] if C t : Yes [$b:e_t_if_d_t{t}((c_t_if_d_t!0{t}(x0) <- _:assumption($a)) => g$7:assumption(x0))] 4 | [F t u, D t, D u] : [$b:D u] remaining. [$a:f_t_t_if_d_t!0{u}(g$7:assumption($c)), $c:assumption($b)] (improved to [F u u, D u, D u]) 5 | [D t, D u] if F t u : Yes [(f_t_t_if_d_t!0{t}(x0) <- _:assumption($a)) => $b:assumption(x0), (f_t_t_if_d_t!0{t}(x0) <- _:assumption($a)) => $c:assumption(x0)] (improved to [D u, D u] if F u u) 6 | [D t, D u] if G t u True : Yes [(g_t_t_true_if_d_t!0{t}(x0) <- _:assumption($a)) => $b:assumption(x0), (g_t_t_true_if_d_t!0{t}(x0) <- _:assumption($a)) => $c:assumption(x0)] (improved to [D t, D t] if G t t True) 7 | [D t, D u] if G t u False : [$b:D t, $c:D u] remaining. [] 8 | [+ x y 32] if <= x 32 : Yes [$b:computed{x}] 9 | -------------------------------------------------------------------------------- /tests/solver/results/cases: -------------------------------------------------------------------------------- 1 | [C (Maybe Int)] : Yes 2 | [C Int] : Yes 3 | [C t] : Yes 4 | -------------------------------------------------------------------------------- /tests/solver/results/cases-p: -------------------------------------------------------------------------------- 1 | [C (Maybe Int)] : Yes [$a:c_int!1{Maybe Int}()] 2 | [C Int] : Yes [$a:c_int!0{}()] 3 | [C t] : Yes [$a:cases {[t :-> Int] -> [] c_int!0{}(); [] -> [] c_int!1{t}()}] 4 | -------------------------------------------------------------------------------- /tests/solver/results/cases2: -------------------------------------------------------------------------------- 1 | [C Int] : Yes 2 | [C Bool] : Yes 3 | [C t] : [C t] remaining. 4 | -------------------------------------------------------------------------------- /tests/solver/results/cases2-p: -------------------------------------------------------------------------------- 1 | [C Int] : Yes [$a:c_int!0{}()] 2 | [C Bool] : Yes [$a:c_int!1{Bool}(g$8:d_bool{}())] 3 | [C t] : [$a:C t] remaining. [] 4 | -------------------------------------------------------------------------------- /tests/solver/results/cyclic1: -------------------------------------------------------------------------------- 1 | [@ e$5j8y (Expr e$5j8y), :-: e$5j8y Const h$5j8z, @ h$5j8z (Expr e$5j8y), :-: e$5j95 Double e$5j8y, ExprFour (Expr e$5j95)] : Yes (improved to [@ (:+: Const (:+: Sum Product)) (Expr (:+: Const (:+: Sum Product))), :-: (:+: Const (:+: Sum Product)) Const (:+: Sum Product), @ (:+: Sum Product) (Expr (:+: Const (:+: Sum Product))), :-: (:+: Const (:+: Sum (:+: Product Double))) Double (:+: Const (:+: Sum Product)), ExprFour (Expr (:+: Const (:+: Sum (:+: Product Double))))]) 2 | -------------------------------------------------------------------------------- /tests/solver/results/cyclic1-p: -------------------------------------------------------------------------------- 1 | ___+__a_b_c_requires___b_c: 2 | (___+__a_c_b_if___a_b____c_b!0{t$cc, t$cd, t$ce}(g1, g2)) -> ___+__a_b_c_requires___b_c:assumption(g2) 3 | ___+__a_b_c_requires___a_c: 4 | (___+__a_c_b_if___a_b____c_b!0{t$cc, t$cd, t$ce}(g1, g2)) -> ___+__a_b_c_requires___a_c:assumption(g1) 5 | __expr_a_requires___a_expr_a: 6 | (__expr_a_if___a_expr_a!0{t$cu}(g1)) -> __expr_a_requires___a_expr_a:assumption(g1) 7 | [@ e$5j8y (Expr e$5j8y), :-: e$5j8y Const h$5j8z, @ h$5j8z (Expr e$5j8y), :-: e$5j95 Double e$5j8y, ExprFour (Expr e$5j95)] : Yes [$a:___+__a_c_b_if___a_b____c_b!0{Const, Expr (:+: Const (:+: Sum Product)), :+: Sum Product}(g$pa:__const_a{Expr (:+: Const (:+: Sum Product))}(), g$pb:assumption($c)), $b:_____+__a_b_a_b_if____+__a_b_____+__a!0{Const, :+: Sum Product}(g$ru:assumption(g$c0), g$rv:assumption(g$22)), $c:___+__a_c_b_if___a_b____c_b!0{Sum, Expr (:+: Const (:+: Sum Product)), Product}(g$sb:__sum_a{Expr (:+: Const (:+: Sum Product))}(), g$sc:__product_a{Expr (:+: Const (:+: Sum Product))}()), $d:_____+__a_b_a_b_if____+__a_b_____+__a!3{Double, Const, :+: Sum (:+: Product Double), t$20}[0:g$3t:in_a_a!2{Double, :+: Product Double, Sum}[0:g$68:in_a_a!3{Double, Sum}()](g$6t:in_a_a!2{Double, Double, Product}[0:g$92:in_a_a!3{Double, Product}()](g$9n:in_a_a!0{Double}(), g$9o:___+__a_b{Product, Double}(), g$9p:___+__a{Product}()), g$6u:___+__a_b{Sum, :+: Product Double}(), g$6v:___+__a{Sum}())](g$bw:in_a_a!3{Double, Const}(), g$bx:_____+__a_b_a_b_if____+__a_b_____+__a!3{Double, Sum, :+: Product Double, t$cy}[0:g$fl:in_a_a!2{Double, Double, Product}[0:g$i0:in_a_a!3{Double, Product}()](g$il:in_a_a!0{Double}(), g$im:___+__a_b{Product, Double}(), g$in:___+__a{Product}())](g$ku:in_a_a!3{Double, Sum}(), g$kv:_____+__a_b_a_b_if____+__a_b_____+__a!1{Product, Double}(g$oh:assumption(g$mr), g$oi:assumption(g$ms)), g$kw:assumption(g$dt), g$kx:assumption(g$du), g$ky:___+__a_b{Sum, t$cy}(), g$kz:assumption(g$du)), g$by:assumption(g$21), g$bz:assumption(g$22), g$c0:___+__a_b{Const, t$20}(), g$c1:assumption(g$22)), $e:exprfour_expr__+__const__+__sum__+__product_double!0{}()] (improved to [@ (:+: Const (:+: Sum Product)) (Expr (:+: Const (:+: Sum Product))), :-: (:+: Const (:+: Sum Product)) Const (:+: Sum Product), @ (:+: Sum Product) (Expr (:+: Const (:+: Sum Product))), :-: (:+: Const (:+: Sum (:+: Product Double))) Double (:+: Const (:+: Sum Product)), ExprFour (Expr (:+: Const (:+: Sum (:+: Product Double))))]) 8 | -------------------------------------------------------------------------------- /tests/solver/results/dtac: -------------------------------------------------------------------------------- 1 | [In Int Int] : Yes 2 | [In Int (Plus Int Bool)] : Yes 3 | [In Char (Plus Int Bool)] : No 4 | [In Int (Plus Int (Plus Int Bool))] : Yes 5 | [In Int (Plus x (Plus Int Bool))] : [In Int (Plus x (Plus Int Bool))] remaining. 6 | [In Int (Plus Int (Plus Int Int))] : Yes 7 | [In Bool (Plus Int (Plus Int Bool))] : Yes 8 | [In Int (Plus (Plus Int Bool) (Plus Char Expr))] : Yes 9 | [UniqueIn Int Int] : Yes 10 | [UniqueIn Int (Plus Int Bool)] : Yes 11 | [UniqueIn Char (Plus Int Bool)] : No 12 | [UniqueIn Int (Plus Int (Plus Int Bool))] : No 13 | [UniqueIn Int (Plus Int (Plus Int Int))] : No 14 | [UniqueIn Int (Plus x (Plus Int Bool))] : [In Int x fails] remaining. 15 | [UniqueIn Int (Plus (Plus Int Int) Int)] : No 16 | [UniqueIn Int (Plus (Plus Int Int) (Plus Int Int))] : No 17 | [UniqueIn Bool (Plus Int (Plus Int Bool))] : Yes 18 | [UniqueIn Int (Plus (Plus Int Bool) (Plus Char Expr))] : Yes 19 | [Without Int Int t] : No 20 | [Without Int Bool t] : Yes (improved to [Without Int Bool Int]) 21 | [Without (Plus Int Bool) Int t] : Yes (improved to [Without (Plus Int Bool) Int Bool]) 22 | [Without (Plus Int Bool) Bool t] : Yes (improved to [Without (Plus Int Bool) Bool Int]) 23 | [Without (Plus (Plus Int Bool) (Plus Char Float)) Int t] : Yes (improved to [Without (Plus (Plus Int Bool) (Plus Char Float)) Int (Plus Bool (Plus Char Float))]) 24 | [Without (Plus (Plus Int Bool) (Plus Char Float)) (Plus Int Bool) t] : Yes (improved to [Without (Plus (Plus Int Bool) (Plus Char Float)) (Plus Int Bool) (Plus Char Float)]) 25 | -------------------------------------------------------------------------------- /tests/solver/results/fd2: -------------------------------------------------------------------------------- 1 | [J P4 P2] : Yes 2 | [J P4 P1] : No 3 | [J P4 t] : Yes (improved to [J P4 P2]) 4 | [J P6 P3] : No 5 | [J P6 P1] : Yes 6 | [J P6 t] : Yes (improved to [J P6 P1]) 7 | -------------------------------------------------------------------------------- /tests/solver/results/fd2-p: -------------------------------------------------------------------------------- 1 | [J P4 P2] : Yes [$a:j_m_n_if_double_n_m__even_n{t$7, P4}(g$3z:double_m_n_if_mult_p2_m_n{t$7, P4}(g$49:mult_x_p0_p0!1{P2, t$4k, t$4l, P4}(g$4t:mult_x_p0_p0!1{P2, t$55, t$56, t$4l}(g$5l:mult_x_p0_p0!0{P2}(), g$5m:add_p0_p0_p0!2{P2}()), g$4u:add_p0_p0_p0!3{P1, t$5j, P2}(g$60:add_p0_p0_p0!3{P0, t$69, P0}(g$6b:add_p0_p0_p0!0{}())))), g$40:even_p0!1{t$47}(g$4q:even_p0!0{}()))] 2 | [J P4 P1] : No 3 | [J P4 t] : Yes [$a:j_m_n_if_double_n_m__even_n{t$7, P4}(g$3z:double_m_n_if_mult_p2_m_n{t$7, P4}(g$49:mult_x_p0_p0!1{P2, t$4k, t$4l, P4}(g$4t:mult_x_p0_p0!1{P2, t$55, t$56, t$4l}(g$5l:mult_x_p0_p0!0{P2}(), g$5m:add_p0_p0_p0!2{P2}()), g$4u:add_p0_p0_p0!3{P1, t$5j, P2}(g$60:add_p0_p0_p0!3{P0, t$69, P0}(g$6b:add_p0_p0_p0!0{}())))), g$40:even_p0!1{t$47}(g$4q:even_p0!0{}()))] (improved to [J P4 P2]) 4 | [J P6 P3] : No 5 | [J P6 P1] : Yes [$a:j_m_p1_if_double_n_m__even_n_fails{t$5, P6}(g$9:double_m_n_if_mult_p2_m_n{t$5, P6}(g$h:mult_x_p0_p0!1{P2, t$s, t$t, P6}(g$13:mult_x_p0_p0!1{P2, t$1f, t$1g, t$t}(g$1y:mult_x_p0_p0!1{P2, t$31, t$32, t$1g}(g$3c:mult_x_p0_p0!0{P2}(), g$3d:add_p0_p0_p0!2{P2}()), g$1z:add_p0_p0_p0!3{P1, t$3a, P2}(g$3r:add_p0_p0_p0!3{P0, t$40, P0}(g$42:add_p0_p0_p0!0{}()))), g$14:add_p0_p0_p0!3{P1, t$1t, P4}(g$2d:add_p0_p0_p0!3{P0, t$2m, P2}(g$2o:add_p0_p0_p0!1{P2}())))), g$a:even_p0!2{t$5}[0:g$y:even_p0!2{t$f}()]())] 6 | [J P6 t] : Yes [$a:j_m_p1_if_double_n_m__even_n_fails{t$5, P6}(g$9:double_m_n_if_mult_p2_m_n{t$5, P6}(g$h:mult_x_p0_p0!1{P2, t$s, t$t, P6}(g$13:mult_x_p0_p0!1{P2, t$1f, t$1g, t$t}(g$1y:mult_x_p0_p0!1{P2, t$31, t$32, t$1g}(g$3c:mult_x_p0_p0!0{P2}(), g$3d:add_p0_p0_p0!2{P2}()), g$1z:add_p0_p0_p0!3{P1, t$3a, P2}(g$3r:add_p0_p0_p0!3{P0, t$40, P0}(g$42:add_p0_p0_p0!0{}()))), g$14:add_p0_p0_p0!3{P1, t$1t, P4}(g$2d:add_p0_p0_p0!3{P0, t$2m, P2}(g$2o:add_p0_p0_p0!1{P2}())))), g$a:even_p0!2{t$5}[0:g$y:even_p0!2{t$f}()]())] (improved to [J P6 P1]) 7 | -------------------------------------------------------------------------------- /tests/solver/results/fd3: -------------------------------------------------------------------------------- 1 | Overlapping instances: forall k, k, k. H (List _2) _0 P1 if Double _0 _1, Eq _2 2 | overlaps with forall k, k, k. H (Maybe _2) _0 _1 if Double _0 _1, Even _1, Ord _2 3 | -------------------------------------------------------------------------------- /tests/solver/results/fd3-p: -------------------------------------------------------------------------------- 1 | Overlapping instances: forall k, k, k. H (List _2) _0 P1 if Double _0 _1, Eq _2 2 | overlaps with forall k, k, k. H (Maybe _2) _0 _1 if Double _0 _1, Even _1, Ord _2 3 | -------------------------------------------------------------------------------- /tests/solver/results/fd3a: -------------------------------------------------------------------------------- 1 | Overlapping instances: forall k, k. F _1 P1 if Double _0 _1 2 | overlaps with forall k, k. F _1 _0 if Double _0 _1, Even _0 3 | -------------------------------------------------------------------------------- /tests/solver/results/fd3b: -------------------------------------------------------------------------------- 1 | Overlapping instances: forall k, k. G Float _0 P1 if Double _0 _1 2 | overlaps with forall k, k. G Int _0 _1 if Double _0 _1, Even _1 3 | -------------------------------------------------------------------------------- /tests/solver/results/fd3c: -------------------------------------------------------------------------------- 1 | Overlapping instances: forall k, k, k. H (List _2) _0 P1 if Double _0 _1, Eq _2 2 | overlaps with forall k, k, k. H (Maybe _2) _0 _1 if Double _0 _1, Even _1, Ord _2 3 | -------------------------------------------------------------------------------- /tests/solver/results/fd4: -------------------------------------------------------------------------------- 1 | [C T u] : Yes (improved to [C T U]) 2 | [C t U] : Yes (improved to [C T U]) 3 | [C U U] : No 4 | -------------------------------------------------------------------------------- /tests/solver/results/fd4-p: -------------------------------------------------------------------------------- 1 | [C T u] : Yes [$a:c_t_u{}()] (improved to [C T U]) 2 | [C t U] : Yes [$a:c_t_u{}()] (improved to [C T U]) 3 | [C U U] : No 4 | -------------------------------------------------------------------------------- /tests/solver/results/generic: -------------------------------------------------------------------------------- 1 | [C Int Bool] : Yes 2 | [C Int Float] : Yes 3 | [C Int t] : [C Int t] remaining. 4 | [C Int t, C Int u] : [C Int t, C Int u] remaining. 5 | -------------------------------------------------------------------------------- /tests/solver/results/generic-p: -------------------------------------------------------------------------------- 1 | [C Int Bool] : Yes [$a:c_t_u_if_f_t_u{Int, Bool}(g$b:f_int_bool{}())] 2 | [C Int Float] : Yes [$a:c_t_u_if_f_t_u_fails__g_t_u{Int, Float}(g$9:f_int_bool{}(), g$a:g_int_float{}())] 3 | [C Int t] : [$a:C Int t] remaining. [] 4 | [C Int t, C Int u] : [$a:C Int t, $b:C Int u] remaining. [] 5 | -------------------------------------------------------------------------------- /tests/solver/results/generic2: -------------------------------------------------------------------------------- 1 | [F t u, MEq (Maybe Int) u] : Yes (improved to [F Int (Maybe Int), MEq (Maybe Int) (Maybe Int)]) 2 | -------------------------------------------------------------------------------- /tests/solver/results/generic2-p: -------------------------------------------------------------------------------- 1 | [F t u, MEq (Maybe Int) u] : Yes [$a:f_t_maybe_t{t}(), $b:meq_t_t{Maybe Int}()] (improved to [F Int (Maybe Int), MEq (Maybe Int) (Maybe Int)]) 2 | -------------------------------------------------------------------------------- /tests/solver/results/hlist: -------------------------------------------------------------------------------- 1 | [One Int (C Int Nil)] : Yes 2 | [One Int (C Int (C Bool Nil))] : Yes 3 | [One Int (C Bool (C Int Nil))] : Yes 4 | [One Int (C Bool Nil)] : No 5 | [One Int (C Int (C Int Nil))] : No 6 | [One Int (C x (C Int Nil))] : [One Int (C x (C Int Nil))] remaining. 7 | [One Int (C Int Int)] : No 8 | [One Int (C Bool Int)] : No 9 | -------------------------------------------------------------------------------- /tests/solver/results/hlist-p: -------------------------------------------------------------------------------- 1 | [One Int (C Int Nil)] : Yes [$a:one!0{Int, Nil}(g$j:none!0{Int}())] 2 | [One Int (C Int (C Bool Nil))] : Yes [$a:one!0{Int, C Bool Nil}(g$j:none!2{Int, Nil, Bool}(g$10:none!0{Int}()))] 3 | [One Int (C Bool (C Int Nil))] : Yes [$a:one!2{Int, C Int Nil, Bool}(g$j:one!0{Int, Nil}(g$12:none!0{Int}()))] 4 | [One Int (C Bool Nil)] : No 5 | [One Int (C Int (C Int Nil))] : No 6 | [One Int (C x (C Int Nil))] : [$a:One Int (C x (C Int Nil))] remaining. [] 7 | [One Int (C Int Int)] : No 8 | [One Int (C Bool Int)] : No 9 | -------------------------------------------------------------------------------- /tests/solver/results/impr1: -------------------------------------------------------------------------------- 1 | [C Int u v, D u v] : Yes (improved to [C Int Float Bool, D Float Bool]) 2 | [D u v, C Int u v] : Yes (improved to [D Float Bool, C Int Float Bool]) 3 | [D u v] if C Int u v : Yes (improved to [D Float Bool] if C Int Float Bool) 4 | -------------------------------------------------------------------------------- /tests/solver/results/impr1-p: -------------------------------------------------------------------------------- 1 | [C Int u v, D u v] : Yes [$a:c_int_float_bool{}(), $b:d_float_bool{}()] (improved to [C Int Float Bool, D Float Bool]) 2 | [D u v, C Int u v] : Yes [$a:d_float_bool{}(), $b:c_int_float_bool{}()] (improved to [D Float Bool, C Int Float Bool]) 3 | [D u v] if C Int u v : Yes [$b:d_float_bool{}()] (improved to [D Float Bool] if C Int Float Bool) 4 | -------------------------------------------------------------------------------- /tests/solver/results/impr10: -------------------------------------------------------------------------------- 1 | [== u__t0 u__t1, Alignment (Stored (Ref CLL)) u__t2, Alignment (Stored (Ref CLL)) u__t3, Alignment (Stored Unsigned) u__t4, LCM u__t2 u__t3 u__t5, LCM u__t5 u__t4 u__t0, Alignment (Stored (Ref CLL)) u__t6] : Yes (improved to [== 4 4, Alignment (Stored (Ref CLL)) 4, Alignment (Stored (Ref CLL)) 4, Alignment (Stored Unsigned) 4, LCM 4 4 4, LCM 4 4 4, Alignment (Stored (Ref CLL)) 4]) 2 | -------------------------------------------------------------------------------- /tests/solver/results/impr10-p: -------------------------------------------------------------------------------- 1 | [== u__t0 u__t1, Alignment (Stored (Ref CLL)) u__t2, Alignment (Stored (Ref CLL)) u__t3, Alignment (Stored Unsigned) u__t4, LCM u__t2 u__t3 u__t5, LCM u__t5 u__t4 u__t0, Alignment (Stored (Ref CLL)) u__t6] : Yes [$a:==_t_t{u__t1}(), $b:alignment_stored_a_b_if_bytesize_stored_a_b{Ref CLL, t$6}(g$b:bytesize_stored_ref_a_4{CLL}()), $c:assumption($b), $d:alignment_stored_a_b_if_bytesize_stored_a_b{Unsigned, t$a}(g$e:bytesize_stored_unsigned_4{}()), $e:Oracles_arithmetic_lcm{}(), $f:assumption($e), $g:assumption($b)] (improved to [== 4 4, Alignment (Stored (Ref CLL)) 4, Alignment (Stored (Ref CLL)) 4, Alignment (Stored Unsigned) 4, LCM 4 4 4, LCM 4 4 4, Alignment (Stored (Ref CLL)) 4]) 2 | -------------------------------------------------------------------------------- /tests/solver/results/impr2: -------------------------------------------------------------------------------- 1 | [F a b, F a c, C b c a] : Yes (improved to [F True Int, F True Int, C Int Int True]) 2 | [C b c a] if F a b, F a c : Yes (improved to [C c c True] if F True c, F True c) 3 | [F a b, F a Bool, C b c a] : [F a Bool] remaining. (improved to [F a Bool, F a Bool, C Bool c a]) 4 | -------------------------------------------------------------------------------- /tests/solver/results/impr2-p: -------------------------------------------------------------------------------- 1 | [F a b, F a c, C b c a] : Yes [$a:f_true_int{}(), $b:assumption($a), $c:c_t_t_true!0{b}()] (improved to [F True Int, F True Int, C Int Int True]) 2 | [C b c a] if F a b, F a c : Yes [$c:c_t_t_true!0{c}()] (improved to [C c c True] if F True c, F True c) 3 | [F a b, F a Bool, C b c a] : [$a:F a Bool] remaining. [$b:assumption($a), $c:cases {[c :-> Bool] -> [a :-> True] c_t_t_true!0{Bool}(); [] -> [a :-> False] c_t_t_true!1{Bool, c}()}] (improved to [F a Bool, F a Bool, C Bool c a]) 4 | -------------------------------------------------------------------------------- /tests/solver/results/impr2b: -------------------------------------------------------------------------------- 1 | [F a b, F a c, C b c a] : [F a b, C b b a] remaining. (improved to [F a b, F a b, C b b a]) 2 | [F a b, F a Bool, C b c a] : [F a Bool, C Bool c a] remaining. (improved to [F a Bool, F a Bool, C Bool c a]) 3 | [C b c a] if F a b, F a c : [C c c a] remaining. (improved to [C c c a] if F a c, F a c) 4 | -------------------------------------------------------------------------------- /tests/solver/results/impr2b-p: -------------------------------------------------------------------------------- 1 | [F a b, F a c, C b c a] : [$a:F a b, $c:C b b a] remaining. [$b:assumption($a)] (improved to [F a b, F a b, C b b a]) 2 | [F a b, F a Bool, C b c a] : [$a:F a Bool, $c:C Bool c a] remaining. [$b:assumption($a)] (improved to [F a Bool, F a Bool, C Bool c a]) 3 | [C b c a] if F a b, F a c : [$c:C c c a] remaining. [] (improved to [C c c a] if F a c, F a c) 4 | -------------------------------------------------------------------------------- /tests/solver/results/impr4: -------------------------------------------------------------------------------- 1 | [H y, F X y] : [H y, F X y] remaining. 2 | [H y] if F X y : [H y] remaining. 3 | -------------------------------------------------------------------------------- /tests/solver/results/impr4-p: -------------------------------------------------------------------------------- 1 | [H y, F X y] : [$a:H y, $b:F X y] remaining. [] 2 | [H y] if F X y : [$b:H y] remaining. [] 3 | -------------------------------------------------------------------------------- /tests/solver/results/impr5: -------------------------------------------------------------------------------- 1 | [C t Float u v] : [C t Float u Bool] remaining. (improved to [C t Float u Bool]) 2 | [C (Maybe t) Float u v] : [C (Maybe t) Float u Bool] remaining. (improved to [C (Maybe t) Float u Bool]) 3 | [C (Maybe Int) Float u v] : Yes (improved to [C (Maybe Int) Float Int Bool]) 4 | -------------------------------------------------------------------------------- /tests/solver/results/impr5-p: -------------------------------------------------------------------------------- 1 | [C t Float u v] : [$a:C t Float u Bool] remaining. [] (improved to [C t Float u Bool]) 2 | [C (Maybe t) Float u v] : [$a:C (Maybe t) Float u Bool] remaining. [] (improved to [C (Maybe t) Float u Bool]) 3 | [C (Maybe Int) Float u v] : Yes [$a:c_maybe_int_float_int_bool{}()] (improved to [C (Maybe Int) Float Int Bool]) 4 | -------------------------------------------------------------------------------- /tests/solver/results/impr6: -------------------------------------------------------------------------------- 1 | [F Int True, G True Int] : Yes 2 | [F Float False, G False Float] : Yes 3 | [F t u] : [F t u] remaining. 4 | [F t u, G u t] : [F t u, G u t] remaining. 5 | -------------------------------------------------------------------------------- /tests/solver/results/impr6-p: -------------------------------------------------------------------------------- 1 | [F Int True, G True Int] : Yes [$a:f_t_true_if_c_t!0{Int}(g$5:c_int{}()), $b:g_true_int{}()] 2 | [F Float False, G False Float] : Yes [$a:f_t_true_if_c_t!1{Float}[0:g$5:c_float_fails{}()](), $b:g_false_float{}()] 3 | [F t u] : [$a:F t u] remaining. [] 4 | [F t u, G u t] : [$a:F t u, $b:G u t] remaining. [] 5 | -------------------------------------------------------------------------------- /tests/solver/results/impr7: -------------------------------------------------------------------------------- 1 | [F t u] : [F t u] remaining. 2 | [F t u, C t] : [C t] remaining. (improved to [F t Int, C t]) 3 | [F t u] if C t : Yes (improved to [F t Int] if C t) 4 | [G t u] : [G t u] remaining. 5 | [G t u] if C t : Yes (improved to [G t Int] if C t) 6 | [G t u] if C t fails : Yes (improved to [G t Bool] if C t fails) 7 | [G t u, C t] : [C t] remaining. (improved to [G t Int, C t]) 8 | [G t u, C t fails] : [C t fails] remaining. (improved to [G t Bool, C t fails]) 9 | [H t u v] : [H t u v] remaining. 10 | [H t u v] if C u : [H t u v] remaining. 11 | [H t u v, C u] : [H t u v, C u] remaining. 12 | -------------------------------------------------------------------------------- /tests/solver/results/impr7-p: -------------------------------------------------------------------------------- 1 | [F t u] : [$a:F t u] remaining. [] 2 | [F t u, C t] : [$b:C t] remaining. [$a:f_t_int_if_c_t{t}(g$3:assumption($b))] (improved to [F t Int, C t]) 3 | [F t u] if C t : Yes [$b:f_t_int_if_c_t{t}(g$3:assumption($a))] (improved to [F t Int] if C t) 4 | [G t u] : [$a:G t u] remaining. [] 5 | [G t u] if C t : Yes [$b:g_t_int_if_c_t{t}(g$6:assumption($a))] (improved to [G t Int] if C t) 6 | [G t u] if C t fails : Yes [$b:g_t_bool_if_c_t_fails{t}(g$5:assumption($a))] (improved to [G t Bool] if C t fails) 7 | [G t u, C t] : [$b:C t] remaining. [$a:g_t_int_if_c_t{t}(g$6:assumption($b))] (improved to [G t Int, C t]) 8 | [G t u, C t fails] : [$b:C t fails] remaining. [$a:g_t_bool_if_c_t_fails{t}(g$5:assumption($b))] (improved to [G t Bool, C t fails]) 9 | [H t u v] : [$a:H t u v] remaining. [] 10 | [H t u v] if C u : [$b:H t u v] remaining. [] 11 | [H t u v, C u] : [$a:H t u v, $b:C u] remaining. [] 12 | -------------------------------------------------------------------------------- /tests/solver/results/impr8: -------------------------------------------------------------------------------- 1 | [C t, Eq t u] if C u : Yes (improved to [C u, Eq u u] if C u) 2 | [Eq t u, C t] if C u : Yes (improved to [Eq u u, C u] if C u) 3 | -------------------------------------------------------------------------------- /tests/solver/results/impr8-p: -------------------------------------------------------------------------------- 1 | [C t, Eq t u] if C u : Yes [$b:assumption($a), $c:eq_t_t{u}()] (improved to [C u, Eq u u] if C u) 2 | [Eq t u, C t] if C u : Yes [$b:eq_t_t{u}(), $c:assumption($a)] (improved to [Eq u u, C u] if C u) 3 | -------------------------------------------------------------------------------- /tests/solver/results/impr9: -------------------------------------------------------------------------------- 1 | [F t u, C u] : [O t, C (S t)] remaining. (improved to [F t (S t), C (S t)]) 2 | -------------------------------------------------------------------------------- /tests/solver/results/impr9-p: -------------------------------------------------------------------------------- 1 | [F t u, C u] : [g$7:O t, $b:C (S t)] remaining. [f_t_s_t_if_o_t!0{t}(g$7:assumption(g$7))] (improved to [F t (S t), C (S t)]) 2 | -------------------------------------------------------------------------------- /tests/solver/results/log2: -------------------------------------------------------------------------------- 1 | [Log2 0 n] : No 2 | [Log2 1 n] : Yes (improved to [Log2 1 0]) 3 | [Log2 2 n] : Yes (improved to [Log2 2 1]) 4 | [Log2 3 n] : Yes (improved to [Log2 3 2]) 5 | [Log2 4 n] : Yes (improved to [Log2 4 2]) 6 | [Log2 5 n] : Yes (improved to [Log2 5 3]) 7 | [Log2 6 n] : Yes (improved to [Log2 6 3]) 8 | [Log2 7 n] : Yes (improved to [Log2 7 3]) 9 | [Log2 8 n] : Yes (improved to [Log2 8 3]) 10 | [Log2 9 n] : Yes (improved to [Log2 9 4]) 11 | [Log2 126 n] : Yes (improved to [Log2 126 7]) 12 | [Log2 127 n] : Yes (improved to [Log2 127 7]) 13 | [Log2 128 n] : Yes (improved to [Log2 128 7]) 14 | [Log2 129 n] : Yes (improved to [Log2 129 8]) 15 | [Log2 255 n] : Yes (improved to [Log2 255 8]) 16 | [Log2 256 n] : Yes (improved to [Log2 256 8]) 17 | [Log2 257 n] : Yes (improved to [Log2 257 9]) 18 | [Log2 65535 n] : Yes (improved to [Log2 65535 16]) 19 | [Log2 65536 n] : Yes (improved to [Log2 65536 16]) 20 | [Log2 65537 n] : Yes (improved to [Log2 65537 17]) 21 | [Log2 4294967296 n] : Yes (improved to [Log2 4294967296 32]) 22 | [Log2 4294967297 n] : Yes (improved to [Log2 4294967297 33]) 23 | -------------------------------------------------------------------------------- /tests/solver/results/loop: -------------------------------------------------------------------------------- 1 | [C t] : [C t] remaining. 2 | -------------------------------------------------------------------------------- /tests/solver/results/loop-p: -------------------------------------------------------------------------------- 1 | [C t] : [$a:C t] remaining. [] 2 | -------------------------------------------------------------------------------- /tests/solver/results/opaque1: -------------------------------------------------------------------------------- 1 | [C Int t] : Yes (improved to [C Int Int]) 2 | [C Int Int] : [C Int Int] remaining. 3 | [C Int Bool] : [C Int Bool] remaining. 4 | [C Int t, C Float t] : No 5 | [C Int t, C Bool t] : Yes (improved to [C Int Int, C Bool Int]) 6 | [C Int t] if C Float t : No 7 | [C Int t] if C Bool t : Yes (improved to [C Int Int] if C Bool Int) 8 | [C Int t, Eq t Bool] : [C Int Bool] remaining. (improved to [C Int Bool, Eq Bool Bool]) 9 | [C Int t, Eq t Int] : [C Int Int] remaining. (improved to [C Int Int, Eq Int Int]) 10 | [C Int t] if Eq t Bool : [C Int Bool] remaining. (improved to [C Int Bool] if Eq Bool Bool) 11 | [C Int t] if Eq t Int : [C Int Int] remaining. (improved to [C Int Int] if Eq Int Int) 12 | [C Int Int] if C Int Int : Yes 13 | [C Int Bool] if C Int Bool : Yes 14 | [C Int t] if C Int Int : Yes (improved to [C Int Int] if C Int Int) 15 | [C Int t] if C Int Bool : Yes (improved to [C Int Bool] if C Int Bool) 16 | [C Int Int, C Int Int] : [C Int Int] remaining. 17 | [D Int] : Yes 18 | [D Bool] : Yes 19 | [D Foo] : [D Foo] remaining. 20 | [E Int t] : [E Int t] remaining. 21 | [E Bool t] : [E Bool t] remaining. 22 | [E Int Int] : [E Int Int] remaining. 23 | [E Bool Int] : [E Bool Int] remaining. 24 | [E Int Bool] : [E Int Bool] remaining. 25 | [F Int t] : [F Int t] remaining. 26 | [F Bool t] : [F Bool t] remaining. 27 | [F Int Int] : [F Int Int] remaining. 28 | [F Bool Int] : [F Bool Int] remaining. 29 | [F Int Bool] : [F Int Bool] remaining. 30 | -------------------------------------------------------------------------------- /tests/solver/results/opaque1-p: -------------------------------------------------------------------------------- 1 | [C Int t] : Yes [$a:c_int_int{}()] (improved to [C Int Int]) 2 | [C Int Int] : [$a:C Int Int] remaining. [] 3 | [C Int Bool] : [$a:C Int Bool] remaining. [] 4 | [C Int t, C Float t] : No 5 | [C Int t, C Bool t] : Yes [$a:c_int_int{}(), $b:c_bool_t_if_eq_t_int{}(g$1:eq_t_t{Int}())] (improved to [C Int Int, C Bool Int]) 6 | [C Int t] if C Float t : No 7 | [C Int t] if C Bool t : Yes [$b:c_int_int{}()] (improved to [C Int Int] if C Bool Int) 8 | [C Int t, Eq t Bool] : [$a:C Int Bool] remaining. [$b:eq_t_t{Bool}()] (improved to [C Int Bool, Eq Bool Bool]) 9 | [C Int t, Eq t Int] : [$a:C Int Int] remaining. [$b:eq_t_t{Int}()] (improved to [C Int Int, Eq Int Int]) 10 | [C Int t] if Eq t Bool : [$b:C Int Bool] remaining. [] (improved to [C Int Bool] if Eq Bool Bool) 11 | [C Int t] if Eq t Int : [$b:C Int Int] remaining. [] (improved to [C Int Int] if Eq Int Int) 12 | [C Int Int] if C Int Int : Yes [$b:assumption($a)] 13 | [C Int Bool] if C Int Bool : Yes [$b:assumption($a)] 14 | [C Int t] if C Int Int : Yes [$b:assumption($a)] (improved to [C Int Int] if C Int Int) 15 | [C Int t] if C Int Bool : Yes [$b:assumption($a)] (improved to [C Int Bool] if C Int Bool) 16 | [C Int Int, C Int Int] : [$a:C Int Int] remaining. [$b:assumption($a)] 17 | [D Int] : Yes [$a:d_t_if_c_t_u{Int, t$4}(g$5:c_int_int{}())] 18 | [D Bool] : Yes [$a:d_t_if_c_t_u{Bool, t$4}(g$5:c_bool_t_if_eq_t_int{}(g$6:eq_t_t{Int}()))] 19 | [D Foo] : [$a:D Foo] remaining. [] 20 | [E Int t] : [$a:E Int t] remaining. [] 21 | [E Bool t] : [$a:E Bool t] remaining. [] 22 | [E Int Int] : [$a:E Int Int] remaining. [] 23 | [E Bool Int] : [$a:E Bool Int] remaining. [] 24 | [E Int Bool] : [$a:E Int Bool] remaining. [] 25 | [F Int t] : [$a:F Int t] remaining. [] 26 | [F Bool t] : [$a:F Bool t] remaining. [] 27 | [F Int Int] : [$a:F Int Int] remaining. [] 28 | [F Bool Int] : [$a:F Bool Int] remaining. [] 29 | [F Int Bool] : [$a:F Int Bool] remaining. [] 30 | -------------------------------------------------------------------------------- /tests/solver/results/oracle: -------------------------------------------------------------------------------- 1 | [+ 2 1 3] : Yes 2 | [+ 7 14 21] : Yes 3 | [+ 1 0 2] : No 4 | [+ 1 2 4] : No 5 | [+ 1 2 2] : No 6 | [+ 0 0 x] : Yes (improved to [+ 0 0 0]) 7 | [+ 0 1 x] : Yes (improved to [+ 0 1 1]) 8 | [+ 2 2 x] : Yes (improved to [+ 2 2 4]) 9 | [- 0 0 0] : Yes 10 | [- 0 1 0] : No 11 | [- 1 0 1] : Yes 12 | [- 3 1 2] : Yes 13 | [- 21 14 7] : Yes 14 | [- 0 0 1] : No 15 | [- 1 0 0] : No 16 | [- 1 0 2] : No 17 | [- 21 14 8] : No 18 | [- 0 0 x] : Yes (improved to [- 0 0 0]) 19 | [- 1 0 x] : Yes (improved to [- 1 0 1]) 20 | [- 28 14 x] : Yes (improved to [- 28 14 14]) 21 | [* 0 0 0] : Yes 22 | [* 1 0 0] : Yes 23 | [* 0 1 0] : Yes 24 | [* 2 3 6] : Yes 25 | [* 7 4 28] : Yes 26 | [* 2 3 5] : No 27 | [* 2 3 7] : No 28 | [* 2 4 12] : No 29 | [* 7 4 0] : No 30 | [* 7 4 21] : No 31 | [* 0 1 1] : No 32 | [* 2 3 x] : Yes (improved to [* 2 3 6]) 33 | [* 0 1 x] : Yes (improved to [* 0 1 0]) 34 | [* 7 3 x] : Yes (improved to [* 7 3 21]) 35 | [<= 0 0] : Yes 36 | [<= 0 1] : Yes 37 | [<= 0 1 fails] : No 38 | [<= 1 0] : No 39 | [<= 3 4] : Yes 40 | [<= 5 2 fails] : Yes 41 | [Gcd 2 3 1] : Yes 42 | [Gcd 2 3 x] : Yes (improved to [Gcd 2 3 1]) 43 | [Gcd 12 9 x] : Yes (improved to [Gcd 12 9 3]) 44 | [Gcd 8 12 x] : Yes (improved to [Gcd 8 12 4]) 45 | [Gcd 21 36 x] : Yes (improved to [Gcd 21 36 3]) 46 | -------------------------------------------------------------------------------- /tests/solver/results/peano: -------------------------------------------------------------------------------- 1 | [Add P2 P1 P3] : Yes 2 | [Add P7 P14 P21] : Yes 3 | [Add P1 P0 P2] : No 4 | [Add P1 P2 P4] : No 5 | [Add P1 P2 P2] : No 6 | [Add P0 P0 x] : Yes (improved to [Add P0 P0 P0]) 7 | [Add P0 P1 x] : Yes (improved to [Add P0 P1 P1]) 8 | [Add P2 P2 x] : Yes (improved to [Add P2 P2 P4]) 9 | [Subt P0 P0 P0] : Yes 10 | [Subt P0 P1 P0] : No 11 | [Subt P1 P0 P1] : Yes 12 | [Subt P3 P1 P2] : Yes 13 | [Subt P21 P14 P7] : Yes 14 | [Subt P0 P0 P1] : No 15 | [Subt P1 P0 P0] : No 16 | [Subt P1 P0 P2] : No 17 | [Subt P21 P14 P8] : No 18 | [Subt P0 P0 x] : Yes (improved to [Subt P0 P0 P0]) 19 | [Subt P1 P0 x] : Yes (improved to [Subt P1 P0 P1]) 20 | [Subt P28 P14 x] : Yes (improved to [Subt P28 P14 P14]) 21 | [Mult P0 P0 P0] : Yes 22 | [Mult P1 P0 P0] : Yes 23 | [Mult P0 P1 P0] : Yes 24 | [Mult P2 P3 P6] : Yes 25 | [Mult P7 P4 P28] : Yes 26 | [Mult P2 P3 P5] : No 27 | [Mult P2 P3 P7] : No 28 | [Mult P2 P4 P12] : No 29 | [Mult P7 P4 P0] : No 30 | [Mult P7 P4 P21] : No 31 | [Mult P0 P1 P1] : No 32 | [Mult P2 P3 x] : Yes (improved to [Mult P2 P3 P6]) 33 | [Mult P0 P1 x] : Yes (improved to [Mult P0 P1 P0]) 34 | [Mult P7 P3 x] : Yes (improved to [Mult P7 P3 P21]) 35 | [Div P0 P1 P0] : Yes 36 | [Div P6 P1 P6] : Yes 37 | [Div P6 P2 P3] : Yes 38 | [Div P21 P7 P3] : Yes 39 | [Div P1 P0 P0] : No 40 | [Div P1 P0 P1] : No 41 | [Div P21 P7 P2] : No 42 | [Div P6 P1 x] : Yes (improved to [Div P6 P1 P6]) 43 | [Div P6 P2 x] : Yes (improved to [Div P6 P2 P3]) 44 | [Div P5 P2 x] : No 45 | [Div P21 P7 x] : Yes (improved to [Div P21 P7 P3]) 46 | [Lte P0 P0] : Yes 47 | [Lte P0 P1] : Yes 48 | [Lte P0 P1 fails] : No 49 | [Lte P1 P0] : No 50 | [Lte P3 P4] : Yes 51 | [Lte P5 P2 fails] : Yes 52 | [Gcd P2 P3 P1] : Yes 53 | [Gcd P2 P3 x] : Yes (improved to [Gcd P2 P3 P1]) 54 | [Gcd P12 P9 x] : Yes (improved to [Gcd P12 P9 P3]) 55 | [Gcd P8 P12 x] : Yes (improved to [Gcd P8 P12 P4]) 56 | [Gcd P21 P36 x] : Yes (improved to [Gcd P21 P36 P3]) 57 | -------------------------------------------------------------------------------- /tests/solver/results/primrq: -------------------------------------------------------------------------------- 1 | The axiom forall . Divisor Unsigned NZU 2 | does not meet the requirement forall k, k, k. Divisor _0 _1, NumLit _2 _0, < 0 _2 requires NumLit _2 _1 3 | -------------------------------------------------------------------------------- /tests/solver/results/rq1: -------------------------------------------------------------------------------- 1 | [D X] if C X : Yes 2 | [E X] if C X : Yes 3 | -------------------------------------------------------------------------------- /tests/solver/results/rq1-p: -------------------------------------------------------------------------------- 1 | [D X] if C X : Yes [$b:required(c_t_requires_d_t, [_:assumption($a)])] 2 | [E X] if C X : Yes [$b:e_t_if_c_t__d_t{X}(g$4:assumption($a), g$5:required(c_t_requires_d_t, [_:assumption($a)]))] 3 | -------------------------------------------------------------------------------- /tests/solver/results/rq2: -------------------------------------------------------------------------------- 1 | [C T U, C U V, C T V, C V W, C U W, C T W] : [C T U, C U V, C V W] remaining. 2 | [C T V, C U W, C T W] if C T U, C U V, C V W : Yes 3 | [C x y, C y z, C x z] : [C x y, C y z] remaining. 4 | [C x z] if C x y, C y z : Yes 5 | -------------------------------------------------------------------------------- /tests/solver/results/rq2-p: -------------------------------------------------------------------------------- 1 | [C T U, C U V, C T V, C V W, C U W, C T W] : [$a:C T U, $b:C U V, $d:C V W] remaining. [$c:required(c_t_u_c_u_v_requires_c_t_v, [_:assumption($a), _:assumption($b)]), $e:required(c_t_u_c_u_v_requires_c_t_v, [_:assumption($b), _:assumption($d)]), $f:required(c_t_u_c_u_v_requires_c_t_v, [_:required(c_t_u_c_u_v_requires_c_t_v, [_:assumption($a), _:assumption($b)]), _:assumption($d)])] 2 | [C T V, C U W, C T W] if C T U, C U V, C V W : Yes [$d:required(c_t_u_c_u_v_requires_c_t_v, [_:assumption($a), _:assumption($b)]), $e:required(c_t_u_c_u_v_requires_c_t_v, [_:assumption($b), _:assumption($c)]), $f:required(c_t_u_c_u_v_requires_c_t_v, [_:required(c_t_u_c_u_v_requires_c_t_v, [_:assumption($a), _:assumption($b)]), _:assumption($c)])] 3 | [C x y, C y z, C x z] : [$a:C x y, $b:C y z] remaining. [$c:required(c_t_u_c_u_v_requires_c_t_v, [_:assumption($a), _:assumption($b)])] 4 | [C x z] if C x y, C y z : Yes [$c:required(c_t_u_c_u_v_requires_c_t_v, [_:assumption($a), _:assumption($b)])] 5 | -------------------------------------------------------------------------------- /tests/solver/results/rq3: -------------------------------------------------------------------------------- 1 | [Lte P0 P14] : Yes 2 | [Lte P5 P14] : Yes 3 | [Lte P14 P5] : No 4 | [Lte P5 P8, Lte P8 P16, Lte P5 P16] : Yes 5 | [Lte P5 P16] if Lte P5 P8, Lte P8 P16 : Yes 6 | -------------------------------------------------------------------------------- /tests/solver/results/rq3-p: -------------------------------------------------------------------------------- 1 | lte_m_n_lte_n_p_requires_lte_m_p: 2 | (lte_s_m_s_n_if_lte_m_n!0{t$17, t$18}(g1), lte_s_m_s_n_if_lte_m_n!0{t$18, t$20}(g2)) -> lte_m_n_lte_n_p_requires_lte_m_p:lte_s_m_s_n_if_lte_m_n!0{t$17, t$20}(g$76:required(lte_m_n_lte_n_p_requires_lte_m_p, [_:assumption(g1), _:assumption(g2)])) 3 | (lte_s_m_s_n_if_lte_m_n!0{t$25, t$17}(g2), lte_s_m_s_n_if_lte_m_n!0{t$17, t$18}(g1)) -> lte_m_n_lte_n_p_requires_lte_m_p:lte_s_m_s_n_if_lte_m_n!0{t$25, t$18}(g$82:required(lte_m_n_lte_n_p_requires_lte_m_p, [_:assumption(g2), _:assumption(g1)])) 4 | (lte_p0_m!0{S t$17}(), lte_s_m_s_n_if_lte_m_n!0{t$17, t$18}(g1)) -> lte_m_n_lte_n_p_requires_lte_m_p:lte_p0_m!0{S t$18}() 5 | (lte_p0_m!0{P0}(), lte_p0_m!0{t$51}()) -> lte_m_n_lte_n_p_requires_lte_m_p:lte_p0_m!0{t$51}() 6 | (lte_p0_m!0{S t$55}(), lte_s_m_s_n_if_lte_m_n!0{t$55, t$56}(g1)) -> lte_m_n_lte_n_p_requires_lte_m_p:lte_p0_m!0{S t$56}() 7 | (lte_p0_m!0{P0}(), lte_p0_m!0{t$52}()) -> lte_m_n_lte_n_p_requires_lte_m_p:lte_p0_m!0{t$52}() 8 | [Lte P0 P14] : Yes [$a:lte_p0_m!0{P14}()] 9 | [Lte P5 P14] : Yes [$a:lte_s_m_s_n_if_lte_m_n!0{P4, P13}(g$16:lte_s_m_s_n_if_lte_m_n!0{P3, P12}(g$29:lte_s_m_s_n_if_lte_m_n!0{P2, P11}(g$42:lte_s_m_s_n_if_lte_m_n!0{P1, P10}(g$55:lte_s_m_s_n_if_lte_m_n!0{P0, P9}(g$68:lte_p0_m!0{P9}())))))] 10 | [Lte P14 P5] : No 11 | [Lte P5 P8, Lte P8 P16, Lte P5 P16] : Yes [$a:lte_s_m_s_n_if_lte_m_n!0{P4, P7}(g$34:lte_s_m_s_n_if_lte_m_n!0{P3, P6}(g$60:lte_s_m_s_n_if_lte_m_n!0{P2, P5}(g$86:lte_s_m_s_n_if_lte_m_n!0{P1, P4}(g$118:lte_s_m_s_n_if_lte_m_n!0{P0, P3}(g$144:lte_p0_m!0{P3}()))))), $b:lte_s_m_s_n_if_lte_m_n!0{P7, P15}(g$47:lte_s_m_s_n_if_lte_m_n!0{P6, P14}(g$73:lte_s_m_s_n_if_lte_m_n!0{P5, P13}(g$105:lte_s_m_s_n_if_lte_m_n!0{P4, P12}(g$131:lte_s_m_s_n_if_lte_m_n!0{P3, P11}(g$157:lte_s_m_s_n_if_lte_m_n!0{P2, P10}(g$176:lte_s_m_s_n_if_lte_m_n!0{P1, P9}(g$189:lte_s_m_s_n_if_lte_m_n!0{P0, P8}(g$202:lte_p0_m!0{P8}())))))))), $c:required(lte_m_n_lte_n_p_requires_lte_m_p, [_:assumption($a), _:assumption($b)])] 12 | [Lte P5 P16] if Lte P5 P8, Lte P8 P16 : Yes [$c:required(lte_m_n_lte_n_p_requires_lte_m_p, [_:assumption($a), _:assumption($b)])] 13 | -------------------------------------------------------------------------------- /tests/solver/results/rq4: -------------------------------------------------------------------------------- 1 | The axiom forall k. D (Pair _0 Bool) 2 | does not meet the requirement forall k. C _0, D _0 requires E _0 3 | -------------------------------------------------------------------------------- /tests/solver/results/rq4-p: -------------------------------------------------------------------------------- 1 | The axiom forall k. D (Pair _0 Bool) 2 | does not meet the requirement forall k. C _0, D _0 requires E _0 3 | 4 | The axiom forall k. C (Pair Int _0) 5 | does not meet the requirement forall k. C _0, D _0 requires E _0 6 | 7 | -------------------------------------------------------------------------------- /tests/solver/results/simpl1: -------------------------------------------------------------------------------- 1 | [C t] : [C t] remaining. 2 | [C' t] : [D t] remaining. 3 | [E t] : [C t] remaining. 4 | -------------------------------------------------------------------------------- /tests/solver/results/simpl1-p: -------------------------------------------------------------------------------- 1 | [C t] : [$a:C t] remaining. [] 2 | [C' t] : [g$5:D t] remaining. [c__t_if_d_t!0{t}(g$5:assumption(g$5))] 3 | [E t] : [g$5:C t] remaining. [e_t_if_c_t!0{t}(g$5:assumption(g$5))] 4 | -------------------------------------------------------------------------------- /tests/solver/tests/1: -------------------------------------------------------------------------------- 1 | -- Simple instances with basic backtracking and fails clauses. Tests are in '2'. 2 | 3 | Integral Int; Integral Integer; Integral t fails if Fractional t; Integral t if Enum t. 4 | Fractional Float; Fractional Double; Fractional t if RealFrac t. 5 | Eq Int; Eq (List a) if Eq a; Eq (Fun a b) fails. 6 | -------------------------------------------------------------------------------- /tests/solver/tests/2: -------------------------------------------------------------------------------- 1 | -- Various queries - intended to be run with the axioms from 'tests/1' 2 | 3 | Integral Int? 4 | Fractional Int? 5 | Integral Float? 6 | Eq Int? 7 | Eq (List Int)? 8 | Eq (List (List Int))? 9 | Eq (Fun a b)? 10 | Eq (List (List (Fun a b)))? 11 | Eq (List (List Bool))? 12 | -------------------------------------------------------------------------------- /tests/solver/tests/3: -------------------------------------------------------------------------------- 1 | -- This test is left over from one of the unification bugs. 2 | F t t; F t u fails. 3 | F Int Int? 4 | F Int Bool? 5 | 6 | -- Another unification bug: This verifies that bindings from matches in a sequence cannot allow 7 | -- later matches to bind LHS variables. In this case, when matching the goal against the first 8 | -- clause of the 'C' axiom, binding [x/t] resulting from the first parameter should not allow the 9 | -- binding [y/x] for the second. 10 | -- 11 | -- Note that the goal ought to be solvable, requires cases. The bug is demonstrated should the 12 | -- solver find the improvement [True/z] 13 | 14 | C t u v | t u ~> v. 15 | C t t True; C t u False. 16 | C x y z? -------------------------------------------------------------------------------- /tests/solver/tests/4: -------------------------------------------------------------------------------- 1 | -- Before the solver caught co-inductive proofs, this test generated an infinite loop 2 | R Double. 3 | F t fails if I t; F t if R t. 4 | I t fails if F t. 5 | 6 | F Double? -------------------------------------------------------------------------------- /tests/solver/tests/5: -------------------------------------------------------------------------------- 1 | -- Simple functional dependency tests. 2 | 3 | C Int fails. 4 | C Float. 5 | 6 | -- Note that the second axiom is only consistent and non-overlapping with the first because of the 7 | -- axiom 'C Int fails' above. 8 | F t u | t ~> u. 9 | F Int Bool. 10 | F t Int if C t. 11 | 12 | 13 | F Int Bool? 14 | F Int t? 15 | F Float Int? 16 | F Float t? 17 | F Float Bool? 18 | F Float Bool fails? -------------------------------------------------------------------------------- /tests/solver/tests/6: -------------------------------------------------------------------------------- 1 | -- More functional dependency tests. This checks that the improvement from 'C' propagates to 2 | -- queries on 'F' 3 | 4 | C t u | t ~> u. 5 | F t u | t ~> u. 6 | C Int Bool. 7 | F t u if C t u. 8 | F Int t? 9 | 10 | -- This tests functional dependency driven exclusions. Note that because we know 'G Int Char', we 11 | -- know that no predicate of the form 'G Int t' for t =/= Char can hold. 12 | 13 | G t u | t ~> u. 14 | G Int Bool fails; G Int Char. 15 | G Int Float fails? 16 | -------------------------------------------------------------------------------- /tests/solver/tests/7: -------------------------------------------------------------------------------- 1 | -- More functional dependencies. This checks that functional dependencies work for variables that 2 | -- do not appear in the initial query. 3 | 4 | C t u | t ~> u. 5 | C Int Bool. 6 | D Bool. 7 | E t if C t u, D u. 8 | F t if D u, C t u. 9 | 10 | E Int? 11 | F Int? -------------------------------------------------------------------------------- /tests/solver/tests/8: -------------------------------------------------------------------------------- 1 | -- Equality relation powered by functional dependencies. 2 | Eq t u | t ~> u, u ~> t. 3 | Eq t t. 4 | 5 | -- Simple improvement tests. 6 | Eq T T? 7 | Eq T U? 8 | Eq T t? 9 | Eq t T? 10 | Eq t u? 11 | 12 | -- Equivalence relations ought to be symmetric and transitive... 13 | Eq t u if Eq u t? 14 | Eq t v if Eq t u, Eq u v? 15 | 16 | -- In this case, we can use the improvement from the assumption Eq t u to select the first clause of 17 | -- C, without requiring proof by cases. 18 | C t u v | t u ~> v. 19 | C t t True; C t u False. 20 | 21 | C t u v if Eq t u? 22 | 23 | -------------------------------------------------------------------------------- /tests/solver/tests/9: -------------------------------------------------------------------------------- 1 | -- 2 | 3 | C t if D t; C (Maybe t) fails; C U. 4 | D U fails. 5 | 6 | == t u | t ~> u, u ~> t. 7 | == t t. 8 | 9 | C U? 10 | C t, == t U? 11 | == t U, C t? 12 | 13 | -- 14 | 15 | C1 t; C1 (Maybe t) if E1 t. 16 | D1 (Maybe T). 17 | 18 | C1 t, == t (Maybe T)? -------------------------------------------------------------------------------- /tests/solver/tests/Overlap.hs: -------------------------------------------------------------------------------- 1 | module Tests.Overlap where 2 | 3 | import Parser 4 | import Solver 5 | 6 | -------------------------------------------------------------------------------- 7 | -- Overlap tests 8 | 9 | p = q' predicate 10 | qp = q' qpred 11 | ax = q' axiom 12 | 13 | a = [qp "Eq a => Eq (L a)", qp "(Eq a, Eq b) => Eq (P a b)"] 14 | f = [p "Eq Int", p "Eq Bool"] 15 | 16 | a' = [qp "Eq a => Eq (L a)", qp "Eq (F a b) fails"] 17 | f' = [p "Eq (F a b)"] 18 | 19 | t0 = overlapping [] (qp "Eq Int") (qp "Eq Bool") 20 | t1 = overlapping [] (qp "Eq Int") (qp "Eq t") 21 | t2 = overlapping [] (qp "Eq t") (qp "Eq Int") 22 | t3 = overlapping [] (qp "Eq Int") (qp "Eq Int") 23 | t4 = overlapping [] (qp "Eq t") (qp "Eq t") 24 | 25 | b0 = and [not t0, t1, t2, t3, t4] 26 | 27 | t5 = overlapping [] (qp "Eq a => Eq (L a)") (qp "Eq (L a)") 28 | t6 = overlapping [] (qp "Eq a => Eq (L a)") (qp "Eq a fails => Eq (L a)") 29 | t7 = overlapping [] (qp "Eq a => Eq (L a)") (qp "Qe q => Eq (L a)") 30 | 31 | b1 = and [t5, not t6, t7] 32 | 33 | t8 = overlapping [ax "Eq T fails"] (qp "Eq a => Eq (L a)") (qp "Eq (L T)") 34 | t9 = overlapping [ax "Eq T"] (qp "Eq t fails => Eq (L t)") (qp "Eq (L T)") 35 | t10 = overlapping [ax "C t => D t fails"] (qp "C t => F t") (qp "D t => F t") 36 | t11 = overlapping [ax "C t => D t fails"] (qp "C t => F t") (qp "D t fails => F t") 37 | 38 | b2 = and [not t8, not t9, not t10, t11] 39 | 40 | 41 | 42 | main = print (and [b0, b1, b2]) -------------------------------------------------------------------------------- /tests/solver/tests/cases: -------------------------------------------------------------------------------- 1 | -- Simplest possible use of proof-by-cases. Note that 'C t' holds for all 't', but has a different 2 | -- proof in the particular case that 't' = 'Int'. 3 | 4 | C Int; C t. 5 | 6 | -- Sanity checks: should use the second and first clauses, respectively. 7 | 8 | C (Maybe Int)? 9 | C Int? 10 | 11 | -- For the final query, we should generate a proof by cases: under the condition [Int/t], the proof 12 | -- is by the first clause of the axiom; otherwise, under the empty condition, the proof is by the 13 | -- second clause. 14 | 15 | C t? -------------------------------------------------------------------------------- /tests/solver/tests/cases2: -------------------------------------------------------------------------------- 1 | D Int. D Bool. D Float fails. D (Maybe t) fails. 2 | C Int; C t if D t. 3 | C Float; C t if D t fails, E t. 4 | 5 | C Int? 6 | C Bool? 7 | C t? -------------------------------------------------------------------------------- /tests/solver/tests/cycle: -------------------------------------------------------------------------------- 1 | MinAlign a | ~> a. 2 | Ref a b | a ~> b. 3 | Ref b (ARef a b) if MinAlign a. 4 | MinAlign 1. 5 | Ref t u, Ref (Stored Unsigned) u? 6 | 7 | 8 | -------------------------------------------------------------------------------- /tests/solver/tests/cyclic1: -------------------------------------------------------------------------------- 1 | ExprFour a | ~> a. 2 | 3 | :-: a b c | a c ~> b. 4 | :-: a b c | a b ~> c. 5 | 6 | @ Expr a requires @ a (Expr a). 7 | @ (:+: a b) c requires @ a c, @ b c. 8 | 9 | ExprFour (Expr (:+: Const (:+: Sum (:+: Product Double)))); 10 | ExprFour a fails. 11 | 12 | In a a; 13 | In a (:+: b c) if In a b, @ (:+: b) c, @ :+: b; 14 | In a (:+: c b) if In a b, @ (:+: c) b, @ :+: c; 15 | In a b fails. 16 | 17 | :-: (:+: a b) a b if @ (:+: a) b, @ :+: a; 18 | :-: (:+: a b) b a if @ (:+: a) b, @ :+: a; 19 | :-: (:+: c b) a (:+: d b) if In a b fails, :-: c a d, @ (:+: c) b, @ :+: c, @ (:+: d) b, @ :+: d; 20 | :-: (:+: b c) a (:+: b d) if In a b fails, :-: c a d, @ (:+: b) c, @ :+: b, @ (:+: b) d, @ :+: b. 21 | 22 | @ Double a! 23 | @ Expr a if @ a (Expr a); @ Expr a fails! 24 | @ Product a! 25 | @ Sum a! 26 | @ Const a! 27 | @ :+: a! 28 | @ (:+: a) b! 29 | @ (:+: a c) b if @ a b, @ c b; @ (:+: a b) c fails! 30 | 31 | @ e$5j8y (Expr e$5j8y), 32 | :-: e$5j8y Const h$5j8z, 33 | @ h$5j8z (Expr e$5j8y), 34 | :-: e$5j95 Double e$5j8y, 35 | ExprFour (Expr e$5j95)? 36 | -------------------------------------------------------------------------------- /tests/solver/tests/dtac: -------------------------------------------------------------------------------- 1 | -- Examples based on data types a la carte. Explained in great, gory detail in 2 | -- http://cs.pdx.edu/~jgmorris/d/final.pdf, section 3.4. Queries are in 'dtac_tests' 3 | 4 | -- Simple inclusion. 5 | 6 | In f f; 7 | In f (Plus g h) if In f g; 8 | In f (Plus g h) if In f h; 9 | In f g fails. 10 | 11 | -- Unique inclusion. A query like 'In Int (Plus Int Int)' holds, but makes an arbitrary (if 12 | -- predictable) choice as to which 'Int' it finds. In terms of an overloaded injection functions, 13 | -- this means you would never be able to generate a value (Inr x). UniqueIn rejects these cases. 14 | 15 | UniqueIn f f; 16 | UniqueIn f (Plus g h) if UniqueIn f g, In f h fails; 17 | UniqueIn f (Plus g h) if UniqueIn f h, In f g fails; 18 | UniqueIn f g fails. 19 | 20 | -- Exclusion. Roughly speaking, 'Without t u v' holds if 'v' contains all the types that 't' does 21 | -- except for 'u'. 22 | 23 | Without t u v | t u ~> v. -- , t v ~> u. 24 | Without t t v fails; 25 | Without (Plus t u) t u; 26 | Without (Plus t u) u t; 27 | Without (Plus t u) v (Plus t' u) if Without t v t', In v u fails; 28 | Without (Plus t u) v (Plus t u') if Without u v u', In v t fails; 29 | Without t u t. -------------------------------------------------------------------------------- /tests/solver/tests/dtac_tests: -------------------------------------------------------------------------------- 1 | In Int Int? 2 | In Int (Plus Int Bool)? 3 | In Char (Plus Int Bool)? 4 | In Int (Plus Int (Plus Int Bool))? 5 | In Int (Plus x (Plus Int Bool))? 6 | In Int (Plus Int (Plus Int Int))? 7 | In Bool (Plus Int (Plus Int Bool))? 8 | In Int (Plus (Plus Int Bool) (Plus Char Expr))? 9 | 10 | UniqueIn Int Int? 11 | UniqueIn Int (Plus Int Bool)? 12 | UniqueIn Char (Plus Int Bool)? 13 | UniqueIn Int (Plus Int (Plus Int Bool))? 14 | UniqueIn Int (Plus Int (Plus Int Int))? 15 | UniqueIn Int (Plus x (Plus Int Bool))? 16 | UniqueIn Int (Plus (Plus Int Int) Int)? 17 | UniqueIn Int (Plus (Plus Int Int) (Plus Int Int))? 18 | UniqueIn Bool (Plus Int (Plus Int Bool))? 19 | UniqueIn Int (Plus (Plus Int Bool) (Plus Char Expr))? 20 | 21 | Without Int Int t? 22 | Without Int Bool t? 23 | Without (Plus Int Bool) Int t? 24 | Without (Plus Int Bool) Bool t? 25 | Without (Plus (Plus Int Bool) (Plus Char Float)) Int t? 26 | Without (Plus (Plus Int Bool) (Plus Char Float)) (Plus Int Bool) t? 27 | -------------------------------------------------------------------------------- /tests/solver/tests/fd2: -------------------------------------------------------------------------------- 1 | -- This tests functional dependencies with user-defined classes as hypotheses. We begin by setting 2 | -- up addition and multiplication for Peano numbers. 3 | 4 | Even P0; 5 | Even (S (S n)) if Even n; 6 | Even n fails. 7 | 8 | Add m n p | m n ~> p, m p ~> n, n p ~> m. 9 | 10 | Add P0 P0 P0; 11 | Add P0 n n; 12 | Add m P0 m; 13 | Add (S m) (S n) (S (S p)) if Add m n p. 14 | 15 | Mult x y z | x y ~> z, x z ~> y. 16 | Mult x Z Z; 17 | Mult x (S y) z if Mult x y z', Add x z' z; 18 | Mult x y z fails. 19 | 20 | Double m n | m ~> n, n ~> m. 21 | Double m n if Mult P2 m n. 22 | 23 | -- Predicates 'J t u' hold if either (a) 't' is a multiple of 4, and 'u' is half 't', or (b) 't' is 24 | -- a multiple of 2, but not a multiple of 4, and 'u' is 1. Note that the distinction is based on 25 | -- the determined parameter, not the determining parameter. 26 | 27 | J t u | t ~> u. 28 | J m n if Double n m, Even n. 29 | J m P1 if Double n m, Even n fails. 30 | 31 | J P4 P2? 32 | J P4 P1? 33 | J P4 t? 34 | 35 | J P6 P3? 36 | J P6 P1? 37 | J P6 t? -------------------------------------------------------------------------------- /tests/solver/tests/fd3: -------------------------------------------------------------------------------- 1 | -- Continuing functional dependencies with user-defined classes as hypotheses. This file, along 2 | -- with fd3a-fd3c, demonstrate number of approaches that are not sufficient to prove cases 3 | -- consistent. 4 | 5 | -- As in fd2, we begin with Peano arithmetic 6 | 7 | Even P0; 8 | Even (S (S n)) if Even n; 9 | Even n fails. 10 | 11 | Add m n p | m n ~> p, m p ~> n, n p ~> m. 12 | 13 | Add P0 P0 P0; 14 | Add P0 n n; 15 | Add m P0 m; 16 | Add (S m) (S n) (S (S p)) if Add m n p. 17 | 18 | Mult x y z | x y ~> z, x z ~> y. 19 | Mult x Z Z; 20 | Mult x (S y) z if Mult x y z', Add x z' z; 21 | Mult x y z fails. 22 | 23 | Double m n | m ~> n, n ~> m. 24 | Double m n if Mult P2 m n. 25 | -------------------------------------------------------------------------------- /tests/solver/tests/fd3a: -------------------------------------------------------------------------------- 1 | -- This case demonstrates the flaw with a previous implementation of the functional dependency 2 | -- consistency check. Note that these instances are not overlapping: the common case is a predicate 3 | -- of the form 'F m P1' such that 'Double m n' and 'Even P1' hold, but the latter never holds. 4 | -- However, this does not mean that the instances are consistent. In particular, because the latter 5 | -- instance does not constraint 'n', the predicates 'F P4 P2' and 'F P4 P1' would both hold under 6 | -- these axioms, violating the functional dependency on 'F'. 7 | 8 | F t u | t ~> u. 9 | F m n if Double n m, Even n. 10 | F m P1 if Double n m. 11 | -------------------------------------------------------------------------------- /tests/solver/tests/fd3b: -------------------------------------------------------------------------------- 1 | -- 'G' and 'H' demonstrate the same difference between coherence and consistency, but for non-normal 2 | -- relations. For example, the two axioms for 'G' are more obviously non-overlapping, as Int =/= 3 | -- Float. However, this is not sufficient to show that the functional dependency is respected. 4 | 5 | G t u v | u ~> v. 6 | G Int m n if Double m n, Even n. 7 | G Float m P1 if Double m n. 8 | -------------------------------------------------------------------------------- /tests/solver/tests/fd3c: -------------------------------------------------------------------------------- 1 | -- 'G' and 'H' demonstrate the same difference between coherence and consistency, but for non-normal 2 | -- relations. For example, the two axioms for 'G' are more obviously non-overlapping, as Int =/= 3 | -- Float. However, this is not sufficient to show that the functional dependency is respected. 4 | 5 | H t u v | u ~> v. 6 | H (Maybe t) m n if Double m n, Even n, Ord t. 7 | H (List t) m P1 if Double m n, Eq t. 8 | -------------------------------------------------------------------------------- /tests/solver/tests/fd4: -------------------------------------------------------------------------------- 1 | -- This tests that functional dependencies properly exclude predicates from relations. 2 | 3 | C t u | t ~> u, u ~> t. 4 | 5 | C T U. 6 | 7 | -- Answers should be: Yes [U/u], Yes [T/t], No (on account of the u ~> t dependency). 8 | 9 | C T u? 10 | C t U? 11 | C U U? -------------------------------------------------------------------------------- /tests/solver/tests/generic: -------------------------------------------------------------------------------- 1 | -- Tests for treatment of generic variables. Unlike in Haskell, the hypothesis of an axiom for 2 | -- class 'C' having some functional dependency does not imply that class 'C' has even a partial 3 | -- functional dependency. 4 | 5 | -- We begin by defining two classes with functional dependencies. 6 | 7 | F t u | t ~> u. 8 | G t u | t ~> u. 9 | F Int Bool. 10 | G Int Float. 11 | 12 | -- We now provide axioms for class 'C'. Note that 'C' has neither the functional dependency of 'F' 13 | -- nor that of 'G', as it includes tuples from both classes and they are not disjoint. 14 | 15 | C t u if F t u. 16 | C t u if F t u fails, G t u. 17 | 18 | -- As demonstration thereof, we show that 'C Int t', 'C Int u' does not imply that 't' = 'u', and 19 | -- that C predicates give rise to no improvements. 20 | 21 | C Int Bool? 22 | C Int Float? 23 | C Int t? 24 | C Int t, C Int u? -------------------------------------------------------------------------------- /tests/solver/tests/generic2: -------------------------------------------------------------------------------- 1 | -- More tests of the treatment of generic variables. 2 | 3 | MEq t u | t ~> u. 4 | MEq t t. 5 | 6 | F t u | t ~> u. 7 | F t (Maybe t). 8 | 9 | -- In this query, the solver initially assumes that variable 't' is generic, while 'u', because it 10 | -- appears in the determined position of the 'MEq' predicate, is not generic. However, in improving 11 | -- 'u' to 'Maybe t', variable 't' now appears in a determined position, and the solver must update 12 | -- its notion of which variables are generic. 13 | 14 | F t u, MEq (Maybe Int) u? -------------------------------------------------------------------------------- /tests/solver/tests/hlist: -------------------------------------------------------------------------------- 1 | -- Examples based on the HList paper. This also illustrates the rarely used ilab feature of 2 | -- user-named axioms. 3 | 4 | one: One t (C t ts) if None t ts; One t (C t ts) fails; One t (C t' ts) if One t ts; One t u fails. 5 | none: None t Nil; None t (C t ts) fails; None t (C t' ts) if None t ts; None t u fails. 6 | 7 | One Int (C Int Nil)? 8 | One Int (C Int (C Bool Nil))? 9 | One Int (C Bool (C Int Nil))? 10 | One Int (C Bool Nil)? 11 | One Int (C Int (C Int Nil))? 12 | One Int (C x (C Int Nil))? 13 | One Int (C Int Int)? 14 | One Int (C Bool Int)? -------------------------------------------------------------------------------- /tests/solver/tests/impr1: -------------------------------------------------------------------------------- 1 | -- Improvement for non-normal axioms. Note that variable 'v' does not participate in the functional 2 | -- dependency on class 'C'. 3 | 4 | C t u v | t ~> u. 5 | D u v | u ~> v. 6 | 7 | C Int Float Bool. 8 | C Int Float Char. 9 | D Float Bool. 10 | 11 | -- Each of the queries below includes the predicate 'C Int u v'. Note that this predicate cannot be 12 | -- proven as stated (nor can the axiom used to prove it be inferred from its assumption): since 'v' 13 | -- does not participate in the functional dependency, it must be refined to determine which of the 14 | -- axioms is applicable. However, because the determining part of the functional dependency is 15 | -- specified, the predicate can be used to infer the improvement [Float/u], even without being able 16 | -- to resolve it. This is sufficient to prove the 'D u v' predicate in each case, allowing the 17 | -- entire query to be solved. 18 | 19 | C Int u v, D u v? 20 | D u v, C Int u v? 21 | D u v if C Int u v? -------------------------------------------------------------------------------- /tests/solver/tests/impr10: -------------------------------------------------------------------------------- 1 | == t u | t ~> u, u ~> t. 2 | == t t. 3 | 4 | Alignment t u | t ~> u. 5 | ByteSize t u | t ~> u. 6 | 7 | Alignment (Stored a) b if ByteSize (Stored a) b. 8 | ByteSize (Stored Unsigned) 4. 9 | ByteSize (Stored (Ref a)) 4. 10 | 11 | == u__t0 u__t1, Alignment (Stored (Ref CLL)) u__t2, Alignment (Stored (Ref CLL)) u__t3, Alignment (Stored Unsigned) u__t4, LCM u__t2 u__t3 u__t5, LCM u__t5 u__t4 u__t0, Alignment (Stored (Ref CLL)) u__t6? -------------------------------------------------------------------------------- /tests/solver/tests/impr2: -------------------------------------------------------------------------------- 1 | -- Testing pairwise improvement. 2 | 3 | F t u | t ~> u. 4 | C t u v | t u ~> v. 5 | 6 | C t t True; C t u False. 7 | 8 | F True Int. 9 | F False Bool. 10 | 11 | -- Each of these demonstraints pairwise improvement---even without being able to prove the 12 | -- predicates 'F a b' and 'F a c', we can use them to compute the improvement [b/c]. This, in turn, 13 | -- allows the C predicate to be resolved. 14 | 15 | F a b, F a c, C b c a? 16 | C b c a if F a b, F a c? 17 | 18 | -- Sanity check: without the pairwise improvement, the predicates cannot be resolved. Note that the 19 | -- C predicate can still be solved by cases; in the above examples, it was solved directly. 20 | 21 | F a b, F a Bool, C b c a? 22 | -------------------------------------------------------------------------------- /tests/solver/tests/impr2b: -------------------------------------------------------------------------------- 1 | -- Tests the combination of pairwise improvement and generics. Similar to impr2, but in this 2 | -- version, the 'C' class does not have the functional dependency that it did in that version. 3 | -- Thus, while the pairwise improvements can still be done, the C predicates generate no 4 | -- improvements, and the queries as a whole cannot be discharged. 5 | 6 | F t u | t ~> u. 7 | D t u v | t u ~> v. 8 | 9 | D t t True; D t u False. 10 | 11 | -- The functional dependency on D does not cause a similar functional dependency on C. The second 12 | -- 'C' axiom demonstrates this. 13 | 14 | C t u v if D t u v. 15 | C t t Int if D t t Int fails. 16 | 17 | F True Int. 18 | F False Bool. 19 | 20 | F a b, F a c, C b c a? 21 | F a b, F a Bool, C b c a? 22 | 23 | C b c a if F a b, F a c? -------------------------------------------------------------------------------- /tests/solver/tests/impr3: -------------------------------------------------------------------------------- 1 | -- Aspirational improvement tests for now. These generally present cases where the particular 2 | -- clause to solve a given predicate cannot be determined, but those clauses that could solve it all 3 | -- give rise to the same improvement. The proof-by-cases mechanism could hopefully be extended to 4 | -- observe these cases and generate the suitable improvements. 5 | 6 | -- Classes 'C' and 'D' are variations on the same theme. In each, there are several axioms for 7 | -- types (M t), each with the determined parameter True, and one case for all other types with the 8 | -- determined parameter False. In each case, the types are not sufficiently refined to solve the 9 | -- queries; however, because of the final clause, it could safely be concluded that the query 10 | -- predicates could only hold under the substitution [True/z]. 11 | 12 | C t u v | t u ~> v. 13 | C (M t) t True; 14 | C (M t) u True; 15 | C t u False. 16 | 17 | C (M x) y z? 18 | 19 | D t u v | t u ~> v. 20 | D (M t) Int True; 21 | D (M t) Float True; 22 | D t u False. 23 | 24 | D (M x) y z? 25 | 26 | -- Finally, here is a case where such logic does not apply. In this case, while the same pattern is 27 | -- present (clauses sending (M t) types to True and other types to False), there is no guarantee 28 | -- that other axioms will not be added in the future in which the pattern is no longer true. 29 | 30 | E t u v | t u ~> v. 31 | E (M t) Int True. 32 | E (M t) Float True. 33 | E (L t) Int False. 34 | 35 | E (M x) y z? -------------------------------------------------------------------------------- /tests/solver/tests/impr4: -------------------------------------------------------------------------------- 1 | -- Generic variables and improvement: functional dependency on 'G' should not induce improvements 2 | -- from 'F' predicates. 3 | 4 | -- This seems like a duplication of the tests in 'generic'. 5 | 6 | G x y | x ~> y. 7 | G x x. 8 | 9 | F x y if G x y. 10 | 11 | H X. 12 | 13 | H y, F X y? 14 | H y if F X y? -------------------------------------------------------------------------------- /tests/solver/tests/impr5: -------------------------------------------------------------------------------- 1 | -- More tests of non-normal classes and improvements. In this case, class 'C' has two functional 2 | -- dependencies, each of which involves two of its arguments. 3 | 4 | C a b c d | a ~> c, b ~> d. 5 | 6 | C (Maybe Int) Float Int Bool. 7 | C (Maybe Int) Int Int Float. 8 | C (Maybe Float) Float Float Bool. 9 | 10 | -- In the first two queries, we do not have enough refinment of the types (in particular, of the 11 | -- first argument) to determine whether any axiom that resolves the predicate. However, the second 12 | -- argument is sufficient resolved to determine the fourth, giving rise to the improvement [Bool/v] 13 | -- in each case. 14 | 15 | C t Float u v? 16 | C (Maybe t) Float u v? 17 | 18 | 19 | -- In this case, both the first and second argumets are sufficient resolved to determine the third 20 | -- and fourth arguments via the functional dependencies, and that is enough to solve the predicate. 21 | 22 | C (Maybe Int) Float u v? 23 | -------------------------------------------------------------------------------- /tests/solver/tests/impr7: -------------------------------------------------------------------------------- 1 | -- Tests of improvement and inter-axiom backtracking. 2 | 3 | -- Note that the improvement [Int/u] for 'F t u' depends on the provability of 'C t', and there may 4 | -- be other axioms for cases where 'C t' is disprovable. Thus, the should be no improvement in the 5 | -- first case, but can be improvement in each of the latter cases. 6 | 7 | F t u | t ~> u. 8 | F t Int if C t. 9 | 10 | F t u? 11 | F t u, C t? 12 | F t u if C t? 13 | 14 | -- Here is such an example with a two axioms, depending on the provability of 'C t'. Again, there 15 | -- should be no improvement in the first case, but should be in the remaining cases. 16 | 17 | G t u | t ~> u. 18 | G t Int if C t. 19 | G t Bool if C t fails. 20 | 21 | G t u? 22 | G t u if C t? 23 | G t u if C t fails? 24 | G t u, C t? 25 | G t u, C t fails? 26 | 27 | -- Finally, the same reasoning applies to non-normal classes. 28 | 29 | H t u v | u ~> v. 30 | H Int u Int if C u. 31 | H Float u Int if C u. 32 | 33 | H t u v? 34 | H t u v if C u? 35 | H t u v, C u? -------------------------------------------------------------------------------- /tests/solver/tests/impr8: -------------------------------------------------------------------------------- 1 | -- Demonstrates the need for dynamic backtracking. 2 | 3 | Eq t u | t ~> u, u ~> t. 4 | Eq t t. 5 | 6 | C t if D t. 7 | 8 | -- The queries below should be equivalent. In previous versions of the solver, however, they were 9 | -- not both provable. In the first query, when the solver initially encounters the goal 'C t', it 10 | -- has no information on 't', and so applies the 'C' axiom, introducing the subgoal 'D t'. Upon 11 | -- encountering the goal 'Eq t u', the solver introduces the improvement [t/u]. This ought to allow 12 | -- the first to be solvable; however, note that it has already been reduced to a subgoal, and that 13 | -- backtracking to before the introduction of its subgoal would also backtrack to before the 14 | -- introduction of the [t/u] improvement. Dynamic backtracking allows the solver to backtrack the 15 | -- application of the axiom to the goal 'C t' without eliminating the [t/u] improvement, solving the 16 | -- query. 17 | 18 | C t, Eq t u if C u? 19 | Eq t u, C t if C u? 20 | 21 | -------------------------------------------------------------------------------- /tests/solver/tests/impr9: -------------------------------------------------------------------------------- 1 | F t u | t ~> u. 2 | F t (S t) if O t; F t u fails. 3 | 4 | F t u, C u? -------------------------------------------------------------------------------- /tests/solver/tests/log2: -------------------------------------------------------------------------------- 1 | -- How many bits are needed to represent numbers in the range 0 to (n-1)? 2 | -- The answer is given by log2 n, assuming the following definition: 3 | -- 4 | -- log2 n = if n==1 then 0 5 | -- else if even n then 1 + log2 (n `div` 2) 6 | -- else 1 + log2 ((n+1) `div` 2) 7 | -- 8 | -- Or, see how pretty this looks in Habit (although perhaps the class 9 | -- should be called IxBits in that context): 10 | -- 11 | -- class Log2 (n::nat) = (m::nat) 12 | -- instance Log2 0 = n fails 13 | -- else Log2 1 = 0 14 | -- else Log2 n = 1 + Log2 (n / 2) -- (A) 15 | -- else Log2 n = 1 + Log2 ((n+1) / 2) -- (B) 16 | -- 17 | -- The clauses marked A and B here are particularly interesting; the / 18 | -- symbol represents division of naturals which is a partial function. 19 | -- (Or really, in Habit type class terms, a partial relation.) So if n 20 | -- is an odd number, then n/2 is not defined, clause (A) fails, and we 21 | -- continue to clause (B) instead. 22 | -- 23 | 24 | + a b c | a b ~> c, a c ~> b, c b ~> a. 25 | / a b c | a b ~> c, b c ~> a. 26 | 27 | Log2 n m | n ~> m. 28 | 29 | Log2 0 n fails; 30 | Log2 1 0; 31 | Log2 n m if + p 1 m, / n 2 q, Log2 q p; 32 | Log2 n m if + p 1 m, Log2 q p, / n1 2 q, + n 1 n1. 33 | 34 | -- Some tests: 35 | 36 | Log2 0 n? -- should fail 37 | 38 | Log2 1 n? -- expect n=0 39 | 40 | Log2 2 n? -- expect n=1 41 | 42 | Log2 3 n? -- expect n=2 43 | Log2 4 n? -- expect n=2 44 | 45 | Log2 5 n? -- expect n=3 46 | Log2 6 n? -- expect n=3 47 | Log2 7 n? -- expect n=3 48 | Log2 8 n? -- expect n=3 49 | 50 | Log2 9 n? -- expect n=4 51 | 52 | Log2 126 n? -- expect n=7 53 | Log2 127 n? -- expect n=7 54 | Log2 128 n? -- expect n=7 55 | 56 | Log2 129 n? -- expect n=8 57 | Log2 255 n? -- expect n=8 58 | Log2 256 n? -- expect n=8 59 | 60 | Log2 257 n? -- expect n=9 61 | 62 | Log2 65535 n? -- expect n=16 63 | Log2 65536 n? -- expect n=16 64 | Log2 65537 n? -- expect n=17 65 | 66 | Log2 4294967296 n? -- expect n=32 67 | Log2 4294967297 n? -- expect n=33 68 | -------------------------------------------------------------------------------- /tests/solver/tests/loop: -------------------------------------------------------------------------------- 1 | -- Test for the loop detection in the solver. In this case, the important aspect is that the loop 2 | -- is only apparent after taking pairwise improvement into account. 3 | 4 | F t u | t ~> u. 5 | C t | ~> t. 6 | 7 | C t if C u, F u t. 8 | 9 | C t? -------------------------------------------------------------------------------- /tests/solver/tests/opaque1: -------------------------------------------------------------------------------- 1 | -- Various tests of opacity. 2 | 3 | C t u | t ~> u. 4 | C t u | opaque u. 5 | 6 | Eq t u | t ~> u, u ~> t. 7 | Eq t t. 8 | 9 | C Int Int. 10 | C Bool t if Eq t Int. 11 | C Float Bool. 12 | 13 | -- Simple opacity tests: predicates should only be resolved (either positively or negatively) if 14 | -- their opacity constraints are respected. 15 | 16 | C Int t? 17 | C Int Int? 18 | C Int Bool? 19 | 20 | -- Sharing tests: two predicates can share opaque variables, and should only be solvable if their 21 | -- (opaque) improvements are compatible. 22 | 23 | C Int t, C Float t? 24 | C Int t, C Bool t? 25 | C Int t if C Float t? 26 | C Int t if C Bool t? 27 | 28 | -- More complicated opacity tests: using additional predicates to fix type variables should not 29 | -- allow the violation of opacity constraints. 30 | 31 | C Int t, Eq t Bool? 32 | C Int t, Eq t Int? 33 | C Int t if Eq t Bool? 34 | C Int t if Eq t Int? 35 | 36 | -- Opacity and assumption: assumptions hold, even if they violate opacity constraints, but do not 37 | -- allow violation of other opacity constraints. (This underlies the way that methods of classes 38 | -- with opacity constraints can be recursive.) 39 | 40 | C Int Int if C Int Int? 41 | C Int Bool if C Int Bool? 42 | C Int t if C Int Int? 43 | C Int t if C Int Bool? 44 | 45 | C Int Int, C Int Int? 46 | 47 | -- Because D does not refer to the opaque parameter of C, D should be provable for all the cases 48 | -- where 'C t u' is provable. 49 | 50 | D t if C t u. 51 | 52 | D Int? 53 | D Bool? 54 | D Foo? 55 | 56 | -- E, however, does refer to the opaque parameters of C. So, E should not be provable if doing so 57 | -- would require violating an opacity constraint on 'C'. 58 | 59 | E t u if C t u. 60 | 61 | E Int t? 62 | E Bool t? 63 | E Int Int? 64 | E Bool Int? 65 | E Int Bool? 66 | 67 | -- Similarly, F should not give rise to improvements that violate the opacity constraint on C. 68 | 69 | F t u | t ~> u. 70 | F t u if C t u. 71 | 72 | F Int t? 73 | F Bool t? 74 | F Int Int? 75 | F Bool Int? 76 | F Int Bool? 77 | -------------------------------------------------------------------------------- /tests/solver/tests/oracle_arithmetic: -------------------------------------------------------------------------------- 1 | -- Tests of the built-in arithmetic classes. This defines several additional classes (minus, less 2 | -- than, and GCD) in terms of the built-in classes. Tests are in oracles_arithmetic_tests. 3 | 4 | - a b c | a b ~> c, a c ~> b, c b ~> a. 5 | - a b c if + c b a; - a b c fails. 6 | 7 | <= m n if + n 1 n', < m n'; <= m n fails. 8 | 9 | Gcd m n p | m n ~> p. 10 | Gcd m m m; 11 | Gcd m n p if <= n m, - m n m', Gcd m' n p; 12 | Gcd m n p if <= m n, - n m n', Gcd m n' p; 13 | Gcd m n p fails. 14 | -------------------------------------------------------------------------------- /tests/solver/tests/oracle_arithmetic_tests: -------------------------------------------------------------------------------- 1 | -- Tests of the built-in arithmetic classes. This tests both the built-in classes and user-defined 2 | -- classes defined in terms of them. Definitions are in oracles_arithmetic_tests. 3 | 4 | 5 | + 2 1 3? 6 | + 7 14 21? 7 | 8 | + 1 0 2? 9 | + 1 2 4? 10 | + 1 2 2? 11 | 12 | + 0 0 x? 13 | + 0 1 x? 14 | + 2 2 x? 15 | 16 | 17 | - 0 0 0? 18 | - 0 1 0? 19 | - 1 0 1? 20 | - 3 1 2? 21 | - 21 14 7? 22 | 23 | - 0 0 1? 24 | - 1 0 0? 25 | - 1 0 2? 26 | - 21 14 8? 27 | 28 | - 0 0 x? 29 | - 1 0 x? 30 | - 28 14 x? 31 | 32 | 33 | * 0 0 0? 34 | * 1 0 0? 35 | * 0 1 0? 36 | * 2 3 6? 37 | * 7 4 28? 38 | 39 | * 2 3 5? 40 | * 2 3 7? 41 | * 2 4 12? 42 | * 7 4 0? 43 | * 7 4 21? 44 | * 0 1 1? 45 | 46 | * 2 3 x? 47 | * 0 1 x? 48 | * 7 3 x? 49 | 50 | <= 0 0? 51 | <= 0 1? 52 | <= 0 1 fails? 53 | <= 1 0? 54 | <= 3 4? 55 | <= 5 2 fails? 56 | 57 | Gcd 2 3 1? 58 | Gcd 2 3 x? 59 | Gcd 12 9 x? 60 | Gcd 8 12 x? 61 | Gcd 21 36 x? 62 | -------------------------------------------------------------------------------- /tests/solver/tests/peano: -------------------------------------------------------------------------------- 1 | -- Peano arithmetic, defined standard (to me) fashion. Tests are in 'peano_tests' 2 | 3 | Add x y z | x y ~> z, x z ~> y, y z ~> x. 4 | Add x Z x; 5 | Add x (S y) (S z) if Add x y z; 6 | Add x y z fails. 7 | 8 | Subt x y z | x y ~> z, x z ~> y, y z ~> x. 9 | Subt x Z x; 10 | Subt Z x y fails; 11 | Subt x (S y) z if Subt x y (S z); 12 | Subt x y z fails. 13 | 14 | Mult x y z | x y ~> z. 15 | Mult x Z Z; 16 | Mult x (S y) z if Mult x y z', Add x z' z; 17 | Mult x y z fails. 18 | 19 | Div x y z | x y ~> z. 20 | Div x Z y fails; 21 | Div Z x Z; 22 | Div x y (S z) if Subt x y x', Div x' y z; 23 | Div x y z fails. 24 | 25 | Lte P0 n; 26 | Lte (S m) (S n) if Lte m n; 27 | Lte m n fails. 28 | 29 | Gcd m n p | m n ~> p. 30 | Gcd m m m; 31 | Gcd m n p if Lte n m, Subt m n m', Gcd m' n p; 32 | Gcd m n p if Lte m n, Subt n m n', Gcd m n' p; 33 | Gcd m n p fails. 34 | -------------------------------------------------------------------------------- /tests/solver/tests/peano_tests: -------------------------------------------------------------------------------- 1 | -- Tests of Peano arithmetic. Definitions in 'peano'. 2 | 3 | Add P2 P1 P3? 4 | Add P7 P14 P21? 5 | 6 | Add P1 P0 P2? 7 | Add P1 P2 P4? 8 | Add P1 P2 P2? 9 | 10 | Add P0 P0 x? 11 | Add P0 P1 x? 12 | Add P2 P2 x? 13 | 14 | 15 | Subt P0 P0 P0? 16 | Subt P0 P1 P0? 17 | Subt P1 P0 P1? 18 | Subt P3 P1 P2? 19 | Subt P21 P14 P7? 20 | 21 | Subt P0 P0 P1? 22 | Subt P1 P0 P0? 23 | Subt P1 P0 P2? 24 | Subt P21 P14 P8? 25 | 26 | Subt P0 P0 x? 27 | Subt P1 P0 x? 28 | Subt P28 P14 x? 29 | 30 | 31 | Mult P0 P0 P0? 32 | Mult P1 P0 P0? 33 | Mult P0 P1 P0? 34 | Mult P2 P3 P6? 35 | Mult P7 P4 P28? 36 | 37 | Mult P2 P3 P5? 38 | Mult P2 P3 P7? 39 | Mult P2 P4 P12? 40 | Mult P7 P4 P0? 41 | Mult P7 P4 P21? 42 | Mult P0 P1 P1? 43 | 44 | Mult P2 P3 x? 45 | Mult P0 P1 x? 46 | Mult P7 P3 x? 47 | 48 | 49 | Div P0 P1 P0? 50 | Div P6 P1 P6? 51 | Div P6 P2 P3? 52 | Div P21 P7 P3? 53 | 54 | Div P1 P0 P0? 55 | Div P1 P0 P1? 56 | Div P21 P7 P2? 57 | 58 | Div P6 P1 x? 59 | Div P6 P2 x? 60 | Div P5 P2 x? 61 | Div P21 P7 x? 62 | 63 | Lte P0 P0? 64 | Lte P0 P1? 65 | Lte P0 P1 fails? 66 | Lte P1 P0? 67 | Lte P3 P4? 68 | Lte P5 P2 fails? 69 | 70 | Gcd P2 P3 P1? 71 | Gcd P2 P3 x? 72 | Gcd P12 P9 x? 73 | Gcd P8 P12 x? 74 | Gcd P21 P36 x? 75 | -------------------------------------------------------------------------------- /tests/solver/tests/primrq: -------------------------------------------------------------------------------- 1 | -- Requirements and primitive classes. This ensures that the requirements mechanism is not 2 | -- flummoxed by the lack of axioms for built-in classes. 3 | 4 | Divisor t u | t ~> u. 5 | Divisor t u, NumLit n t, < 0 n requires NumLit n u. 6 | 7 | NumLit n Unsigned. 8 | 9 | -- This test is to make sure the program is rejected without the following instance: 10 | -- NumLit n NZU if < 0 n. 11 | 12 | Divisor Unsigned NZU. -------------------------------------------------------------------------------- /tests/solver/tests/refine: -------------------------------------------------------------------------------- 1 | C t if D t; C Int fails. 2 | 3 | = t u | t ~> u, u ~> t. 4 | = t t. 5 | 6 | C t, = t Int? -------------------------------------------------------------------------------- /tests/solver/tests/rq1: -------------------------------------------------------------------------------- 1 | -- Simplest of requirement tests. From C X, it should be enough to establish D X, which is (in 2 | -- turn) enough to establish E X. 3 | 4 | C t requires D t. 5 | E t if C t, D t. 6 | 7 | D X if C X? 8 | E X if C X? -------------------------------------------------------------------------------- /tests/solver/tests/rq2: -------------------------------------------------------------------------------- 1 | -- Transitivity via requirements 2 | 3 | C t u, C u v requires C t v. 4 | 5 | C T U, C U V, C T V, C V W, C U W, C T W? 6 | C T V, C U W, C T W if C T U, C U V, C V W? 7 | 8 | C x y, C y z, C x z? 9 | C x z if C x y, C y z? -------------------------------------------------------------------------------- /tests/solver/tests/rq3: -------------------------------------------------------------------------------- 1 | -- More concrete example of transitivity, for <= on peano numbers. 2 | 3 | Lte m n, Lte n p requires Lte m p. 4 | 5 | Lte P0 m; 6 | Lte m P0 fails. 7 | 8 | Lte (S m) (S n) if Lte m n; 9 | Lte (S m) (S n) fails. 10 | 11 | Lte P0 P14? 12 | Lte P5 P14? 13 | Lte P14 P5? 14 | Lte P5 P8, Lte P8 P16, Lte P5 P16? 15 | Lte P5 P16 if Lte P5 P8, Lte P8 P16? 16 | -------------------------------------------------------------------------------- /tests/solver/tests/rq4: -------------------------------------------------------------------------------- 1 | -- Requirement violation check: the D instance should be rejected, as there is no instance E (Pair 2 | -- Int Bool). 3 | 4 | C t, D t requires E t. 5 | C (Pair Int t). 6 | D (Pair t Bool). 7 | -------------------------------------------------------------------------------- /tests/solver/tests/rqfd.ilab: -------------------------------------------------------------------------------- 1 | Eq t u | t ~> u, u ~> t. 2 | Eq t t. 3 | 4 | F t u, F t v requires Eq u v. 5 | 6 | F Int Bool. 7 | F t Char if Eq t Int fails. 8 | 9 | F Int t? 10 | F Bool t? 11 | F t u? -------------------------------------------------------------------------------- /tests/solver/tests/rvcoerce: -------------------------------------------------------------------------------- 1 | RowSubset Nil ys; 2 | RowSubset (Cons l t xs) ys if In l ys, RowSubset xs ys; 3 | RowSubset xs ys fails. 4 | 5 | In l Nil fails; 6 | In l (Cons l t ys); 7 | In l (Cons l' t ys) if In l ys; 8 | In l ys fails. 9 | 10 | -- 11 | 12 | RowCoerce Nil ys; 13 | RowCoerce (Cons l t xs) ys if CoerceOne l t ys, RowCoerce xs ys; 14 | RowCoerce xs ys fails. 15 | 16 | CoerceOne l t Nil; 17 | CoerceOne l t (Cons l t ys); 18 | CoerceOne l t (Cons l t' ys) if Coerce t t'; 19 | CoerceOne l t (Cons l' t' ys) if CoerceOne l t ys; 20 | CoerceOne l t ys fails. 21 | 22 | -- 23 | 24 | RLabels r l | r ~> l. 25 | VLabels v l | v ~> l. 26 | 27 | Coerce rec0 rec1 if RLabels rec0 l0, RLabels rec1 l1, RowSubset l1 l0, RowCoerce l0 l1; 28 | Coerce var0 var1 if VLabels var0 l0, VLabels var1 l1, RowSubset l0 l1, RowCoerce l0 l1. 29 | 30 | RLabels Int l fails. VLabels Int l fails. 31 | RLabels Float l fails. VLabels Float l fails. 32 | Coerce Int Float. 33 | 34 | RLabels Point (Cons X Int (Cons Y Int Nil)). VLabels Point fails. 35 | RLabels FloatingPoint (Cons X Float (Cons Y Float Nil)). VLabels FloatingPoint fails. 36 | RLabels ColoredPoint (Cons X Int (Cons Y Int (Cons Color RGB Nil))). VLabels ColoredPoint fails. 37 | 38 | Coerce Point ColoredPoint? 39 | Coerce ColoredPoint Point? 40 | 41 | Coerce Point FloatingPoint? 42 | Coerce FloatingPoint Point? 43 | 44 | Coerce FloatingPoint ColoredPoint? 45 | Coerce ColoredPoint FloatingPoint? 46 | 47 | 48 | RLabels Square (Cons TopLeft Point (Cons BottomRight Point Nil)). VLabels Square l fails. 49 | RLabels SquareF (Cons TopLeft FloatingPoint (Cons BottomRight FloatingPoint Nil)). VLabels SquareF l fails. 50 | RLabels Circle (Cons TopLeft Point (Cons Radius Int Nil)). VLabels Circle l fails. 51 | 52 | VLabels ShapeA (Cons Sq Square Nil). RLabels ShapeA l fails. 53 | VLabels ShapeB (Cons Sq SquareF Nil). RLabels ShapeB l fails. 54 | VLabels ShapeC (Cons Sq Square (Cons Ci Circle Nil)). RLabels ShapeC l fails. 55 | VLabels ShapeD (Cons Sq SquareF (Cons Ci Circle Nil)). RLabels ShapeD l fails. 56 | 57 | Coerce ShapeA ShapeB? 58 | Coerce ShapeB ShapeA? 59 | 60 | Coerce ShapeA ShapeC? 61 | Coerce ShapeB ShapeC? 62 | Coerce ShapeC ShapeA? 63 | Coerce ShapeC ShapeB? 64 | 65 | Coerce ShapeA ShapeD? 66 | Coerce ShapeB ShapeD? 67 | Coerce ShapeC ShapeD? 68 | Coerce ShapeD ShapeA? 69 | Coerce ShapeD ShapeB? 70 | Coerce ShapeD ShapeC? -------------------------------------------------------------------------------- /tests/solver/tests/simpl1: -------------------------------------------------------------------------------- 1 | -- Simplification. With inter-axiom backtracking, simplification can only trigger in cases where 2 | -- other axioms are ruled out. In this examples, there is nothing to prevent other instances 'C t', 3 | -- so long as they require that 'D t' be disprovable. However, other instances of 'C' t' are ruled 4 | -- out by the trailing fails clause. Thus, the C' (and E) examples can simplify, but the C example 5 | -- cannot. 6 | 7 | C t if D t. 8 | C' t if D t; C' t fails. 9 | E t if C t; E t fails. 10 | 11 | C t? 12 | C' t? 13 | E t? -------------------------------------------------------------------------------- /tests/solver/tests/sort: -------------------------------------------------------------------------------- 1 | Lte 0 x; Lte (S x) (S y) if Lte x y; Lte x y fails. 2 | LteAll x Nil; LteAll x (Cons y ys) if Lte x y, LteAll x ys; LteAll x y fails. 3 | Sorted Nil; Sorted (Cons x xs) if LteAll x xs, Sorted xs; Sorted (Cons x xs) fails. 4 | 5 | Insert x xs ys | x xs ~> ys. 6 | Insert x Nil (Cons x Nil); 7 | Insert x (Cons x' xs) (Cons x (Cons x' xs)) if Lte x x'; 8 | Insert x (Cons x' xs) (Cons x' ys) if Insert x xs ys; 9 | Insert x xs ys fails. 10 | 11 | Sort xs ys | xs ~> ys. 12 | Sort Nil Nil; 13 | Sort (Cons x xs) zs if Sort xs ys, Insert x ys zs; 14 | Sort xs ys fails. -------------------------------------------------------------------------------- /tests/struct.hb: -------------------------------------------------------------------------------- 1 | requires prelude 2 | requires mem 3 | requires io 4 | 5 | struct S[y :: Stored Unsigned | x :: Stored (Bit 8)] 6 | 7 | -- Things that should fail: 8 | -- 9 | -- struct S[y :: Stored Unsigned | x :: Stored (Bit 8)] 10 | -- aligned 1 11 | -- 12 | -- Because the alignment is too small for the 'y' component 13 | -- 14 | -- struct S[x :: Stored (Bit 8) | y :: Stored Unsigned] 15 | -- 16 | -- Because the y field has the wrong alignment 17 | 18 | struct T / 5 [y :: Stored Unsigned | x :: Stored (Bit 8)] 19 | aligned 4K 20 | 21 | area a <- S[x <- 1 | y <- 2] :: Ref S 22 | 23 | main = do z <- readRef a.y 24 | putint z 25 | -------------------------------------------------------------------------------- /tests/super.hb: -------------------------------------------------------------------------------- 1 | data Bool = False | True 2 | 3 | class Eq t 4 | where eq :: t -> t -> Bool 5 | 6 | class Ord t | Eq t 7 | where lte :: t -> t -> Bool 8 | 9 | f :: Ord t => t -> t -> Bool 10 | f x y = eq x y 11 | 12 | instance Eq Bool 13 | where eq True True = True 14 | eq False False = True 15 | eq _ _ = False 16 | 17 | instance Ord Bool 18 | where lte False _ = True 19 | lte True True = True 20 | lte _ _ = False 21 | 22 | data List t = Nil | Cons t (List t) 23 | 24 | instance Eq (List t) if Eq t 25 | where eq Nil Nil = True 26 | eq (Cons x xs) (Cons y ys) = if eq x y then eq xs ys else False 27 | eq _ _ = False 28 | 29 | instance Ord (List t) if Ord t 30 | where lte Nil Nil = True 31 | lte (Cons x xs) (Cons y ys) = if lte x y then lte xs ys else False 32 | lte _ _ = False 33 | 34 | -------------------------------------------------------------------------------- /tests/synth.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | 3 | bitdata T = K [ x, y :: Bit 3 ] 4 | 5 | instance T.z = Bit 6 6 | where t.z = t.x :# t.y 7 | 8 | f :: (r.x = a) => r -> a 9 | f r = r.x 10 | -------------------------------------------------------------------------------- /tests/test.hb: -------------------------------------------------------------------------------- 1 | requires prelude 2 | requires list 3 | requires io 4 | 5 | equalM x m = do 6 | m' <- m 7 | return (x == m') 8 | 9 | runTests :: List (M Bool) -> M Unsigned 10 | runTests xs = f 0 0 xs where 11 | passChar = 0x2E 12 | failChar = 0x58 13 | f :: Unsigned -> Unsigned -> List (M Bool) -> M Unsigned 14 | f pass total Nil = do 15 | putchar 0x20 -- space 16 | putchar 0x5B -- [ 17 | putint pass 18 | putchar 0x20 -- space 19 | putchar 0x6F -- o 20 | putchar 0x66 -- f 21 | putchar 0x20 -- space 22 | putint total 23 | putchar 0x20 -- space 24 | putchar 0x74 -- t 25 | putchar 0x65 -- e 26 | putchar 0x73 -- s 27 | putchar 0x74 -- t 28 | putchar 0x73 -- s 29 | putchar 0x20 -- space 30 | putchar 0x70 -- p 31 | putchar 0x61 -- a 32 | putchar 0x73 -- s 33 | putchar 0x73 -- s 34 | putchar 0x5D -- ] 35 | putchar 0x0A -- \n 36 | return (total - pass) 37 | f pass total (Cons m ms) = do 38 | pass' <- if<- m then do putchar passChar; return (pass+1) else do putchar failChar; return pass 39 | flush 40 | f pass' (total+1) ms 41 | -------------------------------------------------------------------------------- /tests/testHarness.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | import System.Environment 3 | import System.Exit 4 | import System.Process 5 | import Text.Printf 6 | import System.IO 7 | 8 | testFile :: String -> IO [(String, Int)] 9 | testFile f = do 10 | putStrLn $ "Testing " ++ f ++ ": " 11 | hFlush stdout 12 | code <- rawSystem f [] 13 | x <- return $ case code of 14 | ExitSuccess -> [] 15 | ExitFailure x -> [(f, x)] 16 | putStr "\n" 17 | return x 18 | 19 | summary files failedFiles = do 20 | printf "Summary: %d of %d files passed, %d tests failed\n" 21 | (length files - length failedFiles :: Int) 22 | (length files :: Int) 23 | (sum $ map snd failedFiles :: Int) 24 | 25 | reportFile (file, failures) = do 26 | printf " Failed: %s (failed %d tests)\n" (file :: String) (failures :: Int) 27 | 28 | main = do 29 | files <- getArgs 30 | putStrLn $ take 72 $ repeat '=' 31 | failedFiles <- liftM concat $ mapM testFile files 32 | putStrLn $ take 72 $ repeat '=' 33 | summary files failedFiles 34 | mapM reportFile failedFiles 35 | return () 36 | -------------------------------------------------------------------------------- /tests/thih.hb: -------------------------------------------------------------------------------- 1 | primitive type (->) :: * -> * -> * 2 | infixr type 5 -> 3 | 4 | data Bool = False | True 5 | 6 | not False = True 7 | not True = False 8 | 9 | class Monad m 10 | where return :: a -> m a 11 | (>>=) :: m a -> (a -> m b) -> m b 12 | 13 | data List x = Cons x (List x) | Nil 14 | 15 | Nil ++ y = y 16 | (Cons x xs) ++ y = Cons x (xs ++ y) 17 | 18 | class C t where op :: t -> Bool 19 | instance C (List t) where op x = True 20 | 21 | x >> y = x >>= (\x -> y) 22 | 23 | p y = (let f x = op (y >> return x) in f :: c -> Bool, y ++ Nil) 24 | 25 | q y = (y ++ Nil, let f x = op (y >> return x) in f :: c -> Bool) -------------------------------------------------------------------------------- /tests/tuples.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | 3 | x = (True, False) 4 | y = (False, True, True) 5 | z = (,,) False True True 6 | 7 | a :: (Bool, Bool) 8 | a = (False, True) 9 | 10 | not True = False 11 | not False = True 12 | 13 | f (x, y) = (y, not x) 14 | 15 | g :: (Bool, Bool) -> (,) Bool Bool 16 | g ((,) x y) = (,) (not y) (not x) -------------------------------------------------------------------------------- /tests/tuples2.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | 3 | aa = (True, False) 4 | bb = (True, False, True, True) 5 | 6 | ff (x, y) = (x, not x, y, not y) 7 | 8 | gg :: (Bool, Bool, Bool) -> (Bool, Bool) 9 | gg (x, y, z) = (not z, not y) -------------------------------------------------------------------------------- /tests/typeSynOverlap.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | 3 | type D t = Maybe t 4 | 5 | class C t 6 | instance C (D t) 7 | instance C Bool -------------------------------------------------------------------------------- /tests/unsz.hb: -------------------------------------------------------------------------------- 1 | requires miniprelude 2 | 3 | primitive (:#) :: Bit m -> Bit n -> Bit (m + n) 4 | 5 | unsz :: n < 33 => Bit n -> Bit 32 6 | unsz x = 0 :# x 7 | 8 | main () = unsz (1 :: Bit 15) -------------------------------------------------------------------------------- /tests/zerobitdata.hb: -------------------------------------------------------------------------------- 1 | requires minprel 2 | 3 | bitdata Foo /32 = Foo [ 0 | x :: Bit 4 ] 4 | 5 | -- It would also be nice to allow this syntax ... 6 | -- bitdata Bar = Bar [ 0 :: Bit 32 ] 7 | --------------------------------------------------------------------------------