[create methods from instance rules rather than class hierarchy. replace unused functions with error in type analysis pass
John Meacham <john@repetae.net>**20060314062526] hunk ./E/Rules.hs 3
-    Rule(ruleHead,ruleBinds,ruleArgs,ruleBody,ruleUniq,ruleName),
+    Rule(Rule,ruleHead,ruleBinds,ruleArgs,ruleBody,ruleUniq,ruleName),
hunk ./E/TypeAnalysis.hs 4
-module E.TypeAnalysis(typeAnalyze, Typ()) where
+module E.TypeAnalysis(typeAnalyze, Typ(),expandPlaceholder) where
hunk ./E/TypeAnalysis.hs 73
-    let (prog',stats) = runStatM $ specializeProgram prog
+    unusedRules <- supplyReadValues ur >>= return . fsts . filter (not . snd)
+    unusedValues <- supplyReadValues uv >>= return . fsts . filter (not . snd)
+    let (prog',stats) = runStatM $ specializeProgram (Set.fromList unusedRules) (Set.fromList unusedValues) prog
hunk ./E/TypeAnalysis.hs 246
+type SpecEnv = (Set.Set (Module,Int),Set.Set TVr,DataTable,Map.Map TVr [Int])
+
+
hunk ./E/TypeAnalysis.hs 260
-specializeProgram :: (MonadStats m) => Program -> m Program
-specializeProgram prog = do
-    (nds,_) <- specializeDs (progDataTable prog) mempty (programDs prog)
+specializeProgram :: (MonadStats m) =>
+    (Set.Set (Module,Int))  -- ^ used rules
+    -> (Set.Set TVr)        -- ^ used values
+    -> Program
+    -> m Program
+specializeProgram usedRules usedValues prog = do
+    (nds,_) <- specializeDs (usedRules,usedValues,progDataTable prog,mempty) (programDs prog)
hunk ./E/TypeAnalysis.hs 270
-specializeDef _dataTable (t,e) | getProperty prop_PLACEHOLDER t || getProperty prop_INSTANCE t = return (t,e)
+specializeDef _dataTable (t,e) | getProperty prop_PLACEHOLDER t = return (t,e)
hunk ./E/TypeAnalysis.hs 272
-    sub = eLetRec  [ (t,v) | (t,Just v) <- sts ]
+    sub = substMap''  $ Map.fromList [ (tvrNum t,v) | (t,Just v) <- sts ]
hunk ./E/TypeAnalysis.hs 286
-specBody :: MonadStats m => DataTable -> Map.Map TVr [Int] -> E -> m E
-specBody dataTable env e | (EVar h,as) <- fromAp e, Just os <- Map.lookup h env = do
+specBody :: MonadStats m => SpecEnv -> E -> m E
+specBody env@(_,unusedVars,dataTable,_) e | (EVar h,as) <- fromAp e, h `Set.member` unusedVars = do
+    mtick $ "Specialize.delete.{" ++ pprint h ++ "}"
+    return $ foldl EAp (EError ("Unused: " ++ pprint h) (getType h)) as
+specBody (_,_,_,dmap) e | (EVar h,as) <- fromAp e, Just os <- Map.lookup h dmap = do
hunk ./E/TypeAnalysis.hs 293
-specBody dataTable env (ELetRec ds e) = do
-    (nds,nenv) <- specializeDs dataTable env ds
-    e <- specBody dataTable nenv e
+specBody env (ELetRec ds e) = do
+    (nds,nenv) <- specializeDs env ds
+    e <- specBody nenv e
hunk ./E/TypeAnalysis.hs 297
-specBody dataTable env e = emapE' (specBody dataTable env) e
+specBody env e = emapE' (specBody env) e
hunk ./E/TypeAnalysis.hs 300
-specializeDs dataTable env ds = do
+specializeDs env@(unusedRules,_,dataTable,_) ds = do
hunk ./E/TypeAnalysis.hs 306
+            nfo <- infoMapM (return . arules . filter ( not . (`Set.member` unusedRules) . ruleUniq) . rulesFromARules) nfo
hunk ./E/TypeAnalysis.hs 308
-        sb = specBody dataTable (nenv `mappend` env)
+        tenv = ((\ (a,b,c,d) -> (a,b,c,nenv `mappend` d)) env)
+        sb = specBody tenv
hunk ./E/TypeAnalysis.hs 311
-    return (ds,nenv `mappend` env)
+    return (ds,tenv)
+
+
+expandPlaceholder :: Monad m => (TVr,E) -> m (TVr,E)
+expandPlaceholder (tvr,oe) | getProperty prop_PLACEHOLDER tvr = do
+    let rules = filter isBodyRule $  rulesFromARules $ Info.fetch (tvrInfo tvr)
+        isBodyRule Rule { ruleBody = e } | (EVar vv,_) <- fromAp e, getProperty prop_INSTANCE vv = True
+        isBodyRule _ = False
+    if null rules then return (unsetProperty prop_PLACEHOLDER tvr, EError "placeholder, no bodies" (getType tvr)) else do
+    let (oe',as) = fromLam oe
+        rule1:_ = rules
+        ct = getType $ foldr ELam oe' (drop (length $ ruleArgs rule1) as)
+        as'@(a:ras) = take (length $ ruleArgs rule1) as
+        ne = emptyCase {
+            eCaseScrutinee = EVar a,
+            eCaseAlts = map calt rules,
+            eCaseBind = a { tvrIdent = 0 },
+            eCaseType = ct
+            }
+        calt rule@Rule { ruleArgs = (arg:rs) } = Alt (valToPat' arg) (substMap (Map.fromList [ (tvrIdent v,EVar r) | ~(EVar v) <- rs | r <- ras ]) $ ruleBody rule)
+
+        valToPat' (ELit (LitCons x ts t)) = LitCons x [ z | ~(EVar z) <- ts ] t
+        valToPat' (EPi (TVr { tvrType =  EVar a}) (EVar b))  = LitCons tc_Arrow [a,b] eStar
+        valToPat' x = error $ "expandPlaceholder.valToPat': " ++ show x
+
+    return (unsetProperty prop_PLACEHOLDER tvr,foldr ELam ne as')
+
+expandPlaceholder _x = fail "not placeholder"
+
+
+
+
+
hunk ./Main.hs 426
-        es' <- createMethods dataTable (hoClassHierarchy ho) (programEsMap prog)
+        let es' = concatMap expandPlaceholder (programDs prog)
+        --es' <- createMethods dataTable (hoClassHierarchy ho) (programEsMap prog)
hunk ./Main.hs 429
-            tmap = Set.fromList $ [ t | (_,t,_) <- es' ]
-        let Identity es'' = annotateDs initMap (idann (hoRules ho) (hoProps ho) ) letann lamann [ (y,z) | (x,y,z) <- es']
-        es' <- return [ (x,y,floatInward rules z) | (x,_,_) <- es' | (y,z) <- es'' ]
+            tmap = Set.fromList [ t | (t,_) <- es' ]
+        let Identity es'' = annotateDs initMap (idann (hoRules ho) (hoProps ho) ) letann lamann es'
+        es' <- return [ (y,floatInward rules z) |  (y,z) <- es'' ]
hunk ./Main.hs 433
-            sequence_ [ print x >> printCheckName' dataTable y z |  (x,y,z) <- es']
-        return [ (y,z) | (_,y,z) <- es' ]
+            sequence_ [ printCheckName' dataTable y z |  (y,z) <- es']
+        return es'