[honor SPECIALIZE pragmas
John Meacham <john@repetae.net>**20060228035536] hunk ./E/FromHs.hs 6
+    makeSpec,
hunk ./E/FromHs.hs 43
+import qualified FrontEnd.Tc.Type as T(Rule(..))
hunk ./E/FromHs.hs 631
+
+specializeE :: Monad m
+    => E   -- ^ the general type
+    -> E   -- ^ the specific type
+    -> m [E]  -- ^ what to apply the general type to to get the specific one
+specializeE gt st = do
+    let f zs x | Just mm <- match (const Nothing) zs x st = mapM (g mm) (reverse zs) where
+            g mm tvr = case lookup tvr mm of
+                Just x -> return x
+                Nothing -> fail $ "specializeE: variable not bound: " ++ pprint (((gt,st),(mm,tvr)),(zs,x))
+        f zs (EPi vbind exp) = f (vbind:zs) exp
+        f _ _ = fail "specializeE: attempt to specialize types that do not unify"
+    f [] gt
+
+
+
+makeSpec :: Monad m => (TVr,E) -> T.Rule -> m ((TVr,E),Rule)
+makeSpec (t,e) T.RuleSpec { T.ruleType = rt, T.ruleUniq = (Module m,ui), T.ruleSuper = ss } = do
+    let nt = tipe rt
+    as <- specializeE (getType t) nt
+    let ntvr = tvr { tvrIdent = toId newName, tvrType = nt, tvrInfo = setProperties (prop_SPECIALIZATION:sspec) mempty }
+        Just nn = fromId (tvrIdent t)
+        (ntype,Just m,q) = nameParts nn
+        newName = toName ntype (Just $ "Spec@." ++ m ++ "." ++ show ui,'f':m ++ "." ++ q)
+        sspec = if ss then [prop_SUPERSPECIALIZE] else []
+        ar = makeRule ("Specialize.{" ++ show newName) (Module m,ui) [] t as (EVar ntvr)
+    return ((ntvr,foldl EAp e as),ar)
+
+
hunk ./E/FromHs.hs 662
---    f (ELit (LitCons n [x] t)) | alias =  (f x)  where
---        alias = case getConstructor n dataTable of
---                 Just v -> conAlias v
---                 x      -> error ("deNewtype for "++show n++": "++show x)
hunk ./E/FromHs.hs 666
+
hunk ./Main.hs 154
-procSpecs :: Monad m => (Map.Map Name [Type.Rule]) -> (TVr,E) -> m [(TVr,E)]
+procSpecs :: Monad m => (Map.Map Name [Type.Rule]) -> (TVr,E) -> m ([(TVr,E)],[Rule])
hunk ./Main.hs 156
-    return [(t,e)]
-procSpecs _specMap d = return [d]
+    hs <- mapM (makeSpec (t,e)) rs
+    let (defs,rls) = unzip hs
+        crules = Info.fetch (tvrInfo t)
+    return $ ((t { tvrInfo = Info.insert (mappend crules (arules rls)) $ tvrInfo t},e):defs,rls)
+procSpecs _specMap d = return ([d],[])
hunk ./Main.hs 222
-    prog <- return $ programSetDs (concat nds) prog
+    prog <- return $ programSetDs (concat (fsts nds)) prog
+    let specRules = fromRules $ concat $ snds nds
+    wdump FD.Rules $ printRules specRules
+    rules <- return $ specRules `mappend` rules
+    allRules <- return $ allRules `mappend` rules
hunk ./Main.hs 233
-        cds <- annotateDs annmap (idann (hoRules allHo) mempty) letann lamann [ (t,e) | (t,e) <- ns]
+        cds <- annotateDs annmap (idann allRules mempty) letann lamann [ (t,e) | (t,e) <- ns]