rc (#13)
* update readme * Literal -> Lit, LitE -> Lit * commentary * infer * hindley milner inference :D * comments and better type errors * type IsString + test unification error * infer nonrec let binds infer nonrec let binds * small * LitE -> Lit * LitE -> Lit * TyInt -> TyCon "Int#" * parse type sigs; program type sigs * parse types * parse programs (with types :D) * parse programs (with type sigs :D) * Name = Text Name = Text * RlpcError * i'm on an airplane rn, my eyelids grow heavy, and i forgot my medication. should this be my final commit (of the week): gootbye * kinda sorta typechecking * back and medicated! * errorful (it's not good) * type-checked quasiquoters * fix hm tests * Compiler.JustRun * lex \ instead of \\ * grammar reference * 4:00 AM psychopath code * oh boy am i going to hate this code in 12 hours * application and lits appl * something * goofy * Show1 instances * fixation fufilled - back to work! * works * labels * infix decl * expr fixups * where * cool * aaaaa * decls fix * finally in a decent state * replace uses of many+satisfy with takeWhileP * layout layouts oh my layouts * i did not realise my fs is case insensitive * tysigs * add version bounds * grammar reference * 4:00 AM psychopath code * oh boy am i going to hate this code in 12 hours * application and lits appl * something * goofy * Show1 instances * fixation fufilled - back to work! * works * labels * infix decl * expr fixups * where * cool * aaaaa * decls fix * finally in a decent state * replace uses of many+satisfy with takeWhileP * layout layouts oh my layouts * i did not realise my fs is case insensitive * tysigs * its fine * threaded lexer * decent starting point * man this sucks * aagh * okay layouts kinda * kitten i'll be honest mommy's about to kill herself * see previous commit and scale back the part where i'm joking * version bounds * we're so back * fixy * cool * FIX REAL * oh my god * works * now we're fucking GETTING SOMEWHERE * i really need to learn git proper * infix exprs * remove debug flags * renamerlp * rename rlp * compiles (kill me) man * RlpcError -> IsRlpcError * when the "Test suite rlp-test: PASS" hits i'm like atlas and the world is writing two lines of code * errorful parser * errorful parser small * msgenvelope * errors! * allow uppercase sc names in preperation for Rlp2Core * letrec * infer letrec expressions * minor docs * checklist * minor docs * stable enough for a demo hey? * small fixups * new tag syntax; preparing for Core patterns new tag syntax; preparing for data names * temporary pragma system * resolve named data in case exprs * named constr tests * nearing release :3 * minor changes putting this on hold; implementing TTG first * some * oh my god guys!!! `Located` is a lax semimonoidal endofunctor on the category Hask!!!  * it's also a comonad. lol. * idk * show * abandon ship * at long last more no more undefineds * i should've made a lisp man this sucks * let layout * ttg boilerplate * fixup! ttg boilerplate * fixup! ttg boilerplate * organisation and cleaning organisation and tidying * error messages * driver progress * formatting * *R functions * -ddump-ast * debug tags * -ddump-eval * core driver * XRec fix * rlp2core base * ccoool * something * rlp TH * sc * expandableAlt * expandableAlt * fix layout_let * parse case exprs * case unrolling * rose * her light cuts deep time and time again ('her' of course referring to the field of computer science) * tidying * NameSupply effect * tidy * fix incomplete byTag * desugar * WIP associate postproc corecursive * sigh i'm gonna have to nuke the ast again in a month * remove old files * remove old files * fix top-level layout * define datatags * diagram * diagram * Update README.md * ppr debug flags ddump-parsed * ppr typesigs * ppr datatags * remove unnecessary comment * tidying * .hs -> .cr update examples * fix evil parser bug (it was a fucking typo) * fix evil lexer bug (it was actually quite subtle unlike prev.) * examples * examples * letrec + typechecking core * Update README.md * Rlp2Core: simple let binds * Rlp2Core: pattern let binds * small core fixes * update examples * formatting * typed coreExpr quoter * typechecking things * lt * decent state! * constants for bool tags * print# gm primitive * bind VarP after pats * fix: tag nested data names * gte gm prim * more nightmare GM fixes * QuickSort example works i'm gonig to cry * remove debug code * remove debug tracers * ready? * update readme * remove bad, incorrct, outdated docs --------- Co-authored-by: crumbtoo <crumb@disroot.org>
This commit was merged in pull request #13.
This commit is contained in:
crumb
@@ -6,6 +6,7 @@ module Arith
|
||||
) where
|
||||
----------------------------------------------------------------------------------
|
||||
import Data.Functor.Classes (eq1)
|
||||
import Lens.Micro
|
||||
import Core.Syntax
|
||||
import GM
|
||||
import Test.QuickCheck
|
||||
@@ -40,6 +41,7 @@ evalArith (a ::* b) = evalArith a * evalArith b
|
||||
evalArith (a ::- b) = evalArith a - evalArith b
|
||||
|
||||
instance Arbitrary ArithExpr where
|
||||
-- TODO: implement shrink
|
||||
arbitrary = gen 4
|
||||
where
|
||||
gen :: Int -> Gen ArithExpr
|
||||
@@ -70,13 +72,13 @@ instance Arbitrary ArithExpr where
|
||||
-- coreResult = evalCore (toCore e)
|
||||
|
||||
toCore :: ArithExpr -> Program'
|
||||
toCore expr = Program
|
||||
toCore expr = mempty & programScDefs .~
|
||||
[ ScDef "id" ["x"] $ Var "x"
|
||||
, ScDef "main" [] $ go expr
|
||||
]
|
||||
where
|
||||
go :: ArithExpr -> Expr'
|
||||
go (IntA n) = LitE (IntL n)
|
||||
go (IntA n) = Lit (IntL n)
|
||||
go (NegateA e) = "negate#" :$ go e
|
||||
go (IdA e) = "id" :$ go e
|
||||
go (a :+ b) = f "+#" a b
|
||||
|
||||
62
tst/Core/HindleyMilnerSpec.hs
Normal file
62
tst/Core/HindleyMilnerSpec.hs
Normal file
@@ -0,0 +1,62 @@
|
||||
{-# LANGUAGE QuasiQuotes, OverloadedStrings #-}
|
||||
module Core.HindleyMilnerSpec
|
||||
( spec
|
||||
)
|
||||
where
|
||||
----------------------------------------------------------------------------------
|
||||
import Core.Syntax
|
||||
import Core.TH (coreExpr)
|
||||
import Core.HindleyMilner
|
||||
import Control.Monad.Errorful
|
||||
import Data.Either (isLeft)
|
||||
import Test.Hspec
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
-- TODO: more tests. preferrably property-based. lol.
|
||||
spec :: Spec
|
||||
spec = do
|
||||
it "should infer `id 3` :: Int" $
|
||||
let g = [ ("id", "a" :-> "a") ]
|
||||
in infer' g [coreExpr|id 3|] `shouldBe` Right TyInt
|
||||
|
||||
it "should not infer `id 3` when `id` is specialised to `a -> a`" $
|
||||
let g = [ ("id", ("a" :-> "a") :-> "a" :-> "a") ]
|
||||
in infer' g [coreExpr|id 3|] `shouldSatisfy` isLeft
|
||||
|
||||
-- TODO: property-based tests for let
|
||||
it "should infer `let x = 3 in id x` :: Int" $
|
||||
let g = [ ("id", "a" :-> "a") ]
|
||||
e = [coreExpr|let {x = 3} in id x|]
|
||||
in infer' g e `shouldBe` Right TyInt
|
||||
|
||||
it "should infer `let x = 3; y = 2 in (+#) x y` :: Int" $
|
||||
let g = [ ("+#", TyInt :-> TyInt :-> TyInt) ]
|
||||
e = [coreExpr|let {x=3;y=2} in (+#) x y|]
|
||||
in infer' g e `shouldBe` Right TyInt
|
||||
|
||||
it "should find `3 :: Bool` contradictory" $
|
||||
let e = [coreExpr|3|]
|
||||
in check' [] (TyCon "Bool") e `shouldSatisfy` isLeft
|
||||
|
||||
it "should infer `fix ((+#) 1)` :: Int" $
|
||||
let g = [ ("fix", ("a" :-> "a") :-> "a")
|
||||
, ("+#", TyInt :-> TyInt :-> TyInt) ]
|
||||
e = [coreExpr|fix ((+#) 1)|]
|
||||
in infer' g e `shouldBe` Right TyInt
|
||||
|
||||
it "should infer mutually recursively defined lists" $
|
||||
let g = [ ("cons", TyInt :-> TyCon "IntList" :-> TyCon "IntList") ]
|
||||
e :: Expr'
|
||||
e = [coreExpr|letrec { as = cons 1 bs; bs = cons 2 as } in as|]
|
||||
in infer' g e `shouldBe` Right (TyCon "IntList")
|
||||
|
||||
infer' :: Context' -> Expr' -> Either [TypeError] Type
|
||||
infer' g e = case runErrorful $ infer g e of
|
||||
(Just t, _) -> Right t
|
||||
(Nothing, es) -> Left es
|
||||
|
||||
check' :: Context' -> Type -> Expr' -> Either [TypeError] ()
|
||||
check' g t e = case runErrorful $ check g t e of
|
||||
(Just t, _) -> Right ()
|
||||
(Nothing, es) -> Left es
|
||||
|
||||
@@ -27,15 +27,22 @@ spec = do
|
||||
in coreRes `shouldBe` arithRes
|
||||
|
||||
describe "test programs" $ do
|
||||
it "fac 3" $ do
|
||||
it "fac 3" $
|
||||
resultOf Ex.fac3 `shouldBe` Just (NNum 6)
|
||||
|
||||
it "sum [1,2,3]" $ do
|
||||
it "sum [1,2,3]" $
|
||||
resultOf Ex.sumList `shouldBe` Just (NNum 6)
|
||||
|
||||
it "k 3 ((/#) 1 0)" $ do
|
||||
it "k 3 ((/#) 1 0)" $
|
||||
resultOf Ex.constDivZero `shouldBe` Just (NNum 3)
|
||||
|
||||
it "id (case ... of { ... })" $ do
|
||||
it "id (case ... of { ... })" $
|
||||
resultOf Ex.idCase `shouldBe` Just (NNum 5)
|
||||
|
||||
it "bool pattern matching with named constructors" $
|
||||
resultOf Ex.namedBoolCase `shouldBe` Just (NNum 123)
|
||||
|
||||
it "list pattern matching with named constructors" $
|
||||
resultOf Ex.namedConsCase `shouldBe` Just (NNum 6)
|
||||
|
||||
|
||||
|
||||
Reference in New Issue
Block a user