ref: 9779f4db8b850a7dce62bcc4a620882090ac429d
parent: 1e05744846ac152bcc1150ce27c89554a551abed
author: Lennart Augustsson <lennart@augustsson.net>
date: Fri Nov 17 15:37:18 EST 2023
Make it compile
--- a/Makefile
+++ b/Makefile
@@ -93,9 +93,6 @@
everytest: runtest bootcombtest
-runtest: bin/mhseval bin/gmhs tests/*.hs
- cd tests; make alltest
-
bootcombtest: bin/gmhs bin/mhseval
bin/gmhs -ilib -isrc -ogmhs.comb MicroHs.Main
bin/mhseval +RTS -v -rgmhs.comb -RTS -ilib -isrc -omhs.comb MicroHs.Main
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -1610,6 +1610,9 @@
getFixity :: FixTable -> Ident -> Fixity
getFixity fixs i = fromMaybe (AssocLeft, 9) $ M.lookup i fixs
+newDictIdent :: SLoc -> T Ident
+newDictIdent loc = newIdent loc "adict"
+
tcPats :: forall a . EType -> [EPat] -> (EType -> [EPat] -> T a) -> T a
tcPats t [] ta = ta t []
tcPats t (p:ps) ta = do
@@ -1626,7 +1629,7 @@
tcEqns top (EForall iks t) eqns = withExtTyps iks $ tcEqns top t eqns
tcEqns top t eqns | Just (ctx, t') <- getImplies t = do
let loc = getSLoc eqns
- d <- newIdent loc "adict"
+ d <- newDictIdent loc
f <- newIdent loc "fcnD"
withDict d ctx $ do
eqns' <- tcEqns top t' eqns
@@ -1719,6 +1722,7 @@
withExtVals env $ do
(_sks, ds, pp) <- tCheckPat t ap
() <- checkArity 0 pp
+-- traceM ("tCheckPatC " ++ show ds)withDicts ds $
ta pp
@@ -1747,13 +1751,19 @@
(_, EForall _ (EForall _ _)) -> return ()
_ -> undefined
(ap, EForall avs apt) <- tInst' ipt
- (_sks, spt) <- shallowSkolemise avs apt
- (p, pt) <- xxxx (ap, spt)
+ (sks, spt) <- shallowSkolemise avs apt
+ (d, p, pt) <-
+ case getImplies spt of
+ Nothing -> return ([], ap, apt)
+ Just (ctx, pt') -> do
+ di <- newDictIdent loc
+ return ([(di, ctx)], EApp ap (EVar i), pt')
+
-- We will only have an expected type for a non-nullary constructor
pp <- case mt of
Check ext -> subsCheck loc p ext pt
Infer r -> do { tSetRefType loc r pt; return p }- return ([], [], pp)
+ return (sks, d, pp)
| otherwise -> do
-- All pattern variables are in the environment as
--
⑨