[include return type in application nodes in Grin.
John Meacham <john@repetae.net>**20051013080504] hunk ./C/FromGrin.hs 160
-cexp (App a vs) = do
+cexp (App a vs _) = do
hunk ./Grin/DeadFunctions.hs 169
-    f (App fn as) = do
+    f (App fn as ty) = do
hunk ./Grin/DeadFunctions.hs 171
-        return $ App fn as
+        return $ App fn as ty
hunk ./Grin/DeadFunctions.hs 205
-    g (App a [e]) | a == funcEval =  tell (Seq.fromList [ (v,Used) | v <- freeVars e ])
-    g (App a [x,y]) | a == funcApply =  tell (Seq.fromList [ (v,Used) | v <- freeVars (x,y) ])
-    g (App a vs) = tell (Seq.fromList $ concat [ [ (x,Passed [(a,i)]) | x <- freeVars v] | v <- vs | i <- [0..] ])
+    g (App a [e] _) | a == funcEval =  tell (Seq.fromList [ (v,Used) | v <- freeVars e ])
+    g (App a [x,y] _) | a == funcApply =  tell (Seq.fromList [ (v,Used) | v <- freeVars (x,y) ])
+    g (App a vs _) = tell (Seq.fromList $ concat [ [ (x,Passed [(a,i)]) | x <- freeVars v] | v <- vs | i <- [0..] ])
hunk ./Grin/EvalInline.hs 50
-        | HoistedUpdate udp@(NodeC t [v]) <- shared = App (toAtom n) vs :>>= n3 :-> Return n3 :>>= udp :-> Update p1 udp :>>= unit :-> Return v
-        | HoistedUpdate udp <- shared = App (toAtom n) vs :>>= n3 :-> (Return n3 :>>= udp :-> Update p1 udp) :>>= unit :-> Return n3
-        | otherwise = App (toAtom n) vs
+        | HoistedUpdate udp@(NodeC t [v]) <- shared = App fname vs ty :>>= n3 :-> Return n3 :>>= udp :-> Update p1 udp :>>= unit :-> Return v
+        | HoistedUpdate udp <- shared = App fname vs ty :>>= n3 :-> (Return n3 :>>= udp :-> Update p1 udp) :>>= unit :-> Return n3
+        | otherwise = App fname vs ty
+     where
+        fname = toAtom n
+        Just (_,ty) = findArgsType te fname
hunk ./Grin/EvalInline.hs 70
-            | n == (1::Int) =  App (toAtom $ 'f':rs) (vs ++ [p2])
+            | n == (1::Int) =  App fname (vs ++ [p2]) ty
hunk ./Grin/EvalInline.hs 73
+         where
+            fname = (toAtom $ 'f':rs)
+            Just (_,ty) = findArgsType te fname
+
+
hunk ./Grin/FromE.hs 140
-    let (main,as,_) = runIdentity $ Map.lookup (tvrNum mt) scMap
-        main' =  if not $ null as then  (Return $ NodeC (partialTag main (length as)) []) else App main []
+    let (main,as,rtype) = runIdentity $ Map.lookup (tvrNum mt) scMap
+        main' =  if not $ null as then  (Return $ NodeC (partialTag main (length as)) []) else App main [] rtype
hunk ./Grin/FromE.hs 159
-            grinFunctions = (funcMain ,(Tup [] :-> App funcInitCafs [] :>>= unit :->  theMain :>>= n0 :-> Return unit )) : ds',
+            grinFunctions = (funcMain ,(Tup [] :-> App funcInitCafs [] tyUnit :>>= unit :->  theMain :>>= n0 :-> Return unit )) : ds',
hunk ./Grin/FromE.hs 296
-                    app (App v x) y
+                    app (App v x es) y
hunk ./Grin/FromE.hs 315
-    ce ep@(EPrim (APrim (PrimPrim s) _) es _) = do
-        fail $ "Unrecognized PrimPrim: " ++ show ep
-        return $ App (toAtom $ 'b':s ) (args es)
+    --ce ep@(EPrim (APrim (PrimPrim s) _) es _) = do
+    --    fail $ "Unrecognized PrimPrim: " ++ show ep
+    --    return $ App (toAtom $ 'b':s ) (args es)
hunk ./Grin/Grin.hs 83
-gEval x = App funcEval [x]
-gApply x y = App funcApply [x,y]
+gEval x = App funcEval [x] TyNode
+gApply x y = App funcApply [x,y] TyNode
hunk ./Grin/Grin.hs 137
-    | App { expFunction :: Atom, expArgs :: [Val] }    -- ^ this handles applications of functions and builtins
+    | App { expFunction :: Atom, expArgs :: [Val], expType :: Ty }    -- ^ this handles applications of functions and builtins
hunk ./Grin/Grin.hs 171
---    grinPrimitives :: [(Primitive,Builtin)],
hunk ./Grin/Grin.hs 401
-    typecheck te a@(App fn as) = do
+    typecheck te a@(App fn as t) = do
hunk ./Grin/Grin.hs 404
-        if as'' == as' then return t' else
-            fail $ "App: arguments do not match: " ++ show a
+        if t' == t then
+            if as'' == as' then return t' else
+                fail $ "App: arguments do not match: " ++ show a
+         else fail $ "App: results do not match: " ++ show a
hunk ./Grin/Grin.hs 434
---    typecheck _ Unit = return tyUnit
hunk ./Grin/Grin.hs 443
---    typecheck _ (NodeC {}) = return TyNode
hunk ./Grin/Grin.hs 451
+instance CanType Exp Ty where
+    getType (_ :>>= (_ :-> e2)) = getType e2
+    getType (Prim p _) = snd (primType p)
+    getType App { expType = t } = t
+    getType (Store v) = TyPtr (getType v)
+    getType (Return v) = getType v
+    getType (Fetch v) = case getType v of
+        TyPtr t -> t
+        _ -> error "Exp.getType: fetch of non-pointer type"
+    getType (Error _ t) = t
+    getType (Update w v) = tyUnit
+    getType (Case _ []) = error "empty case"
+    getType (Case _ ((_ :-> e):_)) = getType e
+    getType (Cast _ t) =  t
+
hunk ./Grin/Grin.hs 494
-    freeVars (App a vs) =  freeVars vs
+    freeVars (App a vs _) =  freeVars vs
hunk ./Grin/Grin.hs 531
-    freeVars (App a vs) = Set.singleton a `Set.union` freeVars vs
+    freeVars (App a vs _) = Set.singleton a `Set.union` freeVars vs
hunk ./Grin/Interpret.hs 40
-        g (App t [l@Lit {}]) | t == funcEval = return l
-        g (App t [Const n]) | t == funcEval = return n
+        g (App t [l@Lit {}] _) | t == funcEval = return l
+        g (App t [Const n] _) | t == funcEval = return n
hunk ./Grin/Interpret.hs 47
-    v <- g (App funcMain [])
+    v <- g (App funcMain [] tyUnit)
hunk ./Grin/Interpret.hs 62
-    f env (App a xs) = do
+    f env (App a xs ty) = do
hunk ./Grin/Interpret.hs 64
-            putErrLn $ render (prettyExp mempty $ App a xs')
+            putErrLn $ render (prettyExp mempty $ App a xs' ty)
hunk ./Grin/Interpret.hs 68
-            Nothing -> error $ "Unknown App: " ++ show (App a xs')
+            Nothing -> error $ "Unknown App: " ++ show (App a xs' ty)
hunk ./Grin/Interpret.hs 127
-        | n == (1::Int) = f mempty (App (toAtom $ 'f':rs) (xs ++ [y]))
+        | n == (1::Int) = f mempty (App (toAtom $ 'f':rs) (xs ++ [y]) TyNode)  -- TODO, right?
hunk ./Grin/Interpret.hs 139
-        | 'F':rs <- t' = f mempty (App (toAtom $ 'f':rs) xs)
-        | 'B':rs <- t' = f mempty (App (toAtom $ 'b':rs) xs)
+        | 'F':rs <- t' = f mempty (App (toAtom $ 'f':rs) xs TyNode)  -- TODO, right?
+        | 'B':rs <- t' = f mempty (App (toAtom $ 'b':rs) xs TyNode)  -- TODO, right?
hunk ./Grin/Linear.hs 55
-    h (App a [_,b]) | a == funcApply = omegaize b
-    h (App a [Var v _]) | a == funcEval = eval v
-    h (App a vs) = fuse a vs
+    h (App a [_,b] _) | a == funcApply = omegaize b
+    h (App a [Var v _] _) | a == funcEval = eval v
+    h (App a vs _) = fuse a vs
hunk ./Grin/PointsToAnalysis.hs 3
-import Atom
-import CharIO
hunk ./Grin/PointsToAnalysis.hs 6
+import Data.IORef
hunk ./Grin/PointsToAnalysis.hs 8
+import List(sort,intersperse)
+import Maybe
+import Monad
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
+import Atom
+import CharIO
hunk ./Grin/PointsToAnalysis.hs 17
+import Fixer
hunk ./Grin/PointsToAnalysis.hs 19
+import Grin.EvalInline
hunk ./Grin/PointsToAnalysis.hs 22
-import List(sort)
-import List(intersperse)
-import Maybe
-import Monad
+import Grin.Linear
hunk ./Grin/PointsToAnalysis.hs 24
-import Data.IORef
-import qualified Data.Map as Map
-import qualified Data.Set as Set
hunk ./Grin/PointsToAnalysis.hs 27
-import Grin.EvalInline
-import Fixer
-import Grin.Linear
hunk ./Grin/PointsToAnalysis.hs 295
-        g (App a [vr@(Var v _)] :>>= vb :-> Return vb' :>>= node@(NodeC {}) :-> e)
+        g (App a [vr@(Var v _)] _ :>>= vb :-> Return vb' :>>= node@(NodeC {}) :-> e)
hunk ./Grin/PointsToAnalysis.hs 298
-        g (App a [vr@(Var v _)])
+        g (App a [vr@(Var v _)] _)
hunk ./Grin/PointsToAnalysis.hs 300
-        g app@(App a [vr@(Var v _),y])
+        g app@(App a [vr@(Var v _),y] _)
hunk ./Grin/PointsToAnalysis.hs 304
-        g n@(App a _)
+        g n@(App a _ _)
hunk ./Grin/PointsToAnalysis.hs 364
-    g (App fe [v]) | fe == funcEval = do
+    g (App fe [v] _) | fe == funcEval = do
hunk ./Grin/PointsToAnalysis.hs 368
-    g (App fe [v,x]) | fe == funcApply = do
+    g (App fe [v,x] _) | fe == funcApply = do
hunk ./Grin/PointsToAnalysis.hs 375
-    g (App a vs ) | a `notElem` [funcEval,funcApply]  = do
+    g (App a vs _) | a `notElem` [funcEval,funcApply]  = do
hunk ./Grin/Show.hs 59
-prettyExp vl (App t [v]) | t == funcEval = vl <> keyword "eval" <+> pVal v
-prettyExp vl (App t [a,b]) | t == funcApply = vl <> keyword "apply" <+> pVal a <+> pVal b
-prettyExp vl (App a vs)  = vl <> func (fromAtom a) <+> hsep (map pVal vs)
+prettyExp vl (App t [v] _) | t == funcEval = vl <> keyword "eval" <+> pVal v
+prettyExp vl (App t [a,b] _) | t == funcApply = vl <> keyword "apply" <+> pVal a <+> pVal b
+prettyExp vl (App a vs _)  = vl <> func (fromAtom a) <+> hsep (map pVal vs)
hunk ./Grin/Simplify.hs 87
-    inline app@(App fn as)
+    inline app@(App fn as _)
hunk ./Grin/Simplify.hs 102
-    getCS (b,app@(App a [vr@Var {}])) | a == funcEval = return $ Map.fromList [(app,Return b), (Store b,Return vr)]
+    getCS (b,app@(App a [vr@Var {}] _)) | a == funcEval = return $ Map.fromList [(app,Return b), (Store b,Return vr)]
hunk ./Grin/Simplify.hs 104
-    getCS (b@Var {},Store v@(Var _ _)) = return $ Map.singleton (App funcEval [b]) (Return v)     -- TODO - only works if node stores have always been evaluated.
-    getCS (b@Var {},Store v@(NodeC t _)) | tagIsWHNF t, t /= tagHole = return $ Map.fromList [(Store v,Return b),(Fetch b,Return v),(App funcEval [b],Return v)]
+    getCS (b@Var {},Store v@(Var _ _)) = return $ Map.singleton (App funcEval [b] TyNode) (Return v)     -- TODO - only works if node stores have always been evaluated.
+    getCS (b@Var {},Store v@(NodeC t _)) | tagIsWHNF t, t /= tagHole = return $ Map.fromList [(Store v,Return b),(Fetch b,Return v),(App funcEval [b] TyNode,Return v)]
hunk ./Grin/Simplify.hs 107
-    getCS (b@Var {},Return (Const v)) = return $ Map.fromList [(Fetch b,Return v),(App funcEval [b],Return v)]
+    getCS (b@Var {},Return (Const v)) = return $ Map.fromList [(Fetch b,Return v),(App funcEval [b] TyNode,Return v)]
hunk ./Grin/Simplify.hs 112
-    g (App n _) = fromAtom n
+    g App { expFunction = n } = fromAtom n
hunk ./Grin/Simplify.hs 137
-    f _ (_ :-> App fn' _) | fn == fn' = False
+    f _ (_ :-> App { expFunction = fn' }) | fn == fn' = False
hunk ./Grin/Whiz.hs 156
-    f (App a vs) = do
+    f (App a vs t) = do
hunk ./Grin/Whiz.hs 158
-        return $ App a vs'
+        return $ App a vs' t