[relax dependency analysis, infer non-recursive values in a boxy type.
John Meacham <john@repetae.net>**20060302123025] hunk ./FrontEnd/Tc/Main.hs 8
+import Data.Graph(stronglyConnComp, SCC(..))
hunk ./FrontEnd/Tc/Main.hs 13
-import DependAnalysis(getBindGroups)
hunk ./FrontEnd/Tc/Main.hs 41
-type BindGroup = ([Expl], [HsDecl])
+type BindGroup = ([Expl], [Either HsDecl [HsDecl]])
hunk ./FrontEnd/Tc/Main.hs 393
-         (impls, implEnv) <- tiImpls is
+         (impls, implEnv) <- tiImplGroups is
hunk ./FrontEnd/Tc/Main.hs 398
+tiImplGroups :: [Either HsDecl [HsDecl]] -> Tc ([HsDecl], TypeEnv)
+tiImplGroups [] = return ([],mempty)
+tiImplGroups (Left x:xs) = do
+    (d,te) <- tiNonRecImpl x
+    (ds',te') <- localEnv te $ tiImplGroups xs
+    return (d:ds', te `mappend` te')
+tiImplGroups (Right x:xs) = do
+    (ds,te) <- tiImpls x
+    (ds',te') <- localEnv te $ tiImplGroups xs
+    return (ds ++ ds', te `mappend` te')
+
+tiNonRecImpl :: HsDecl -> Tc (HsDecl, TypeEnv)
+tiNonRecImpl decl = withContext (locSimple (srcLoc decl) ("in the implicitly typed: " ++ show (getDeclName decl))) $ do
+    when (dump FD.BoxySteps) $ liftIO $ putStrLn $ "*** tiimpls " ++ show (getDeclName decl)
+    mv <- newMetaVar Sigma Star
+    (res,ps) <- listenPreds $ tcDecl decl mv
+    ps' <- flattenType ps
+    mv' <- flattenType mv
+    fs <- freeMetaVarsEnv
+    let vss = Set.fromList $ freeMetaVars mv'
+        gs = vss Set.\\ fs
+    (mvs,ds,rs) <- splitReduce (Set.toList fs) (Set.toList vss) ps'
+    addPreds ds
+    sc' <- if restricted [decl] then do
+        let gs' = gs Set.\\ Set.fromList (freeVars rs)
+        addPreds rs
+        quantify (Set.toList gs') [] mv'
+     else quantify (Set.toList gs) rs mv'
+    let f n s = do
+        let (TForAll vs _) = toSigma s
+        addCoerce n (ctAbs vs)
+        when (dump FD.BoxySteps) $ liftIO $ putStrLn $ "*** " ++ show n ++ " :: " ++ prettyPrintType s
+        return (n,s)
+    (n,s) <- f (getDeclName decl) sc'
+    let nenv = (Map.singleton n s)
+    addToCollectedEnv nenv
+    return (fst res, nenv)
+
hunk ./FrontEnd/Tc/Main.hs 438
-tiImpls bs = withContext (locSimple (srcLoc bs) ("in the implicitly typed: " ++ (show (map getDeclName bs)))) $ do
+tiImpls bs = withContext (locSimple (srcLoc bs) ("in the recursive implicitly typed: " ++ (show (map getDeclName bs)))) $ do
hunk ./FrontEnd/Tc/Main.hs 455
-            --s <- flattenType s
-            when (dump FD.BoxySteps) $ liftIO $ putStrLn $ "*** " ++ show n ++ " :: " ++ prettyPrintType s
-            --s <- generalize ps s
-            --when (dump FD.BoxySteps) $ liftIO $ putStrLn $ "*** " ++ show n ++ " :: " ++ prettyPrintType s
-            return (n,s)
+        let (TForAll vs _) = toSigma s
+        addCoerce n (ctAbs vs)
+        when (dump FD.BoxySteps) $ liftIO $ putStrLn $ "*** " ++ show n ++ " :: " ++ prettyPrintType s
+        return (n,s)
hunk ./FrontEnd/Tc/Main.hs 460
-    --nenv <- sequence [ f n s | (n,s) <- Map.toAscList $ mconcat $ snds res]
hunk ./FrontEnd/Tc/Main.hs 590
-    addToCollectedEnv (Map.singleton (getDeclName decl) sc)
-    (_,qs,typ) <- skolomize sc
-    (ret,ps) <- listenPreds (tcDecl decl typ)
+    (vs,qs,typ) <- skolomize sc
+    let sc' = (tForAll vs (qs :=> typ))
+        mp = (Map.singleton (getDeclName decl) sc')
+    addCoerce (getDeclName decl) (ctAbs vs)
+    addToCollectedEnv mp
+    (ret,ps) <- localEnv mp $ listenPreds (tcDecl decl typ)
hunk ./FrontEnd/Tc/Main.hs 662
-
-tiDeclTop ::  TypeEnv -> HsDecl -> Type -> TI ([Pred], TypeEnv)
-tiDeclTop env decl t
-   = do (ps,env,t') <- tiDecl env decl
-        unify t t'
-        return (ps, env)
-
-
------------------------------------------------------------------------------
-
-
-
-
------------------------------------------------------------------------------
-
--- type check explicitly typed bindings
-
-
-
-tiExpl ::  TypeEnv -> Expl -> TI (Scheme, [Pred], TypeEnv)
-tiExpl env (sc, HsForeignDecl {}) = do
-    return (sc,[],Map.empty)
-tiExpl env (sc, decl) = withContext
-       (locSimple (srcLoc decl) ("in the explicitly typed " ++  (render $ ppHsDecl decl))) $ do
-       --liftIO $ putStrLn  $ render (ppHsDecl decl)
-       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')
-
------------------------------------------------------------------------------
-
--- type check implicitly typed bindings
-
-
-restricted   :: [Impl] -> Bool
-restricted bs
-   = any isSimpleDecl bs
-   where
-   isSimpleDecl :: (HsDecl) -> Bool
-   isSimpleDecl (HsPatBind _sloc _pat _rhs _wheres) = True
-   isSimpleDecl _ = False
-
-tiImpls ::  TypeEnv -> [Impl] -> TI ([Pred], TypeEnv)
-tiImpls env [] = return ([],env)
-tiImpls env bs = withContext (locSimple (srcLoc bs) ("in the implicitly typed: " ++ (show (map getDeclName bs)))) $ do
-      --liftIO $ mapM (putStrLn .  render . ppHsDecl) bs
-      cHierarchy <- getClassHierarchy
-      ts <- mapM (\_ -> newTVar Star) bs
-      let
-          is      = getImplsNames bs
-          scs     = map toScheme ts
-          newEnv1 = Map.fromList $ zip is scs
-          env'    = newEnv1 `Map.union` env
-      pssEnvs <- sequence (zipWith (tiDeclTop env') bs ts)
-      let pss  = map fst pssEnvs
-      let envs = map snd pssEnvs
-      s   <- getSubst
-      ps' <- flattenType $ concat pss
-      ts' <- flattenType ts
-      fs <- liftM tv (flattenType env)
-      --let ps'     = apply s (concat pss)
-      --    ts'     = apply s ts
-      --    fs      = tv (apply s env)
-      let vss@(_:_)  = map tv ts'
-          gs      = foldr1 union vss \\ fs
-      -- (ds,rs) <- reduce cHierarchy fs (foldr1 intersect vss) ps'
-      (ds,rs,nsub) <- splitReduce cHierarchy fs (foldr1 intersect vss) ps'
-      sequence_ [ unify  (TVar tv) t | (tv,t) <- nsub ]
-      -- extSubst nsub
-      if restricted bs then
-          let gs'  = gs \\ tv rs
-              scs' = map (quantify gs' . ([]:=>)) ts'
-              newEnv2 = Map.fromList $ zip is scs' -- map assumpToPair $ zipWith makeAssump is scs'
-          in return (ds++rs,  (Map.unions envs) `Map.union` newEnv2)
-        else
-          let scs' = map (quantify gs . (rs:=>)) ts'
-              newEnv3 = Map.fromList $ zip is scs' -- map assumpToPair $ zipWith makeAssump is scs'
-          in return (ds,  (Map.unions envs) `Map.union` newEnv3)
-
-getImplsNames :: [Impl] -> [Name]
-getImplsNames impls = map getDeclName impls
-
-
------------------------------------------------------------------------------
-
-
-
-tiProgram ::  Module -> SigEnv -> KindEnv -> ClassHierarchy -> TypeEnv -> TypeEnv -> Program -> IO TypeEnv
-tiProgram modName sEnv kt h dconsEnv env bgs = runTI dconsEnv h kt sEnv modName $
-  do (ps, env1) <- tiSeq tiBindGroup env bgs
-     s         <- getSubst
-     ps <- flattenType ps
-     ([], rs) <- split h [] (apply s ps)
-     case topDefaults h rs of
-       Right s' -> do
-        env1' <- flattenType env1
-        return $  apply  s'  env1'
-       --Nothing -> return $  apply  s env1
-       Left s -> fail $ show modName ++ s
-
-
---------------------------------------------------------------------------------
-
-
hunk ./FrontEnd/Tc/Main.hs 664
-getBindGroupName (expl,impls) =  map getDeclName (snds expl ++ impls)
+getBindGroupName (expl,impls) =  map getDeclName (snds expl ++ concat (rights impls) ++ lefts impls)
hunk ./FrontEnd/Tc/Main.hs 734
-   --equationGroups = getBindGroups bindDecls (hsNameIdent_u (hsIdentString_u ("equationGroup" ++)) . getDeclName) getDeclDeps
-   -- just make sure we only deal with bindDecls and not others
hunk ./FrontEnd/Tc/Main.hs 736
+getBindGroups :: Ord name =>
+                 [node]           ->    -- List of nodes
+                 (node -> name)   ->    -- Function to convert nodes to a unique name
+                 (node -> [name]) ->    -- Function to return dependencies of this node
+                 [[node]]               -- Bindgroups
+
+getBindGroups ns fn fd = map f $ stronglyConnComp [ (n, fn n, fd n) | n <- ns] where
+    f (AcyclicSCC x) = [x]
+    f (CyclicSCC xs) = xs
+
hunk ./FrontEnd/Tc/Main.hs 751
--- reunite decls with their signatures, if ever they had one
+-- | reunite decls with their signatures, if ever they had one
hunk ./FrontEnd/Tc/Main.hs 754
-makeBindGroup sigEnv decls = (exps, impls) where
-   (exps, impls) = makeBindGroup' sigEnv decls
+makeBindGroup sigEnv decls = (exps, f impls) where
+    (exps, impls) = makeBindGroup' sigEnv decls
+    enames = map (nameName . getDeclName . snd) exps
+    f xs = map g $ stronglyConnComp [ (x, nameName $ getDeclName x,[ d | d <- getDeclDeps x, d `notElem` enames]) |  x <- xs]
+    g (AcyclicSCC x) = Left x
+    g (CyclicSCC xs) = Right xs