ref: 968dcee532429345c0aa50eb05100e8925b55341
parent: 1b5181f9a1712712fb2628553079a3af25532d12
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Sat Oct 28 09:21:36 EDT 2023
Start of type inference for local defs.
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v4.0
-1129
-((A :0 _952) ((A :1 ((B _998) _0)) ((A :2 (((S' _998) _0) I)) ((A :3 _922) ((A :4 (_3 "undefined")) ((A :5 I) ((A :6 (((C' B) _951) ((C _84) _5))) ((A :7 (((C' _6) (_969 _73)) ((_84 _967) _72))) ((A :8 ((B ((S _998) _967)) _3)) ((A :9 T) ((A :10 (T I)) ((A :11 ((B (_84 _210)) _10)) ((A :12 ((B (B (_82 _9))) (((C' B) ((B C) _10)) (B _10)))) ((A :13 ((B (B (_82 _9))) (((C' B) ((B C) _10)) (BK _10)))) ((A :14 ((B (_82 _9)) P)) ((A :15 ((B (B (_82 _9))) ((B ((C' C) _10)) (B P)))) ((A :16 _15) ((A :17 (((C' B) _12) (((C' B) _12) (B _14)))) ((A :18 ((B (_82 _9)) (B (P _880)))) ((A :19 ((B (_82 _9)) (BK (P _880)))) ((A :20 ((_82 _9) ((S P) I))) ((A :21 ((B (_82 _9)) ((C (S' P)) I))) ((A :22 ((B Y) ((B (B (P (_14 _122)))) (((C' B) ((B (C' B)) (B _12))) (((C' (C' B)) (B _12)) ((B (B _14)) _123)))))) ((A :23 ((B Y) ((B (B (P (_14 _880)))) ((B (C' B)) (B _13))))) ((A :24 _3) ((A :25 (T (_14 _880))) ((A :26 (_22 _85)) ((A :27 (R _34)) ((A :28 (T _33)) ((A :29 ((P _34) _33)) ((A :30 _34) ((A :31 ((C ((C S') _29)) I)) ((A :32 ((C S) _29)) ((A :33 K) ((A :34 A) ((A :35 ((_76 _916) _917)) ((A :36 ((_76 _926) (_80 _36))) ((A :37 _927) ((A :38 _928) ((A :39 (((S' _28) (_919 #97)) ((C _919) #122))) ((A :40 (((S' _28) (_919 #65)) ((C _919) #90))) ((A :41 (((S' _27) _39) _40)) ((A :42 (((S' _28) (_919 #48)) ((C _919) #57))) ((A :43 (((S' _28) (_919 #32)) ((C _919) #126))) ((A :44 _916) ((A :45 _917) ((A :46 _919) ((A :47 _918) ((A :48 (((S' _27) ((C (_77 _35)) #32)) (((S' _27) ((C (_77 _35)) #9)) ((C (_77 _35)) #10)))) ((A :49 ((S ((S (((S' _28) (_46 #65)) ((C _46) #90))) (_34 (((_879 "lib/Data/Char.hs") #3) #8)))) ((B _37) (((C' _91) (((C' _92) _38) (_38 #65))) (_38 #97))))) ((A :50 ((S ((S (((S' _28) (_46 #97)) ((C _46) #97))) (_34 (((_879 "lib/Data/Char.hs") #3) #8)))) ((B _37) (((C' _91) (((C' _92) _38) (_38 #97))) (_38 #65))))) ((A :51 _887) ((A :52 _888) ((A :53 _889) ((A :54 _890) ((A :55 (_52 %0.0)) ((A :56 _51) ((A :57 _52) ((A :58 _53) ((A :59 _54) ((A :60 ((_76 _891) _892)) ((A :61 (_77 _60)) ((A :62 (_78 _60)) ((A :63 _893) ((A :64 _894) ((A :65 _895) ((A :66 _896) ((A :67 _63) ((A :68 _64) ((A :69 _65) ((A :70 _66) ((A :71 _897) ((A :72 ((B BK) T)) ((A :73 (BK T)) ((A :74 (((S' _76) (((S' C) ((B (C S')) (((C' C) ((B (C C')) ((B _77) (T K)))) (K _33)))) ((B ((C' B) (T (K _33)))) ((B _77) (T A))))) ((B _80) ((B _74) (((S' P) (T K)) (T A)))))) ((A :75 P) ((A :76 P) ((A :77 (T K)) ((A :78 (T A)) ((A :79 (K (noDefault "Eq.=="))) ((A :80 ((B (B (B _29))) _77)) ((A :81 ((_76 ((C ((C S') _29)) I)) (_80 _81))) ((A :82 I) ((A :83 (S _924)) ((A :84 B) ((A :85 I) ((A :86 K) ((A :87 C) ((A :88 _923) ((A :89 ((C ((C S') _210)) _211)) ((A :90 (((C' (S' (C' B))) B) I)) ((A :91 _881) ((A :92 _882) ((A :93 _883) ((A :94 _884) ((A :95 _885) ((A :96 _886) ((A :97 (_92 #0)) ((A :98 ((_76 _904) _905)) ((A :99 _906) ((A :100 _907) ((A :101 _908) ((A :102 _909) ((A :103 (BK K)) ((A :104 ((B BK) ((B (B BK)) P))) ((A :105 ((B (B (B BK))) ((B (B (B BK))) ((B (B (B C))) ((B (B C)) P))))) ((A :106 (((S' S) (((S' (S' C)) (((C' (C' S)) (((C' B) ((B (S' S')) (((C' B) ((B _27) (_100 #0))) ((C (_77 _98)) #0)))) ((B (B ((C' P) (_96 #1)))) _91))) (C P))) _94)) _95)) ((A :107 _103) ((A :108 (((S' C) ((B (P _197)) (((C' (C' B)) (((C' C) (_77 _98)) _197)) _198))) ((B ((C' (C' (C' C))) (((C' (C' (C' C))) (((C' (C' (C' (C' S')))) ((B (B (B (B C)))) ((B ((C' (C' (C' C))) ((B (B (B ((S' S') ((C (_77 _98)) #0))))) ((B ((C' (C' C)) ((B (B ((S' S') ((C (_77 _98)) #1)))) ((B ((C' C) ((B ((C' S') ((C (_77 _98)) #2))) (C _108)))) (C _108))))) (C _108))))) (C _108)))) (T K))) (T A)))) ((C _106) #4)))) ((A :109 (_115 _86)) ((A :110 ((_131 (_89 _109)) _107)) ((A :111 ((C (((C' B) ((P _122) (((C' (C' O)) P) K))) (((S' (C' (C' (C' B)))) ((B (B (B (B _112)))) (((S' (C' (C' B))) ((B (B (B _112))) (((S' (C' B)) ((B (B _112)) (((C' B) ((B _129) (T #0))) _111))) (((C' B) ((B _129) (T #1))) _111)))) (((C' B) ((B _129) (T #2))) _111)))) (((C' B) ((B _129) (T #3))) _111)))) ((B T) ((B (B P)) ((C' _91) (_93 #4)))))) ((A :112 ((S S) ((B BK) ((B BK) (((S' S) T) ((B BK) ((B BK) ((C (((S' C')
\ No newline at end of file
+1138
+((A :0 _961) ((A :1 ((B _1007) _0)) ((A :2 (((S' _1007) _0) I)) ((A :3 _931) ((A :4 (_3 "undefined")) ((A :5 I) ((A :6 (((C' B) _960) ((C _84) _5))) ((A :7 (((C' _6) (_978 _73)) ((_84 _976) _72))) ((A :8 ((B ((S _1007) _976)) _3)) ((A :9 T) ((A :10 (T I)) ((A :11 ((B (_84 _210)) _10)) ((A :12 ((B (B (_82 _9))) (((C' B) ((B C) _10)) (B _10)))) ((A :13 ((B (B (_82 _9))) (((C' B) ((B C) _10)) (BK _10)))) ((A :14 ((B (_82 _9)) P)) ((A :15 ((B (B (_82 _9))) ((B ((C' C) _10)) (B P)))) ((A :16 _15) ((A :17 (((C' B) _12) (((C' B) _12) (B _14)))) ((A :18 ((B (_82 _9)) (B (P _889)))) ((A :19 ((B (_82 _9)) (BK (P _889)))) ((A :20 ((_82 _9) ((S P) I))) ((A :21 ((B (_82 _9)) ((C (S' P)) I))) ((A :22 ((B Y) ((B (B (P (_14 _122)))) (((C' B) ((B (C' B)) (B _12))) (((C' (C' B)) (B _12)) ((B (B _14)) _123)))))) ((A :23 ((B Y) ((B (B (P (_14 _889)))) ((B (C' B)) (B _13))))) ((A :24 _3) ((A :25 (T (_14 _889))) ((A :26 (_22 _85)) ((A :27 (R _34)) ((A :28 (T _33)) ((A :29 ((P _34) _33)) ((A :30 _34) ((A :31 ((C ((C S') _29)) I)) ((A :32 ((C S) _29)) ((A :33 K) ((A :34 A) ((A :35 ((_76 _925) _926)) ((A :36 ((_76 _935) (_80 _36))) ((A :37 _936) ((A :38 _937) ((A :39 (((S' _28) (_928 #97)) ((C _928) #122))) ((A :40 (((S' _28) (_928 #65)) ((C _928) #90))) ((A :41 (((S' _27) _39) _40)) ((A :42 (((S' _28) (_928 #48)) ((C _928) #57))) ((A :43 (((S' _28) (_928 #32)) ((C _928) #126))) ((A :44 _925) ((A :45 _926) ((A :46 _928) ((A :47 _927) ((A :48 (((S' _27) ((C (_77 _35)) #32)) (((S' _27) ((C (_77 _35)) #9)) ((C (_77 _35)) #10)))) ((A :49 ((S ((S (((S' _28) (_46 #65)) ((C _46) #90))) (_34 (((_888 "lib/Data/Char.hs") #3) #8)))) ((B _37) (((C' _91) (((C' _92) _38) (_38 #65))) (_38 #97))))) ((A :50 ((S ((S (((S' _28) (_46 #97)) ((C _46) #97))) (_34 (((_888 "lib/Data/Char.hs") #3) #8)))) ((B _37) (((C' _91) (((C' _92) _38) (_38 #97))) (_38 #65))))) ((A :51 _896) ((A :52 _897) ((A :53 _898) ((A :54 _899) ((A :55 (_52 %0.0)) ((A :56 _51) ((A :57 _52) ((A :58 _53) ((A :59 _54) ((A :60 ((_76 _900) _901)) ((A :61 (_77 _60)) ((A :62 (_78 _60)) ((A :63 _902) ((A :64 _903) ((A :65 _904) ((A :66 _905) ((A :67 _63) ((A :68 _64) ((A :69 _65) ((A :70 _66) ((A :71 _906) ((A :72 ((B BK) T)) ((A :73 (BK T)) ((A :74 (((S' _76) (((S' C) ((B (C S')) (((C' C) ((B (C C')) ((B _77) (T K)))) (K _33)))) ((B ((C' B) (T (K _33)))) ((B _77) (T A))))) ((B _80) ((B _74) (((S' P) (T K)) (T A)))))) ((A :75 P) ((A :76 P) ((A :77 (T K)) ((A :78 (T A)) ((A :79 (K (noDefault "Eq.=="))) ((A :80 ((B (B (B _29))) _77)) ((A :81 ((_76 ((C ((C S') _29)) I)) (_80 _81))) ((A :82 I) ((A :83 (S _933)) ((A :84 B) ((A :85 I) ((A :86 K) ((A :87 C) ((A :88 _932) ((A :89 ((C ((C S') _210)) _211)) ((A :90 (((C' (S' (C' B))) B) I)) ((A :91 _890) ((A :92 _891) ((A :93 _892) ((A :94 _893) ((A :95 _894) ((A :96 _895) ((A :97 (_92 #0)) ((A :98 ((_76 _913) _914)) ((A :99 _915) ((A :100 _916) ((A :101 _917) ((A :102 _918) ((A :103 (BK K)) ((A :104 ((B BK) ((B (B BK)) P))) ((A :105 ((B (B (B BK))) ((B (B (B BK))) ((B (B (B C))) ((B (B C)) P))))) ((A :106 (((S' S) (((S' (S' C)) (((C' (C' S)) (((C' B) ((B (S' S')) (((C' B) ((B _27) (_100 #0))) ((C (_77 _98)) #0)))) ((B (B ((C' P) (_96 #1)))) _91))) (C P))) _94)) _95)) ((A :107 _103) ((A :108 (((S' C) ((B (P _197)) (((C' (C' B)) (((C' C) (_77 _98)) _197)) _198))) ((B ((C' (C' (C' C))) (((C' (C' (C' C))) (((C' (C' (C' (C' S')))) ((B (B (B (B C)))) ((B ((C' (C' (C' C))) ((B (B (B ((S' S') ((C (_77 _98)) #0))))) ((B ((C' (C' C)) ((B (B ((S' S') ((C (_77 _98)) #1)))) ((B ((C' C) ((B ((C' S') ((C (_77 _98)) #2))) (C _108)))) (C _108))))) (C _108))))) (C _108)))) (T K))) (T A)))) ((C _106) #4)))) ((A :109 (_115 _86)) ((A :110 ((_131 (_89 _109)) _107)) ((A :111 ((C (((C' B) ((P _122) (((C' (C' O)) P) K))) (((S' (C' (C' (C' B)))) ((B (B (B (B _112)))) (((S' (C' (C' B))) ((B (B (B _112))) (((S' (C' B)) ((B (B _112)) (((C' B) ((B _129) (T #0))) _111))) (((C' B) ((B _129) (T #1))) _111)))) (((C' B) ((B _129) (T #2))) _111)))) (((C' B) ((B _129) (T #3))) _111)))) ((B T) ((B (B P)) ((C' _91) (_93 #4)))))) ((A :112 ((S S) ((B BK) ((B BK) (((S' S) T) ((B BK) ((B BK) ((C (((S' C
\ No newline at end of file
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -8,7 +8,7 @@
Expr(..), showExpr,
Listish(..),
Lit(..), showLit, eqLit,
- EBind(..), showEBind,
+ EBind(..), showEBind, showEBinds,
Eqn(..),
EStmt(..),
EAlts(..),
@@ -26,13 +26,16 @@
tupleConstr, getTupleConstr,
mkTupleSel,
subst,
- allVarsExpr, allVarsBind,
+ allVarsExpr, allVarsBind, allVarsEqn,
getSLocExpr, setSLocExpr,
getSLocEqns,
errorMessage,
- Assoc(..), eqAssoc, Fixity
+ Assoc(..), eqAssoc, Fixity,
+-- Free(..),
+ getBindsVars,
) where
import Prelude --Xhiding (Monad(..), Applicative(..), MonadFail(..), Functor(..), (<$>), showString, showChar, showList, (<>))
+--import Data.List
import Data.Maybe
import MicroHs.Ident
import qualified Data.Double as D
@@ -372,6 +375,9 @@
showEBind :: EBind -> String
showEBind = render . ppEBind
+showEBinds :: [EBind] -> String
+showEBinds = render . vcat . map ppEBind
+
showEType :: EType -> String
showEType = render . ppEType
@@ -524,3 +530,80 @@
ppList :: forall a . (a -> Doc) -> [a] -> Doc
ppList pp xs = brackets $ hsep $ punctuate (text ",") (map pp xs)
+
+{-+class Free a where
+ freeV :: a -> [Ident]
+
+instance Free Expr where
+ freeV (EVar v) = [v]
+ freeV (EApp f a) = freeV f `union` freeV a
+ freeV (EOper e ies) = freeV e `union` freeV ies
+ freeV (ELam ps e) = freeV e \\ concatMap patVars ps
+ freeV (ELit _ _) = []
+ freeV (ECase e as) = freeV e `union` freeV as
+ freeV (ELet bs e) = (freeV e \\ bvs) `union` fvs where (bvs, fvs) = freeBinds bs
+ freeV (ETuple es) = freeV es
+ freeV (EListish l) = freeV l
+ freeV (EDo _ ss) = snd $ freeStmts ss
+ freeV (ESectL e i) = freeV e `union` [i]
+ freeV (ESectR i e) = [i] `union` freeV e
+ freeV (EIf e1 e2 e3) = freeV e1 `union` freeV e2 `union` freeV e3
+ freeV (ESign _ e) = freeV e
+ freeV (EAt _ _) = undefined
+ freeV (EUVar _) = undefined
+ freeV (ECon _) = undefined
+ freeV (EForall _ _) = undefined
+
+instance forall a . (Free a) => Free [a] where
+ freeV as = foldr (union . freeV) [] as
+
+instance Free (Ident, Expr) where
+ freeV (i, e) = [i] `union` freeV e
+
+--instance Free ECaseArm where
+instance Free (Expr, EAlts) where
+ freeV (p, as) = freeV as \\ patVars p
+
+instance Free Listish where
+ freeV (LList es) = freeV es
+ freeV (LCompr e ss) = (freeV e \\ bvs) `union` fvs where (bvs, fvs) = freeStmts ss
+ freeV (LFrom e) = freeV e
+ freeV (LFromTo e1 e2) = freeV e1 `union` freeV e2
+ freeV (LFromThen e1 e2) = freeV e1 `union` freeV e2
+ freeV (LFromThenTo e1 e2 e3) = freeV e1 `union` freeV e2 `union` freeV e3
+
+instance Free EAlts where
+ freeV (EAlts as bs) = (freeV as \\ bvs) `union` fvs where (bvs, fvs) = freeBinds bs
+
+instance Free EAlt where
+ freeV (ss, e) = (freeV e \\ bvs) `union` fvs where (bvs, fvs) = freeStmts ss
+
+instance Free Eqn where
+ freeV (Eqn ps a) = freeV a \\ concatMap patVars ps
+
+freeStmts :: [EStmt] -> ([Ident], [Ident])
+freeStmts = loop [] []
+ where loop bvs fvs [] = (bvs, fvs)
+ loop bvs fvs (SBind p e : ss) = loop (patVars p `union` bvs) (fvs `union` (freeV e \\ bvs)) ss
+ loop bvs fvs (SThen e : ss) = loop bvs (fvs `union` (freeV e \\ bvs)) ss
+ loop bvs fvs (SLet bs : ss) = loop (bvs' `union` bvs) (fvs `union` (fvs' \\ bvs)) ss
+ where (bvs', fvs') = freeBinds bs
+
+freeBinds :: [EBind] -> ([Ident], [Ident])
+freeBinds bs = (bvs, foldr (union . fv) [] bs \\ bvs)
+ where bvs = getBindsVars bs
+ fv (BSign _ _) = []
+ fv (BFcn _ x) = freeV x
+ fv (BPat _ x) = freeV x
+-}
+
+getBindVars :: EBind -> [Ident]
+getBindVars abind =
+ case abind of
+ BFcn i _ -> [i]
+ BPat p _ -> patVars p
+ BSign _ _ -> []
+
+getBindsVars :: [EBind] -> [Ident]
+getBindsVars = concatMap getBindVars
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -21,6 +21,7 @@
import qualified MicroHs.IdentMap as M
import MicroHs.Ident
import MicroHs.Expr
+import MicroHs.Graph
--Ximport Compat
--Ximport GHC.Stack
--Ximport Debug.Trace
@@ -143,7 +144,7 @@
filterImports it@(ImportSpec _ _ _ Nothing, _) = it
filterImports (imp@(ImportSpec _ _ _ (Just (hide, is))), TModule mn fx ts ss cs ins vs a) =
let
- keep x xs = elem x xs `neBool` hide
+ keep x xs = elemBy eqIdent x xs `neBool` hide
ivs = [ i | ImpValue i <- is ]
vs' = filter (\ (ValueExport i _) -> keep i ivs) vs
cts = [ i | ImpTypeCon i <- is ]
@@ -781,6 +782,16 @@
venv <- gets valueTable
putValueTable (stInsertLcl i (Entry e t) venv)
+{-+withExtValEs :: forall a . [(Ident, EType, Expr)] -> T a -> T a
+withExtValEs ites ta = T.do
+ venv <- gets valueTable
+ putValueTable $ foldr (\ (i, t, e) -> M.insert i [Entry e t]) venv ites
+ a <- ta
+ putValueTable venv
+ T.return a
+-}
+
-- Extend the global symbol table with i = e :: t
-- Add both qualified and unqualified versions of i.
extValETop :: --XHasCallStack =>
@@ -1186,10 +1197,10 @@
Fcn i eqns -> T.do
(_, tt) <- tLookup "type signature" i
-- traceM $ "tcDefValue: " ++ showIdent i ++ " :: " ++ showExpr tt
--- traceM $ showEDefs [adef]
+-- traceM $ "tcDefValue: def=" ++ showEDefs [adef]
mn <- gets moduleName
teqns <- tcEqns tt eqns
--- traceM (showEDefs [Fcn i eqns, Fcn i teqns])
+-- traceM ("tcDefValue: after " ++ showEDefs [adef, Fcn i teqns])checkConstraints
T.return $ Fcn (qualIdent mn i) teqns
ForImp ie i t -> T.do
@@ -1287,10 +1298,9 @@
tcExpr :: --XHasCallStack =>
Expected -> Expr -> T Expr
tcExpr mt ae = T.do
--- traceM ("tcExpr enter: " ++ showExpr ae ++ " :: " ++ showMaybe showExpr mt)+-- traceM ("tcExpr enter: " ++ showExpr ae)r <- tcExprR mt ae
--- t <- expandType (snd r)
--- traceM ("tcExpr exit: " ++ showExpr (fst r) ++ " :: " ++ showExpr t)+-- traceM ("tcExpr exit: " ++ showExpr r)T.return r
tcExprR :: --XHasCallStack =>
Expected -> Expr -> T Expr
@@ -1299,6 +1309,7 @@
case ae of
EVar i -> T.do
tcm <- gets tcMode
+-- traceM ("EVar mode=" ++ show tcm)case tcm of
TCPat | isDummyIdent i -> T.do
-- _ can be anything, so just ignore it
@@ -1590,7 +1601,11 @@
tcAlts :: EType -> EAlts -> T EAlts
tcAlts tt (EAlts alts bs) =
- tcBinds bs $ \ bbs -> T.do { aalts <- T.mapM (tcAlt tt) alts; T.return (EAlts aalts bbs) }+-- trace ("tcAlts: bs in " ++ showEBinds bs) $+ tcBinds bs $ \ bbs -> T.do
+-- traceM ("tcAlts: bs out " ++ showEBinds bbs)+ aalts <- T.mapM (tcAlt tt) alts
+ T.return (EAlts aalts bbs)
tcAlt :: EType -> EAlt -> T EAlt
--tcAlt t (_, rhs) | trace ("tcAlt: " ++ showExpr rhs ++ " :: " ++ showEType t) False = undefined@@ -1683,26 +1698,112 @@
check0 = if n /= 0 then tcError (getSLocExpr p) "Bad pattern" else T.return ()
tcBinds :: forall a . [EBind] -> ([EBind] -> T a) -> T a
-tcBinds xbs ta = T.do
+tcBinds binds ta = T.do
let
- tmap = M.fromList [ (i, t) | BSign i t <- xbs ]
- xs = concatMap getBindVars xbs
+ signs = [ (i, t) | BSign i t <- binds ]
+ xs = getBindsVars binds
+-- traceM ("tcBinds: xs=" ++ showList showIdent xs)multCheck xs
- xts <- T.mapM (tcBindVarT tmap) xs
- withExtVals xts $ T.do
- nbs <- T.mapM tcBind xbs
- ta nbs
+ -- Kind check all the signatures
+ tmap <- M.fromList <$> T.mapM (\ (i, t) -> withTypeTable $ (i,) <$> tcTypeT (Check kType) t) signs
+ -- Split into defns with and without signatures.
+ -- Pattern bindings are always considered as no signatures.
+ let (hasSign, noSign) = loop [] [] binds
+ --loop :: [(Ident, EType, [Eqn])] -> [EBind] -> [EBind] -> ([(Ident, EType, [Eqn])], [EBind])
+ loop s ns [] = (s, ns)
+ loop s ns (BSign _ _ : bs) = loop s ns bs
+ loop s ns (b@(BPat _ _) : bs) = loop s (b:ns) bs
+ loop s ns (b@(BFcn i q) : bs) | Just t <- M.lookup i tmap = loop ((i, t, q):s) ns bs
+ | otherwise = loop s (b:ns) bs
-tcBindVarT :: M.Map EType -> Ident -> T (Ident, EType)
+ -- Make the environment from the signatures.
+ let its = map (\ (i, t, _) -> (i, t)) hasSign
+ withExtVals its $
+ tcBindGrps (sccBinds noSign) [] $ \ nbs -> T.do
+ let tcFcn (i, t, q) = T.do { q' <- tcEqns t q; T.return (BFcn i q') }+ -- Finally type check the functions with signatures.
+ -- All other bindings are in the environment at this point.
+ sbs <- T.mapM tcFcn hasSign
+ ta (sbs ++ nbs)
+
+{-+tcBindVarT :: M.Map EType -> Ident -> T (Ident, EType, Expr)
tcBindVarT tmap x = T.do
case M.lookup x tmap of
Nothing -> T.do
t <- newUVar
- T.return (x, t)
+ ie <- newIdent (getSLocIdent x) "q"
+ T.return (x, t, EApp (EVar ie) (EVar x))
Just t -> T.do
tt <- withTypeTable $ tcTypeT (Check kType) t
- T.return (x, tt)
+ T.return (x, tt, EVar x)
+-}
+-- Split binding into strongly connected components.
+-- BPat complicates things. It's a node with many labels.
+-- Fake it by giving it a unique label, and have all the other
+-- labels point to the unique label.
+sccBinds :: [EBind] -> [SCC EBind]
+sccBinds binds =
+ let node _ b@(BFcn i eqns) = [(Just b, i, freeEqns eqns)]
+ node i b@(BPat p e) =
+ let v = mkIdent (showInt i)
+ in (Just b, v, freeExpr e) : [ (Nothing, x, [v]) | x <- patVars p ]
+ node _ _ = []
+ gr = concat $ zipWith node [0 ..] binds
+ -- Remove the Just/Nothing inserted above
+ un (AcyclicSCC Nothing) = []
+ un (AcyclicSCC (Just b)) = [AcyclicSCC b]
+ un (CyclicSCC bs) = [CyclicSCC $ catMaybes bs]
+ in concatMap un $ stronglyConnComp leIdent gr
+
+-- This is an approximation that works for SCC.
+-- It only means that some SCCs might be bigger.
+freeEqns :: [Eqn] -> [Ident]
+freeEqns = concatMap allVarsEqn
+freeExpr :: Expr -> [Ident]
+freeExpr = allVarsExpr
+
+tcBindGrps :: forall a . [SCC EBind] -> [EBind] -> ([EBind] -> T a) -> T a
+--tcBindGrps xs rbs _ | trace ("tcBindGrps: " ++ show (xs, rbs)) False = undefined+tcBindGrps [] rbs ta = ta rbs
+tcBindGrps (bs:bss) rbs ta =
+ tcBindGrp bs $ \ bs' ->
+ tcBindGrps bss (bs' ++ rbs) ta
+
+tcBindGrp :: forall a . SCC EBind -> ([EBind] -> T a) -> T a
+--tcBindGrp x _ | trace ("tcBindGrp: " ++ show x) False = undefined+tcBindGrp (AcyclicSCC (BPat p a)) ta = T.do
+ its <- T.mapM (\ i -> (i,) <$> newUVar) (patVars p)
+ withExtVals its $ T.do
+ (ep, tp) <- withTCMode TCPat $ tInferExpr p -- pattern variables already bound
+ ea <- tCheckExpr tp a
+ ta [BPat ep ea]
+tcBindGrp (AcyclicSCC (BFcn i eqns)) ta = T.do
+ t <- newUVar
+-- traceM ("tcBindGrp: t=" ++ showEType t)+ eqns' <- tcEqns t eqns
+-- withExtVals [(i, t)] $ ta [BFcn i eqns']
+-- tt <- derefUVar t
+-- traceM ("tcBindGrp: eqns done t=" ++ showEType tt)+ env_tys <- getEnvTypes
+-- traceM ("tcBindGrp: AcyclicSCC env_tys = " ++ showList showEType env_tys)+ env_tvs <- getMetaTyVars env_tys
+-- traceM ("tcBindGrp: AcyclicSCC env_tvs = " ++ showList showInt env_tvs)+ res_tvs <- getMetaTyVars [t]
+-- traceM ("tcBindGrp: AcyclicSCC res_tvs = " ++ showList showInt res_tvs)+ ty <- quantify (res_tvs \\ env_tvs) t
+-- traceM ("***** tcBindGrp: " ++ showIdent i ++ " :: " ++ showEType ty)+ withExtVals [(i, ty)] $ ta [BFcn i eqns']
+
+tcBindGrp (CyclicSCC bs) ta = T.do
+ its <- T.mapM (\ i -> (i,) <$> newUVar) $ getBindsVars bs
+ withExtVals its $ T.do
+ bs' <- T.mapM tcBind bs
+ -- XXX generalize, update its
+ ta bs'
+tcBindGrp _ _ = impossible
+
tcBind :: EBind -> T EBind
tcBind abind =
case abind of
@@ -1716,13 +1817,6 @@
T.return $ BPat ep ea
BSign _ _ -> T.return abind
-getBindVars :: EBind -> [Ident]
-getBindVars abind =
- case abind of
- BFcn i _ -> [i]
- BPat p _ -> patVars p
- BSign _ _ -> []
-
-- Desugar [T] and (T,T,...)
dsType :: EType -> EType
dsType at =
@@ -1778,23 +1872,23 @@
getEnvTypes :: T [EType]
getEnvTypes = gets (map entryType . stElemsLcl . valueTable)
-{--quantify :: [MetaTv] -> Rho -> T Sigma
+quantify :: [TRef] -> Rho -> T Sigma
-- Quantify over the specified type variables (all flexible)
+quantify [] ty = T.return ty
quantify tvs ty = T.do
- T.mapM_ bind (tvs `zip` new_bndrs) -- 'bind' is just a cunning way
- ty' <- zonkType ty -- of doing the substitution
- T.return (EForall new_bndrs_kind ty')
- where
- used_bndrs = tyVarBndrs ty -- Avoid quantified type variables in use
- new_bndrs = deleteFirstsBy eqIdent allBinders used_bndrs
- bind (tv, name) = writeTcRef tv (EVar name)
- new_bndrs_kind = map (\ i -> IdKind i undefined) new_bndrs
+ let
+ used_bndrs = tyVarBndrs ty -- Avoid quantified type variables in use XXX use ty'?
+ new_bndrs = take (length tvs) (allBinders \\ used_bndrs)
+ bind (tv, name) = setUVar tv (EVar name)
+ new_bndrs_kind = map (\ i -> IdKind i (EUVar 0)) new_bndrs
+-- traceM ("quantify: used_bndrs=" ++ showList showIdent used_bndrs)+ T.mapM_ bind (tvs `zip` new_bndrs) -- 'bind' is just a cunning way
+ ty' <- derefUVar ty -- of doing the substitution
+ T.return (EForall new_bndrs_kind ty')
allBinders :: [Ident] -- a,b,..z, a1, b1,... z1, a2, b2,...
allBinders = [ mkIdent [chr x] | x <- [ord 'a' .. ord 'z'] ] ++
[ mkIdent (chr x : showInt i) | i <- [1 ..], x <- [ord 'a' .. ord 'z']]
--}
skolemise :: --XHasCallStack =>
Sigma -> T ([TyVar], Rho)
@@ -1850,17 +1944,18 @@
go (EApp fun arg) acc = go fun (go arg acc)
go _ _ = undefined
-{-tyVarBndrs :: Rho -> [TyVar]
-- Get all the binders used in ForAlls in the type, so that
-- when quantifying an outer for-all we can avoid these inner ones
-tyVarBndrs ty = nubBy eqIdent (bndrs ty)
+tyVarBndrs ty = nub (bndrs ty)
where
bndrs (EForall tvs body) = map idKindIdent tvs ++ bndrs body
bndrs (EApp arg res) = bndrs arg ++ bndrs res
bndrs (EVar _) = []
- bndrs _ = undefined
+ bndrs (EUVar _) = []
+ bndrs t = error $ showEType t
+{-inferSigma :: Expr -> T (Expr, Sigma)
inferSigma e = T.do
(e', exp_ty) <- inferRho e
--- a/tests/Class.hs
+++ b/tests/Class.hs
@@ -1,4 +1,5 @@
module Class(main) where
+import Primitives
import Prelude
class Eqq a where
@@ -7,10 +8,10 @@
x /== y = not (x === y)
instance Eqq Int where
- (===) = (==)
+ (===) = primIntEQ
instance Eqq Char where
- (===) = eqChar
+ (===) = primCharEQ
instance forall a . Eqq a => Eqq [a] where
[] === [] = True
--
⑨