[collect type signatures from inside statements, handle mutually recursive groups of lets. handle binding groups
John Meacham <john@repetae.net>**20051214033533] hunk ./FrontEnd/Tc/Main.hs 20
+import FrontEnd.SrcLoc
hunk ./FrontEnd/Tc/Main.hs 32
-type Impl = HsDecl
hunk ./FrontEnd/Tc/Main.hs 35
-type BindGroup = ([Expl], [Impl])
-type Program = [BindGroup]
+type BindGroup = ([Expl], [HsDecl])
hunk ./FrontEnd/Tc/Main.hs 168
-            --(_,s) <- skolomize s
+            (_,s) <- skolomize s
hunk ./FrontEnd/Tc/Main.hs 207
+tiExpr expr@(HsLet decls e) typ = withContext (makeMsg "in the let binding" $ render $ ppHsExp expr) $ do
+    sigEnv <- getSigEnv
+    liftIO $ print sigEnv
+    let bgs = getFunDeclsBg sigEnv decls
+        f (bg:bgs) rs = do
+            (ds,env) <- tcBindGroup bg
+            localEnv env $ f bgs (ds ++ rs)
+        f [] rs = do
+            e' <- tcExpr e typ
+            return (HsLet rs e')
+    f bgs []
+
hunk ./FrontEnd/Tc/Main.hs 243
+
+-----------------------------------------------------------------------------
+
+-- type check implicitly typed bindings
+
+
hunk ./FrontEnd/Tc/Main.hs 266
+tcGuardedRhs typ gAlt@(HsGuardedRhs sloc eGuard e) = withContext (locMsg sloc "in the guarded alternative" $ render $ ppHsGuardedRhs gAlt) $ do
+    g' <- tcExpr eGuard tBool
+    e' <- tcExpr e typ
+    return  (HsGuardedRhs sloc g' e')
+
hunk ./FrontEnd/Tc/Main.hs 327
+    addToCollectedEnv (Map.singleton (toName Val i) typ)
hunk ./FrontEnd/Tc/Main.hs 334
+tcBindGroup :: BindGroup -> Tc ([HsDecl], TypeEnv)
+tcBindGroup (es, is) = do
+     let env1 = Map.fromList [(getDeclName decl, sc) | (sc,decl) <- es ]
+     localEnv env1 $ do
+         (impls, implEnv) <- tiImpls is
+         localEnv implEnv $ do
+             expls   <- mapM tiExpl es
+             return (impls ++ fsts expls, mconcat (implEnv:env1:snds expls))
+
+tiImpls ::  [HsDecl] -> Tc ([HsDecl], TypeEnv)
+tiImpls [] = return ([],Map.empty)
+tiImpls bs = withContext (locSimple (srcLoc bs) ("in the implicitly typed: " ++ (show (map getDeclName bs)))) $ do
+    liftIO $ putStrLn $ "tiimpls " ++ show (map getDeclName bs)
+    ss <- sequence [newTVar Star | _ <- bs]
+    rs <- localEnv (Map.fromList [  (getDeclName d,s) | d <- bs | s <- ss]) $ sequence [ tcDecl d s | d <- bs | s <- ss ]
+    nenv <- sequence [ flattenType s >>= generalize >>= return . (,) n | (n,s) <- Map.toAscList $ mconcat $ snds rs]
+    addToCollectedEnv (Map.fromAscList nenv)
+    return (fsts rs, Map.fromAscList nenv)
+
+tcRhs :: HsRhs -> Sigma -> Tc HsRhs
+tcRhs rhs typ = case rhs of
+    HsUnGuardedRhs e -> do
+        e' <- tcExpr e typ
+        return (HsUnGuardedRhs e')
+    HsGuardedRhss as -> do
+        gas <- mapM (tcGuardedRhs typ) as
+        return (HsGuardedRhss gas)
+
+
+tcDecl ::  HsDecl -> Sigma -> Tc (HsDecl,TypeEnv)
+
+tcDecl d@(HsForeignDecl _ _ _ n _) typ = do
+    s <- lookupName (toName Val n)
+    s `subsumes` typ
+    return (d,mempty)
+
+
+
+tcDecl decl@(HsPatBind sloc (HsPVar v) rhs []) typ = withContext (declDiagnostic decl) $ do
+    case rhs of
+        HsUnGuardedRhs e -> do
+            e' <- tcExpr e typ
+            return (HsPatBind sloc (HsPVar v) (HsUnGuardedRhs e') [], Map.singleton (toName Val v) typ)
+        HsGuardedRhss as -> do
+            gas <- mapM (tcGuardedRhs typ) as
+            return (HsPatBind sloc (HsPVar v) (HsGuardedRhss gas) [], Map.singleton (toName Val v) typ)
+
+
+tcDecl decl@(HsFunBind matches) typ = withContext (declDiagnostic decl) $ do
+        matches' <- mapM (`tcMatch` typ) matches
+        return (HsFunBind matches', Map.singleton (getDeclName decl) typ)
+
+tcMatch ::  HsMatch -> Sigma -> Tc HsMatch
+tcMatch (HsMatch sloc funName pats rhs []) typ = withContext (locMsg sloc "in" $ show funName) $ do
+    let lam (p:ps) (TMetaVar mv) rs = do -- ABS2
+            b1 <- newBox Star
+            b2 <- newBox Star
+            r <- lam (p:ps) (b1 `fn` b2) rs
+            varBind mv (b1 `fn` b2)
+            return r
+        lam (p:ps) (TArrow s1' s2') rs = do -- ABS1
+            box <- newBox Star
+            s1' `boxyMatch` box
+            (p',env) <- tiPat p box
+            localEnv env $ do
+                lamPoly ps s2' (p':rs)  -- TODO poly
+        lam [] typ rs = do
+            rhs <- tcRhs rhs typ
+            return (HsMatch sloc funName (reverse rs) rhs [])
+        lam _ _ _ = fail "lambda type mismatch"
+        lamPoly ps s@TBox {} rs = lam ps s rs
+        lamPoly ps s rs = do
+            (_,s) <- skolomize s
+            lam ps s rs
+    lam pats typ []
+
+declDiagnostic ::  (HsDecl) -> Diagnostic
+declDiagnostic decl@(HsPatBind sloc (HsPVar {}) _ _) = locMsg sloc "in the declaration" $ render $ ppHsDecl decl
+declDiagnostic decl@(HsPatBind sloc pat _ _) = locMsg sloc "in the pattern binding" $ render $ ppHsDecl decl
+declDiagnostic decl@(HsFunBind matches) = locMsg (srcLoc decl) "in the function binding" $ render $ ppHsDecl decl
+
+tiExpl ::  Expl -> Tc (HsDecl,TypeEnv)
+tiExpl (sc, decl@HsForeignDecl {}) = do return (decl,Map.empty)
+tiExpl (sc, decl) = withContext (locSimple (srcLoc decl) ("in the explicitly typed " ++  (render $ ppHsDecl decl))) $ do
+    liftIO $ putStrLn $ "typing expl: " ++ show (getDeclName decl)
+    addToCollectedEnv (Map.singleton (getDeclName decl) sc)
+    (_,sc) <- skolomize sc
+    tcDecl decl sc
+    {-
+       cHierarchy <- getClassHierarchy
+       --(qs :=> t) <- -fmap snd $ freshInst sc
+       let (qs :=> t) = unQuantify sc
+       t <- flattenType t
+       qs <- flattenType qs
+       --liftIO $ putStrLn  $ show sc
+       (ps, env') <- tiDeclTop env decl t
+       --liftIO $ putStrLn  $ show ps
+       ps <- flattenType ps
+
+       --qs' <- flattenType qs
+       --ps'' <- flattenType ps
+       fs <- liftM tv (flattenType env)
+       --qs' <- sequence [ flattenType y >>= return . IsIn x | IsIn x y <- qs]
+       s          <- getSubst
+       let qs'     = apply s qs
+           t'      = apply s t
+           ps'     = [ p | p <- apply s ps, not (entails cHierarchy qs' p) ]
+       --    fs      = tv (apply s env)
+           gs      = tv t' {- \\ fs  -} -- TODO fix this!
+           sc'     = quantify gs (qs':=>t')
+       -- (ds,rs) <- reduce cHierarchy fs gs ps'
+       --liftIO $ putStrLn  $ show (gs,ps')
+       (ds,rs,nsub) <- splitReduce cHierarchy fs gs ps'
+       --liftIO $ putStrLn  $ show (ds,rs,nsub)
+       sequence_ [ unify  (TVar tv) t | (tv,t) <- nsub ]
+       --extSubst nsub
+       --unify t' t
+       --unify t t'
+       if sc /= sc' then
+           fail $ "signature too general for " ++ show (getDeclName decl) ++ "\n Given: " ++ show sc ++ "\n Infered: " ++ show sc'
+        else if not (null rs) then
+           fail $ "context too weak for "  ++ show (getDeclName decl) ++ "\nGiven: " ++ PPrint.render (pprint  sc) ++ "\nInfered: " ++ PPrint.render (pprint sc') ++"\nContext: " ++ PPrint.render (pprint  rs)
+        else
+           return (sc', ds,  env')
+           --return (sc', ds, env')
+
+-}
hunk ./FrontEnd/Tc/Main.hs 551
-declDiagnostic ::  (HsDecl) -> Diagnostic
-declDiagnostic decl@(HsPatBind sloc (HsPVar {}) _ _) = locMsg sloc "in the declaration" $ render $ ppHsDecl decl
-declDiagnostic decl@(HsPatBind sloc pat _ _) = locMsg sloc "in the pattern binding" $ render $ ppHsDecl decl
-declDiagnostic decl@(HsFunBind matches) = locMsg (srcLoc decl) "in the function binding" $ render $ ppHsDecl decl
hunk ./FrontEnd/Tc/Main.hs 795
-getFunDeclsBg :: TypeEnv -> [HsDecl] -> Program
-getFunDeclsBg sigEnv decls
-   = makeProgram sigEnv equationGroups
-   where
+getFunDeclsBg :: TypeEnv -> [HsDecl] -> [BindGroup]
+getFunDeclsBg sigEnv decls = makeProgram sigEnv equationGroups where
hunk ./FrontEnd/Tc/Main.hs 804
-makeProgram :: TypeEnv -> [[HsDecl]] -> Program
-makeProgram sigEnv groups
-   = map (makeBindGroup sigEnv ) groups
+makeProgram :: TypeEnv -> [[HsDecl]] -> [BindGroup]
+makeProgram sigEnv groups = map (makeBindGroup sigEnv ) groups
hunk ./FrontEnd/Tc/Monad.hs 4
+    getCollectedEnv,
hunk ./FrontEnd/Tc/Monad.hs 8
+    toSigma,
hunk ./FrontEnd/Tc/Monad.hs 13
+    getSigEnv,
+    getModName,
hunk ./FrontEnd/Tc/Monad.hs 38
+import Data.FunctorM
hunk ./FrontEnd/Tc/Monad.hs 52
+import Util.Inst
hunk ./FrontEnd/Tc/Monad.hs 96
+getCollectedEnv :: Tc TypeEnv
+getCollectedEnv = do
+    v <- asks tcCollectedEnv
+    r <- liftIO $ readIORef v
+    fmapM flattenType r
+    return r
+
hunk ./FrontEnd/Tc/Monad.hs 112
-        tcCurrentEnv = tcInfoEnv tcInfo,
+        tcCurrentEnv = tcInfoEnv tcInfo `mappend` tcInfoSigEnv tcInfo,
hunk ./FrontEnd/Tc/Monad.hs 253
+toSigma :: Sigma -> Sigma
+toSigma t@TForAll {} = t
+toSigma t = TForAll [] ([] :=> t)
+
hunk ./FrontEnd/TypeSigs.hs 16
+                 collectSigEnv,
hunk ./FrontEnd/TypeSigs.hs 32
+collectSigEnv :: KindEnv -> HsStmt -> SigEnv
+collectSigEnv kindInfo stmt = sigEnv where
+    allTypeSigs = collectSigsFromStmt stmt
+    sigEnv = listSigsToSigEnv kindInfo allTypeSigs
+
hunk ./Interactive.hs 46
+import TypeSigs
hunk ./Interactive.hs 223
-        tcInfoSigEnv = mempty,
+        tcInfoSigEnv = Map.map schemeToType $ collectSigEnv (hoKinds ho) (HsQualifier e),
hunk ./Interactive.hs 238
+    ce <- getCollectedEnv
+    liftIO $ mapM_ putStrLn [ pprint n <+>  "::" <+> prettyPrintType s |  (n,s) <- Map.toList ce]
hunk ./Util/Inst.hs 6
+import qualified Data.Map as Map
+import Data.FunctorM
hunk ./Util/Inst.hs 26
+instance Ord a => FunctorM (Map.Map a) where
+    fmapM_ f mp = mapM_ f (Map.elems mp)
+    fmapM f mp = sequence [ f y >>= return . (,) x | (x,y) <- Map.toAscList mp] >>= return . Map.fromAscList
+