ref: b4cd0bad3cab41cce85380c127b26af6a8dd083b
parent: 968dcee532429345c0aa50eb05100e8925b55341
author: Lennart Augustsson <lennart@augustsson.net>
date: Sat Oct 28 12:42:34 EDT 2023
Revert "Start of type inference for local defs." This reverts commit 968dcee532429345c0aa50eb05100e8925b55341.
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v4.0
-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
+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
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -8,7 +8,7 @@
Expr(..), showExpr,
Listish(..),
Lit(..), showLit, eqLit,
- EBind(..), showEBind, showEBinds,
+ EBind(..), showEBind,
Eqn(..),
EStmt(..),
EAlts(..),
@@ -26,16 +26,13 @@
tupleConstr, getTupleConstr,
mkTupleSel,
subst,
- allVarsExpr, allVarsBind, allVarsEqn,
+ allVarsExpr, allVarsBind,
getSLocExpr, setSLocExpr,
getSLocEqns,
errorMessage,
- Assoc(..), eqAssoc, Fixity,
--- Free(..),
- getBindsVars,
+ Assoc(..), eqAssoc, Fixity
) 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
@@ -375,9 +372,6 @@
showEBind :: EBind -> String
showEBind = render . ppEBind
-showEBinds :: [EBind] -> String
-showEBinds = render . vcat . map ppEBind
-
showEType :: EType -> String
showEType = render . ppEType
@@ -530,80 +524,3 @@
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,7 +21,6 @@
import qualified MicroHs.IdentMap as M
import MicroHs.Ident
import MicroHs.Expr
-import MicroHs.Graph
--Ximport Compat
--Ximport GHC.Stack
--Ximport Debug.Trace
@@ -144,7 +143,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 = elemBy eqIdent x xs `neBool` hide
+ keep x xs = elem x xs `neBool` hide
ivs = [ i | ImpValue i <- is ]
vs' = filter (\ (ValueExport i _) -> keep i ivs) vs
cts = [ i | ImpTypeCon i <- is ]
@@ -782,16 +781,6 @@
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 =>
@@ -1197,10 +1186,10 @@
Fcn i eqns -> T.do
(_, tt) <- tLookup "type signature" i
-- traceM $ "tcDefValue: " ++ showIdent i ++ " :: " ++ showExpr tt
--- traceM $ "tcDefValue: def=" ++ showEDefs [adef]
+-- traceM $ showEDefs [adef]
mn <- gets moduleName
teqns <- tcEqns tt eqns
--- traceM ("tcDefValue: after " ++ showEDefs [adef, Fcn i teqns])+-- traceM (showEDefs [Fcn i eqns, Fcn i teqns])
checkConstraints
T.return $ Fcn (qualIdent mn i) teqns
ForImp ie i t -> T.do
@@ -1298,9 +1287,10 @@
tcExpr :: --XHasCallStack =>
Expected -> Expr -> T Expr
tcExpr mt ae = T.do
--- traceM ("tcExpr enter: " ++ showExpr ae)+-- traceM ("tcExpr enter: " ++ showExpr ae ++ " :: " ++ showMaybe showExpr mt)r <- tcExprR mt ae
--- traceM ("tcExpr exit: " ++ showExpr r)+-- t <- expandType (snd r)
+-- traceM ("tcExpr exit: " ++ showExpr (fst r) ++ " :: " ++ showExpr t)T.return r
tcExprR :: --XHasCallStack =>
Expected -> Expr -> T Expr
@@ -1309,7 +1299,6 @@
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
@@ -1601,11 +1590,7 @@
tcAlts :: EType -> EAlts -> T EAlts
tcAlts tt (EAlts alts bs) =
--- 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)
+ tcBinds bs $ \ bbs -> T.do { 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@@ -1698,112 +1683,26 @@
check0 = if n /= 0 then tcError (getSLocExpr p) "Bad pattern" else T.return ()
tcBinds :: forall a . [EBind] -> ([EBind] -> T a) -> T a
-tcBinds binds ta = T.do
+tcBinds xbs ta = T.do
let
- signs = [ (i, t) | BSign i t <- binds ]
- xs = getBindsVars binds
--- traceM ("tcBinds: xs=" ++ showList showIdent xs)+ tmap = M.fromList [ (i, t) | BSign i t <- xbs ]
+ xs = concatMap getBindVars xbs
multCheck xs
- -- 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
+ xts <- T.mapM (tcBindVarT tmap) xs
+ withExtVals xts $ T.do
+ nbs <- T.mapM tcBind xbs
+ ta nbs
- -- 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 :: M.Map EType -> Ident -> T (Ident, EType)
tcBindVarT tmap x = T.do
case M.lookup x tmap of
Nothing -> T.do
t <- newUVar
- ie <- newIdent (getSLocIdent x) "q"
- T.return (x, t, EApp (EVar ie) (EVar x))
+ T.return (x, t)
Just t -> T.do
tt <- withTypeTable $ tcTypeT (Check kType) t
- T.return (x, tt, EVar x)
--}
+ T.return (x, tt)
--- 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
@@ -1817,6 +1716,13 @@
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 =
@@ -1872,23 +1778,23 @@
getEnvTypes :: T [EType]
getEnvTypes = gets (map entryType . stElemsLcl . valueTable)
-quantify :: [TRef] -> Rho -> T Sigma
+{-+quantify :: [MetaTv] -> Rho -> T Sigma
-- Quantify over the specified type variables (all flexible)
-quantify [] ty = T.return ty
quantify tvs ty = T.do
- 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')
+ 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
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)
@@ -1944,18 +1850,17 @@
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 = nub (bndrs ty)
+tyVarBndrs ty = nubBy eqIdent (bndrs ty)
where
bndrs (EForall tvs body) = map idKindIdent tvs ++ bndrs body
bndrs (EApp arg res) = bndrs arg ++ bndrs res
bndrs (EVar _) = []
- bndrs (EUVar _) = []
- bndrs t = error $ showEType t
+ bndrs _ = undefined
-{-inferSigma :: Expr -> T (Expr, Sigma)
inferSigma e = T.do
(e', exp_ty) <- inferRho e
--- a/tests/Class.hs
+++ b/tests/Class.hs
@@ -1,5 +1,4 @@
module Class(main) where
-import Primitives
import Prelude
class Eqq a where
@@ -8,10 +7,10 @@
x /== y = not (x === y)
instance Eqq Int where
- (===) = primIntEQ
+ (===) = (==)
instance Eqq Char where
- (===) = primCharEQ
+ (===) = eqChar
instance forall a . Eqq a => Eqq [a] where
[] === [] = True
--
⑨