Distinguish formal lambda type.

1 files changed, 43 insertions, 37 deletions

diff --git a/monkeypatch.hs b/monkeypatch.hs
index e58cc2e..0b115e3 100644
--- a/monkeypatch.hs
+++ b/monkeypatch.hs
@@ -176,12 +176,17 @@ infixOp x op y = InfixApp () x (QVarOp () (UnQual () (Symbol () op))) y
 infixFn :: HS.Exp () -> String -> HS.Exp () -> HS.Exp ()
 infixFn x fn y = InfixApp () x (QVarOp () (UnQual () (HS.Ident () fn))) y
 
+data FormalLambda = FormalLambda { formGo :: String
+                                 , formExp :: HS.Exp ()
+                                 }
 
+informalize :: FormalLambda -> HS.Exp ()
+informalize (FormalLambda k x) = Lambda () [hspvar k] x
 
-applyComputation :: Computation (HS.Exp ()) -> Computation (HS.Exp ()) -> Computation (HS.Exp ())
-applyComputation a@Computation{ comp = (Lambda () [PVar () govar] exp) } b =
-    let matchgo (Var () (UnQual () v)) = v==govar
-        matchgo _                      = False
+applyComputation :: Computation FormalLambda -> Computation (HS.Exp ()) -> Computation (HS.Exp ())
+applyComputation a@Computation{ comp = FormalLambda govar exp } b =
+    let matchgo (Var () (UnQual () (HS.Ident () v))) = v==govar
+        matchgo _                                    = False
     in case listify matchgo exp of
         (_:_:_) -> error "TODO: Multiple go-refs; make let binding."
         _       -> Computation
@@ -191,7 +196,6 @@ applyComputation a@Computation{ comp = (Lambda () [PVar () govar] exp) } b =
                                       | otherwise   = x
                           in everywhere (mkT subst) exp
             }
-applyComputation a b = a
 
 varmap :: [String] -> Map String ()
 varmap vs = Map.fromList $ map (,()) vs
@@ -203,11 +207,11 @@ varmap vs = Map.fromList $ map (,()) vs
 -}
 
 
-renameIntros :: forall v st. (Typeable st, Data st) =>
-                [Computation (HS.Exp st)]
+renameIntros :: forall v st a. (Typeable st, Data st) =>
+                [Computation FormalLambda]
                 -> Computation (HS.Exp st)
                 -> Map String v
-                -> ([Computation (HS.Exp st)], Computation (HS.Exp st))
+                -> ([Computation FormalLambda], Computation (HS.Exp st))
 renameIntros bs cb vs = (bs',cb')
  where
     (rs,bs') = unzip $ map go bs
@@ -230,7 +234,7 @@ renameIntros bs cb vs = (bs',cb')
                 | s==x  = PVar (la::st) (HS.Ident lb v)
             subst p = p
         in if x/=v then (,) ((x,v):rs) c { compIntro = Map.insert v () $ Map.delete x (compIntro c)
-                                         , comp = everywhere (mkT subst) (comp c)
+                                         , comp = (comp c) { formExp = everywhere (mkT subst) (formExp $ comp c) }
                                          }
                    else (rs,c)
 
@@ -277,7 +281,7 @@ isGlobalRef fe sym = fromMaybe False $ do
 -- expression.
 grokExpression :: FunctionEnvironment
                   -> CExpression a
-                  -> Maybe ([Computation (HS.Exp ())], Computation (HS.Exp ()))
+                  -> Maybe ([Computation FormalLambda], Computation (HS.Exp ()))
 grokExpression fe (CVar cv _) =
     let v = identToString cv
     in Just $
@@ -286,7 +290,7 @@ grokExpression fe (CVar cv _) =
                      s = Computation
                             { compFree  = Map.singleton v ()
                             , compIntro = Map.singleton hv ()
-                            , comp      = Lambda () [hspvar k]
+                            , comp      = FormalLambda k
                                             $ infixOp (App () (hsvar "peek") (hsvar v)) ">>="
                                             $ Lambda () [hspvar hv] (hsvar k)
                             }
@@ -333,7 +337,7 @@ grokExpression fe (CUnary CAdrOp (CVar cv0 _) _) = do
         ss = pure Computation
                 { compFree = Map.singleton cv ()
                 , compIntro = Map.singleton hv ()
-                , comp = Lambda () [hspvar k]
+                , comp = FormalLambda k
                             $ infixFn (hsvar cv)
                                       "withPointer"
                                       (Lambda () [hspvar hv] (hsvar k))
@@ -369,11 +373,13 @@ grokExpression fe (CComma exps _) = do
     gs <- mapM (grokExpression fe) exps
     let gs2 = map (\(ss,x) -> foldr applyComputation (App () (hsvar "return") <$> x) ss) gs
         parn e = Paren () e
-        ps = map (\x -> let k = uniqIdentifier "go" (compFree x) in fmap (\xx -> Lambda () [hspvar k] (infixOp (parn xx) ">>" (hsvar k))) x) (init gs2)
+        ps = map (\x -> let k = uniqIdentifier "go" (compFree x)
+                         in fmap (\xx -> FormalLambda k (infixOp (parn xx) ">>" (hsvar k))) x)
+                 (init gs2)
         s = foldr applyComputation (last gs2) ps
         hv = "u"
         k = uniqIdentifier "go" (compFree s)
-        s' = fmap (\x ->  Lambda () [hspvar k] (infixOp (parn x) ">>=" (Lambda () [hspvar hv] (hsvar k)))) s
+        s' = fmap (\x ->  FormalLambda k (infixOp (parn x) ">>=" (Lambda () [hspvar hv] (hsvar k)))) s
     -- TODO: It would be cleaner if I could return only a statement and not an expression.
     return ([s'],Computation (Map.singleton hv ()) Map.empty (hsvar hv))
 grokExpression fe (C.CCall (CVar fn _) exps _) = do
@@ -386,7 +392,7 @@ grokExpression fe (C.CCall (CVar fn _) exps _) = do
         s = Computation
                 { compFree = frees
                 , compIntro = Map.singleton hv ()
-                , comp = Lambda () [hspvar k]
+                , comp = FormalLambda k
                             $ infixOp cll ">>="
                                 $ Lambda () [hspvar hv] (hsvar k)
                 }
@@ -408,7 +414,7 @@ grokExpression fe (CStatExpr (CCompound idents xs _) _) = do
         s = Computation
                 { compFree = compFree s1
                 , compIntro = Map.singleton hv ()
-                , comp = Lambda () [hspvar k]
+                , comp = FormalLambda k
                             $ infixOp (comp s1) ">>="
                                 $ Lambda () [hspvar hv] (hsvar k)
                 }
@@ -423,7 +429,7 @@ grokExpression fe (CAssign CAssignOp cvar expr _) = do
     let k = uniqIdentifier "go" (Map.insert v () $ foldr (\s m -> compFree s `Map.union` compIntro s `Map.union` m) Map.empty ss)
         s = x
             { compIntro = Map.singleton v ()
-            , comp = Lambda () [hspvar k]
+            , comp = FormalLambda k
                 $ infixOp (App () (hsvar "return") (comp x)) ">>="
                     $ Lambda () [hspvar v] (hsvar k)
             }
@@ -439,7 +445,7 @@ grokInitialization :: Foldable t1 =>
                       FunctionEnvironment
                       -> t1 (CDeclarationSpecifier t2)
                       -> (Maybe (CDeclarator a1), CInitializer a2)
-                      -> Maybe (Computation (HS.Exp ()))
+                      -> Maybe (Computation FormalLambda)
 grokInitialization fe _ (Just (CDeclr (Just cv0) _ _ _ _),CInitExpr exp _) = do
     let v = identToString cv0
     (xs,x) <- grokExpression fe exp
@@ -448,7 +454,7 @@ grokInitialization fe _ (Just (CDeclr (Just cv0) _ _ _ _),CInitExpr exp _) = do
                 fmap (\exp -> infixOp exp ">>="
                                 $ Lambda () [hspvar v] (hsvar k)) hsexp
         k = uniqIdentifier "go" (compFree ret)
-    return $ fmap (\exp -> Lambda () [hspvar k] exp) ret
+    return $ fmap (FormalLambda k) ret
 grokInitialization fe ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = do
     let v = identToString cv0
     -- let k = uniqIdentifier "go" (varmap [v])
@@ -471,24 +477,24 @@ grokInitialization fe ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = d
                                 fieldinit = comp x
                                 fieldlbl = identToString m
                             return x
-                                { comp = Lambda () [hspvar k1]
+                                { comp = FormalLambda k1
                                             $ infixOp
                                                 (App () (App () (App () (hsvar "set")
                                                                    (TypeApp () (TyPromoted () (PromotedString () fieldlbl fieldlbl))))
                                                                 (hsvar v))
                                                         fieldinit) ">>" (hsvar k1)
                                 }
-                    return $ fmap (\exp -> Lambda () [hspvar k2] exp) ret
+                    return $ fmap (FormalLambda k2) ret
             let newstruct = Computation
                         { compFree = Map.empty -- todo
                         , compIntro = Map.singleton v ()
-                        , comp = Lambda () [hspvar k]
+                        , comp = FormalLambda k
                             $ infixOp (App () (hsvar "newStruct") (TypeApp () (TyCon () (UnQual () hident)))) ">>="
                                       $ Lambda () [hspvar v] (hsvar k)
                         }
                 k = uniqIdentifier "go" Map.empty -- (compFree ret) TODO
                 ret = foldr applyComputation (Computation Map.empty Map.empty (hsvar k)) $ newstruct : assigns
-            return $ fmap (\exp -> Lambda () [hspvar k] exp) ret
+            return $ fmap (FormalLambda k) ret
         _ -> Nothing
 grokInitialization _ _ _ = Nothing
 
@@ -502,14 +508,14 @@ promote fe y@(Lit () (Int () n _)) | (n==0 || n==1) &&  hasBool (fe Map.! "") =
         1 -> "True"
 promote _ y = y
 
-grokStatement :: FunctionEnvironment -> CCompoundBlockItem a -> Maybe (Computation (HS.Exp ()))
+grokStatement :: FunctionEnvironment -> CCompoundBlockItem a -> Maybe (Computation FormalLambda)
 grokStatement fe (CBlockStmt (CReturn (Just exp) _)) = do
     (xs,x) <- grokExpression fe exp
     let k = uniqIdentifier "go" (compFree x `Map.union` compIntro x)
         x' = fmap (\y -> App () (hsvar "return") $ promote (fnArgs fe) y) x
-    return $ fmap (\y -> Lambda () [hspvar k] y) $ foldr applyComputation x' xs
+    return $ fmap (\y -> FormalLambda k y) $ foldr applyComputation x' xs
 grokStatement fe (CBlockStmt (CReturn Nothing _)) =
-    Just $ Computation Map.empty Map.empty $ Lambda () [hspvar "go"] retUnit
+    Just $ Computation Map.empty Map.empty $ FormalLambda "go" retUnit
 grokStatement fe (CBlockStmt (CIf exp thn els _)) = do
     (xs,x) <- grokExpression fe exp
     let mkif0 = If () (comp x)
@@ -530,7 +536,7 @@ grokStatement fe (CBlockStmt (CIf exp thn els _)) = do
     ss <- sequence $ map (grokStatement fe) stmts
     let s = foldr applyComputation (Computation Map.empty Map.empty (hsvar k)) ss
         k = uniqIdentifier "go" (Map.union (compFree x) (compFree s))
-    return $ fmap (Lambda () [hspvar k]) $ flip (foldr applyComputation) xs Computation
+    return $ fmap (FormalLambda k) $ flip (foldr applyComputation) xs Computation
         { compFree = compFree x `Map.union` compFree s
         , compIntro = compIntro s
         , comp = mkif (comp s) (hsvar k)
@@ -542,7 +548,7 @@ grokStatement fe (CBlockStmt (CExpr (Just (C.CCall (CVar (C.Ident "__assert_fail
             _                            -> Nothing
     let k = uniqIdentifier "go" (compFree x `Map.union` compIntro x)
         x' = fmap (\y -> App () (hsvar "error") y) x
-    return $ fmap (\y -> Lambda () [hspvar k] y) x'
+    return $ fmap (FormalLambda k) x'
 grokStatement fe (CBlockStmt (CExpr (Just
                 (CAssign CAssignOp
                    (CMember cvar fld isptr _) expr _)) _)) = do
@@ -558,7 +564,7 @@ grokStatement fe (CBlockStmt (CExpr (Just
                                             (hsvar v))
                                     fieldinit) ">>" (hsvar k1)
             }
-    return $ fmap (\y -> Lambda () [hspvar k1] y) $ foldr applyComputation x' xs
+    return $ fmap (FormalLambda k1) $ foldr applyComputation x' xs
 grokStatement fe (CBlockStmt (CExpr (Just
                     (C.CCall cvarfun exps _)) _)) = do
     fn <- cvarName cvarfun
@@ -572,7 +578,7 @@ grokStatement fe (CBlockStmt (CExpr (Just
             , compIntro = Map.empty
             , comp = infixOp cll ">>" (hsvar k)
             }
-    return $ fmap (Lambda () [hspvar k]) x
+    return $ fmap (FormalLambda k) x
 grokStatement fe (CBlockStmt (CExpr (Just
                 (CAssign CAssignOp cvarnew
                     (C.CCall cvarfun [] _) _)) _)) = do
@@ -582,7 +588,7 @@ grokStatement fe (CBlockStmt (CExpr (Just
     return Computation
         { compFree = Map.singleton fn ()
         , compIntro = Map.singleton v ()
-        , comp = Lambda () [hspvar k]
+        , comp = FormalLambda k
             $ infixOp (hsvar fn) ">>="
                 $ Lambda () [hspvar v] (hsvar k)
         }
@@ -593,7 +599,7 @@ grokStatement fe (CBlockStmt (CExpr (Just (CUnary CPostIncOp (CMember (CVar cv0
     return Computation
             { compFree = varmap [v]
             , compIntro = Map.empty
-            , comp = Lambda () [hspvar k1]
+            , comp = FormalLambda k1
                         $ infixOp
                             (App () (App () (App () (hsvar "modify")
                                                     (TypeApp () (TyPromoted () (PromotedString () fieldlbl fieldlbl))))
@@ -607,14 +613,14 @@ grokStatement fe (CBlockStmt (CExpr (Just expr) _)) = do
     (ss,x) <- grokExpression fe expr
     let k = uniqIdentifier "go" $ foldr Map.union Map.empty $ map compFree ss ++ map compIntro ss
         g = Computation Map.empty Map.empty (hsvar k)
-    return $ fmap (Lambda () [hspvar k]) $ foldr applyComputation g ss
+    return $ fmap (FormalLambda k) $ foldr applyComputation g ss
 -}
 grokStatement fe (CBlockStmt (CExpr mexpr _)) = do
     (ss,pre) <- maybe (Just $ (,) [] $ Computation Map.empty Map.empty id)
                       (fmap (second (fmap (\e -> infixFn e "seq"))) . grokExpression fe) mexpr
     let k = uniqIdentifier "go" (compFree s)
         s = foldr applyComputation (fmap ($ hsvar k) pre) ss
-    return $ fmap (Lambda () [hspvar k]) s
+    return $ fmap (FormalLambda k) s
 grokStatement fe (CBlockDecl (CDecl (t:ts) (v:vs) _)) = do
     -- case mapMaybe (\(cdeclr,_,_) -> cdeclr >>= \(CDeclr i _ initial _ _) -> initial) (v:vs) of
     -- case mapMaybe (\(cdeclr,_,_) -> cdeclr >>= \(CInitList xs _) -> Just xs) (v:vs) of
@@ -623,11 +629,11 @@ grokStatement fe (CBlockDecl (CDecl (t:ts) (v:vs) _)) = do
             return Computation
                 { compFree  = Map.empty
                 , compIntro = Map.empty
-                , comp      = Lambda () [hspvar "go"] $ hsvar "go"
+                , comp      = FormalLambda "go" $ hsvar "go"
                 }
         initials -> do
             gs <- mapM (grokInitialization fe $ t:ts) initials
-            return $ fmap (\exp -> Lambda () [hspvar "go"] exp)
+            return $ fmap (FormalLambda "go")
                         $ foldr applyComputation (Computation Map.empty Map.empty (hsvar "go")) gs
 grokStatement fe _ = Nothing
 
@@ -772,7 +778,7 @@ transpile o fname incs (CTranslUnit edecls _) = do
                                     case grokStatement fe d of
 
                                         Just hd -> do putStrLn $ "fr: " ++ intercalate " " (Map.keys (compFree hd))
-                                                      putStrLn $ "HS: " ++ HS.prettyPrint (comp hd)
+                                                      putStrLn $ "HS: " ++ HS.prettyPrint (informalize $ comp hd)
 
                                         Nothing -> putStrLn $ "??: " ++ ppShow (cleanTree d)
                                     putStrLn ""