[when creating instance rules, use true unification to determine how to pass arguments to the rule body in favor of assuming they appear in a certain order
John Meacham <john@repetae.net>**20090224083700
 Ignore-this: 85009588ddc59d5910d28749795f8cec
] hunk ./E/FromHs.hs 15
-import Maybe
hunk ./E/FromHs.hs 96
+    f TAssoc {} = error "E.FromHs.tipe TAssoc"
hunk ./E/FromHs.hs 114
-simplifyDecl (HsPatBind sl (HsPVar n)  rhs wh) = HsFunBind [HsMatch sl n [] rhs wh]
-simplifyDecl x = x
hunk ./E/FromHs.hs 188
+-- | create a RULE for each instance attached to the class methods.
+-- These rules allow early specialization of monomorphic code, and are
+-- eventually used in E.TypeAnalysis.expandPlaceholder to fill out
+-- the generic class method bodies.
hunk ./E/FromHs.hs 197
-    cClass classRecord =  concat [ method classRecord n | (n,TForAll _ (_ :=> t)) <- classAssumps classRecord ]
-    method classRecord methodName | isJust _methodName = as where
-        methodVar = tVr (toId methodName) ty
-        _methodName@(~(Just (TVr {tvrType = ty},_))) = findName methodName
-        defaultName =  (defaultInstanceName methodName)
-        valToPat' (ELit LitCons { litAliasFor = af,  litName = x, litArgs = ts, litType = t }) = (ELit litCons { litAliasFor = af, litName = x, litArgs = ts', litType = t },ts') where
-            ts' = [ EVar (tVr j (getType z)) | z <- ts | j <- someIds]
-        --valToPat' (EPi (TVr { tvrType =  a}) b)  = ELit $ litCons { litName = tc_Arrow, litArgs = [ EVar (tVr j (getType z)) | z <- [a,b] | j <- [2,4 ..], j `notElem` map tvrIdent args], litType = eStar }
-        valToPat' (EPi tv@TVr { tvrType =  a} b)  = (EPi tvr { tvrType =  a'} b',[a',b']) where
-            a' = EVar (tVr ja (getType a))
-            b' = EVar (tVr jb (getType b))
-            (ja:jb:_) = someIds
-        valToPat' x = error $ "FromHs.valToPat': " ++ show x
+    cClass classRecord =  concat [ method classRecord n mve | (n,TForAll _ (_ :=> t)) <- classAssumps classRecord, mve <- findName n ]
+
+    method classRecord methodName (methodVar,_) = as where
+        ty = tvrType methodVar
+        defaultName = defaultInstanceName methodName
+
hunk ./E/FromHs.hs 204
-        (_ft,_:args') = fromPi ty
-        someIds = newIds (fromList $ map tvrIdent args')
-        (args,_rargs) = span (sortKindLike . getType)  args'
hunk ./E/FromHs.hs 207
-            name = (instanceName methodName (getTypeCons t))
-            --vp@(ELit LitCons { litArgs =  vs }) = tpat
+            name = instanceName methodName (getTypeCons t)
+            bodyt = foldl eAp ty (vp:map EVar args)
hunk ./E/FromHs.hs 210
-                Just (n,_) -> foldl EAp (EVar n) (vs ++ map EVar args)
+                Just (n,_) -> runIdentity $ do actuallySpecializeE (EVar n) bodyt
hunk ./E/FromHs.hs 212
-                    Just (deftvr,_) | null vs -> foldl EAp (EAp (EVar deftvr) vp) (map EVar args)
-                    Just (deftvr,_) -> eLet tv vp $ foldl EAp (EAp (EVar deftvr) (EVar tv)) (map EVar args) where
-                        tv = tvr { tvrIdent = head [ n | n <- newIds (freeVars vp)], tvrType = getType vp }
-                    Nothing -> foldl EAp (EError ( show methodName ++ ": undefined at type " ++  PPrint.render (pprint t)) (eAp ty (fst $ valToPat' (tipe t)))) (map EVar args)
-    method _ _ = []
-    nfuncs = runIdentity $ do
-        let f d@(v,_) = case fromId (tvrIdent v) of
-                Just n -> return (n,d)
-                Nothing -> fail $ "createInstanceRules: top level var with temporary name " ++ show v
-        xs <- mapM f funcs
-        return (Map.fromList xs)
+                    Just (deftvr,_) | otherwise -> runIdentity $ do actuallySpecializeE (EVar deftvr) bodyt
+                    Nothing -> EError ( show methodName ++ ": undefined at type " ++  PPrint.render (pprint t)) bodyt
+                    --Just (deftvr,_) -> eLet tv vp $ runIdentity $ do actuallySpecializeE (EVar deftvr) (foldl eAp ty $ EVar tv:map EVar args) where -- foldl EAp (EAp (EVar deftvr) (EVar tv)) (map EVar args) where
+                    --    tv = tvr { tvrIdent = head [ n | n <- newIds (freeVars vp `mappend` fromList (map tvrIdent args))], tvrType = getType vp }
+                    --Just (deftvr,_) | null vs -> foldl EAp (EAp (EVar deftvr) vp) (map EVar args)
hunk ./E/FromHs.hs 218
-    findName name = case Map.lookup name nfuncs of
+        -- this assumes the class argument is always the first type parameter
+        (_,_:args') = fromPi ty
+        (args,_) = span (sortKindLike . tvrType)  args'
+
+        someIds = newIds (fromList $ map tvrIdent args')
+        valToPat' (ELit LitCons { litAliasFor = af,  litName = x, litArgs = ts, litType = t }) = ans where
+            ans = (ELit litCons { litAliasFor = af, litName = x, litArgs = ts', litType = t },ts')
+            ts' = [ EVar (tVr j (getType z)) | z <- ts | j <- someIds]
+        valToPat' (EPi tv@TVr { tvrType =  a} b)  = (EPi tvr { tvrType =  a'} b',[a',b']) where
+            a' = EVar (tVr ja (getType a))
+            b' = EVar (tVr jb (getType b))
+            (ja:jb:_) = someIds
+        valToPat' x = error $ "FromHs.valToPat': " ++ show x
+
+    funcsMap = Map.fromList [ (n,(v,e)) | (v,e) <- funcs, let Just n = fromId (tvrIdent v) ]
+    findName name = case Map.lookup name funcsMap of
hunk ./E/FromHs.hs 249
-    Just (cna,sta,ta) = lookupCType' dataTable te
+    Just (cna,sta,_ta) = lookupCType' dataTable te
hunk ./E/FromHs.hs 388
-    -- first argument builds the actual call primitive, given 
+    -- first argument builds the actual call primitive, given
hunk ./E/FromHs.hs 407
-                        eStrictLet tvrWorld2 
+                        eStrictLet tvrWorld2
hunk ./E/FromHs.hs 417
-                let rttIO = ltTuple [tWorld__, rt']
+                let _rttIO = ltTuple [tWorld__, rt']
hunk ./E/FromHs.hs 431
-                                          (eLet rtVar 
+                                          (eLet rtVar
hunk ./E/FromHs.hs 446
-        (var,ty,lamt) <- convertValue name
-        let (ts,rt)    = argTypes' ty
+        (var,ty,lamt)  <- convertValue name
+        let (_ts,rt)   = argTypes' ty
hunk ./E/FromHs.hs 466
-        let ((fptrTy:_), _) = argTypes' ty
-            fty = discardArgs 1 ty
+        --let ((fptrTy:_), _) = argTypes' ty
+        --    fty = discardArgs 1 ty
hunk ./E/FromHs.hs 492
-                let rttIO = ltTuple [tWorld__, rt']
+                let _rttIO = ltTuple [tWorld__, rt']
hunk ./E/FromHs.hs 514
-                          
+
hunk ./E/FromHs.hs 519
-        
+
hunk ./E/FromHs.hs 532
-        
+
hunk ./E/FromHs.hs 536
-        
+
hunk ./E/FromHs.hs 712
-        let ds = map simplifyDecl decls
-            cr = findClassRecord classHierarchy className
+        let cr = findClassRecord classHierarchy className
hunk ./E/FromHs.hs 761
+{-
hunk ./E/FromHs.hs 776
+    -}
hunk ./E/FromHs.hs 919
-                            nargs = length spats
+                            _nargs = length spats
hunk ./E/FromHs.hs 949
-actuallySpecializeE :: Monad m 
+actuallySpecializeE :: Monad m
hunk ./E/FromHs.hs 968
-        f _ _ = fail $ render (text "specializeE: attempt to specialize types that do not unify:" 
+        f _ _ = fail $ render (text "specializeE: attempt to specialize types that do not unify:"
hunk ./E/FromHs.hs 997
+makeSpec _ _ = fail "E.FromHs.makeSpec: invalid specialization"