[implement top level defaulting.
John Meacham <john@repetae.net>**20060213171023] {
hunk ./FlagOpts.flags 5
+monomorphism-restriction enforce monomorphism restriction
hunk ./FlagOpts.flags 24
-@default inline-pragmas rules wrapper float-in strictness defaulting type-analysis
+@default inline-pragmas rules wrapper float-in strictness defaulting type-analysis monomorphism-restriction
hunk ./FrontEnd/Tc/Class.hs 7
+    topDefaults,
hunk ./FrontEnd/Tc/Class.hs 26
-import Class hiding(split,simplify,toHnfs,entails,splitReduce)
+import Class hiding(split,simplify,toHnfs,entails,splitReduce,topDefaults)
hunk ./FrontEnd/Tc/Class.hs 140
-    --liftIO $ putStrLn $ pprint (fs,gs,ps) 
+    --liftIO $ putStrLn $ pprint (fs,gs,ps)
hunk ./FrontEnd/Tc/Class.hs 174
-    let ns = [ p  | p <- ps, not $ entails ch qs p ] 
+    let ns = [ p  | p <- ps, not $ entails ch qs p ]
hunk ./FrontEnd/Tc/Class.hs 203
+topDefaults     :: [Pred] -> Tc ()
+topDefaults ps  = do
+    h <- getClassHierarchy
+    let ams = ambig h [] ps
+        tss = [ ts | (v,qs,ts) <- ams ]
+        vs  = [ v  | (v,qs,ts) <- ams ]
+    when (any null tss) $ fail $ "Top Level ambiguity " ++ (pprint ps)
+    return ()
+--      | otherwise    -> return $ Map.fromList (zip vs (map head tss))
+--        where ams = ambig h [] ps
+--              tss = [ ts | (v,qs,ts) <- ams ]
+--              vs  = [ v  | (v,qs,ts) <- ams ]
hunk ./FrontEnd/Tc/Main.hs 20
+import Options
+import qualified FlagOpts as FO
hunk ./FrontEnd/Tc/Main.hs 388
-    --ch <- getClassHierarchy
-    --ps <- return $ Class.simplify ch ps
hunk ./FrontEnd/Tc/Main.hs 389
-            --liftIO $ putStrLn $ "*** " ++ show n ++ " :: " ++ prettyPrintType s
hunk ./FrontEnd/Tc/Main.hs 390
-            --liftIO $ putStrLn $ "*** " ++ show n ++ " :: " ++ prettyPrintType s
hunk ./FrontEnd/Tc/Main.hs 391
-            --liftIO $ putStrLn $ "*** " ++ show n ++ " :: " ++ prettyPrintType s
hunk ./FrontEnd/Tc/Main.hs 411
+            ch <- getClassHierarchy
hunk ./FrontEnd/Tc/Main.hs 413
-                     tcExpr e1 tr
-                     tcExpr e2 tr
+                    (e1,ps) <- censor (const mempty) $ listen (tcExpr e1 tr)
+                    ([],rs) <- splitPreds ch [] ps
+                    (e2,ps) <- censor (const mempty) $ listen (tcExpr e2 tr)
+                    ([],rs) <- splitPreds ch [] ps
+                    return ()
hunk ./FrontEnd/Tc/Main.hs 508
-    --liftIO $ putStrLn $ pprint ds
-    --addPreds ds
hunk ./FrontEnd/Tc/Main.hs 510
-    --case sc of
-    --    TForAll _ (_ :=> t) -> tcDecl decl t
-    --    t -> tcDecl decl t
-    --(_,sc) <- skolomize 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
hunk ./FrontEnd/Tc/Main.hs 511
-       --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')
+restricted   :: [HsDecl] -> Bool
+restricted bs = fopts FO.MonomorphismRestriction && any isSimpleDecl bs where
+   isSimpleDecl :: (HsDecl) -> Bool
+   isSimpleDecl (HsPatBind _sloc _pat _rhs _wheres) = True
+   isSimpleDecl _ = False
hunk ./FrontEnd/Tc/Main.hs 517
--}
hunk ./FrontEnd/Tc/Main.hs 708
+
+getBindGroupName (expl,impls) =  map getDeclName (snds expl ++ impls)
+
+
hunk ./FrontEnd/Tc/Main.hs 715
-        (r,ps) <- listen $ f bgs [] mempty
+        (r,ps) <- censor (const mempty) $ listen $ f bgs [] mempty
hunk ./FrontEnd/Tc/Main.hs 718
-        ps <- return $ simplify ch ps
-        liftIO $ mapM_ (putStrLn.show) ps
+        liftIO $ print ps
+        ([],rs) <- splitPreds ch [] ps
+        topDefaults rs
hunk ./FrontEnd/Tc/Main.hs 722
+        --ps <- return $ simplify ch ps
+        --liftIO $ mapM_ (putStrLn.show) ps
+        --return r
hunk ./FrontEnd/Tc/Main.hs 726
-        (ds,env) <- tcBindGroup bg
-        liftIO $ do
-            putChar '.'
-            hFlush stdout
+        ((ds,env),ps) <- censor (const mempty) $ listen (tcBindGroup bg)
+        ch <- getClassHierarchy
+        withContext (makeMsg "in the binding group:" $ show (getBindGroupName bg)) $ do
+            ([],leftovers) <- splitPreds ch [] ps
+            topDefaults leftovers
+        liftIO $ do putChar '.'; hFlush stdout
hunk ./FrontEnd/Tc/Main.hs 734
-        mapM_ tcPragmaDecl es
+        ch <- getClassHierarchy
+        ((),ps) <- censor (const mempty) $ listen $ mapM_ tcPragmaDecl es
+        withContext (makeMsg "in the pragmas:" $ "rules") $ do
+            ([],leftovers) <- splitPreds ch [] ps
+            topDefaults leftovers
hunk ./utils/opt_sets.prl 80
-print "\nprocess s xs = foldr f (s,[]) (map one xs) where\n";
+
+print "\n{-# NOINLINE process #-}\n";
+print "process s xs = foldr f (s,[]) (map one xs) where\n";
hunk ./utils/opt_sets.prl 96
-print "\nhelpMsg = \"$help\"\n";
+print "\n{-# NOINLINE helpMsg #-}\n";
+print "helpMsg = \"$help\"\n";
}
