Use dynCall when calling FunPtr types.

1 files changed, 62 insertions, 25 deletions

diff --git a/monkeypatch.hs b/monkeypatch.hs
index 8e2dcf8..14359fe 100644
--- a/monkeypatch.hs
+++ b/monkeypatch.hs
@@ -199,6 +199,15 @@ data FormalLambda = FormalLambda { formGo :: String
                                  , formExp :: HS.Exp ()
                                  }
 
+modifyFormal :: (HS.Exp () -> HS.Exp ())
+                -> FormalLambda -> FormalLambda
+modifyFormal f (FormalLambda s x) = FormalLambda s (f x)
+
+-- modifyLambda f (Lambda l p x) = Lambda l p (f x)
+
+modifyOperand1 :: (HS.Exp l -> HS.Exp l) -> HS.Exp l -> HS.Exp l
+modifyOperand1 f (InfixApp l x op y) = InfixApp l (f x) op y
+
 informalize :: FormalLambda -> HS.Exp ()
 informalize (FormalLambda k x) = Lambda () [hspvar k] x
 
@@ -384,21 +393,7 @@ grokExpression fe (CComma exps _) = do
         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'] (mkcomp $ hsvar hv) { compFree = Map.singleton hv () }
-grokExpression fe (C.CCall (CVar fn _) exps _) = do
-    gs <- mapM (grokExpression fe) exps
-    let ss = concatMap fst gs -- TODO: resolve variable name conflicts
-        hv = "r" ++ identToString fn
-        -- cll = foldl (App ()) (hsvar (identToString fn)) $ map (comp . snd) gs
-        -- frees = foldr Map.union (Map.singleton (identToString fn) ()) (map (compFree . snd) gs)
-        fn' = identToString fn
-        cll = foldl (\f x -> App () <$> f <*> x) (mkcomp $ hsvar fn'){compFree = Map.singleton fn' ()} (map snd gs)
-        k = uniqIdentifier "go" (compFree s)
-        s = (fmap (\c -> FormalLambda k $ infixOp c ">>=" $ Lambda () [hspvar hv] (hsvar k)) cll)
-                { compIntro = Map.singleton hv ()
-                }
-    return $ (,) (ss++[s]) (mkcomp $ hsvar hv)
-        { compFree  = Map.singleton hv ()
-        }
+grokExpression fe (C.CCall fn exps u) = grokCall fe True (C.CCall fn exps u)
 grokExpression fe (CStatExpr (CCompound idents xs _) _) = do
     let (y,ys) = splitAt 1 (reverse xs)
     y' <- case y of
@@ -445,6 +440,51 @@ grokExpression fe (CMember cvar fld isptr _) = do
     return $ (,) [s] (mkcomp $ hsvar hv){ compFree = Map.singleton hv () }
 grokExpression fe _ = Nothing
 
+grokCall :: FunctionEnvironment
+            -> Bool
+            -> CExpression a
+            -> Maybe ([Computation FormalLambda], Computation (HS.Exp ()))
+grokCall fe wantsRet (C.CCall (CVar fn _) exps _) = do
+    gs <- mapM (grokExpression fe) exps
+    let ss = concatMap fst gs -- TODO: resolve variable name conflicts
+        hv = "r" ++ identToString fn
+        -- cll = foldl (App ()) (hsvar (identToString fn)) $ map (comp . snd) gs
+        -- frees = foldr Map.union (Map.singleton (identToString fn) ()) (map (compFree . snd) gs)
+        fn' = identToString fn
+        cll = foldl (\f x -> App () <$> f <*> x) (mkcomp $ hsvar fn'){compFree = Map.singleton fn' ()} (map snd gs)
+        k = uniqIdentifier "go" (compFree s)
+        s | wantsRet = (fmap (\c -> FormalLambda k $ infixOp c ">>=" $ Lambda () [hspvar hv] (hsvar k)) cll)
+                            { compIntro = Map.singleton hv ()
+                            }
+          | otherwise = fmap (\c -> FormalLambda k $ infixOp c ">>" (hsvar k)) cll
+    return $ (,) (ss++[s]) (mkcomp $ hsvar hv)
+        { compFree  = Map.singleton hv ()
+        }
+grokCall fe wantsRet (C.CCall fnx@(CMember cvar fld isptr _) exps _) = do
+    -- We're calling a FunPtr so a "dynamic" import will need to be declared.
+    -- We'll assume that a dynCall type class method points to it.
+    -- fun <- dynCall <$> get @fld cvar
+    -- fun arg1 arg2 ...
+    (fss,fn) <- grokExpression fe fnx
+    let getfn = case reverse fss of
+            fnst:fs -> reverse $ (modifyFormal (modifyOperand1 $ infixOp (hsvar "callDyn") "<$>") <$> fnst) : fs
+            []      -> []
+    gs <- mapM (grokExpression fe) exps
+    let ss = getfn ++ concatMap fst gs -- TODO: resolve variable name conflicts
+        hv = "r" ++ fn'
+        -- cll = foldl (App ()) (hsvar (identToString fn)) $ map (comp . snd) gs
+        -- frees = foldr Map.union (Map.singleton (identToString fn) ()) (map (compFree . snd) gs)
+        fn' = concat (Map.keys $ compFree fn)
+        cll = foldl (\f x -> App () <$> f <*> x) fn (map snd gs)
+        k = uniqIdentifier "go" (compFree s)
+        s | wantsRet = (fmap (\c -> FormalLambda k $ infixOp c ">>=" $ Lambda () [hspvar hv] (hsvar k)) cll)
+                            { compIntro = Map.singleton hv ()
+                            }
+          | otherwise = fmap (\c -> FormalLambda k $ infixOp c ">>" (hsvar k)) cll
+    return $ (,) (ss++[s]) (mkcomp $ hsvar hv)
+        { compFree  = Map.singleton hv ()
+        }
+grokCall _ _ _ = Nothing
 
 
 grokInitialization :: Foldable t1 =>
@@ -515,6 +555,7 @@ promote fe y@(Lit () (Int () n _)) | (n==0 || n==1) &&  hasBool (fe Map.! "") =
         1 -> "True"
 promote _ y = y
 
+
 grokStatement :: FunctionEnvironment -> CCompoundBlockItem a -> Maybe (Computation FormalLambda)
 grokStatement fe (CBlockStmt (CReturn (Just exp) _)) = do
     (xs,x) <- grokExpression fe exp
@@ -573,18 +614,13 @@ grokStatement fe (CBlockStmt (CExpr (Just
                                     fieldinit) ">>" (hsvar k1)
             }
     return $ fmap (FormalLambda k1) $ foldr applyComputation x' xs
-grokStatement fe (CBlockStmt (CExpr (Just
-                    (C.CCall cvarfun exps _)) _)) = do
+grokStatement fe (CBlockStmt (CExpr (Just (C.CCall cvarfun exps a)) _)) = do
     -- This case is technically not needed, but it makes slightly cleaner output
     -- by avoiding a bind operation.
-    fn <- cvarName cvarfun
-    gs <- mapM (grokExpression fe) exps
-    let k = uniqIdentifier "go" (compFree s1)
-        cll = foldl (\f x -> App () <$> f <*> x) (mkcomp $ hsvar fn){compFree = Map.singleton fn ()} $ map snd gs
-        s1 = fmap (`infixOp` ">>") cll
-        s = s1 <*> mkcomp (hsvar k)
-        x = foldr applyComputation s $ concatMap fst gs
-    return $ fmap (FormalLambda k) x
+    (ss,_) <- grokCall fe False (C.CCall cvarfun exps a)
+    let k = uniqIdentifier "go" (compFree r `Map.union` compIntro r)
+        r = FormalLambda k <$> foldr applyComputation (mkcomp $ hsvar k) ss
+    return r
 grokStatement fe (CBlockStmt (CExpr (Just
                 (CAssign CAssignOp cvarnew
                     (C.CCall cvarfun [] _) _)) _)) = do
@@ -615,6 +651,7 @@ grokStatement fe (CBlockStmt (CExpr (Just (CUnary CPostIncOp (CMember (CVar cv0
                                     (hsvar "succ")) ">>" (hsvar k1)
             }
 grokStatement fe (CBlockStmt (CExpr mexpr _)) = do
+    -- trace ("CExpr statement: " ++ take 50 (show $ fmap (fmap $ const ()) mexpr)) $ return ()
     (ss,pre) <- maybe (Just $ (,) [] $ mkcomp id)
                       (let -- Discard pure value since we are interested only in side-effects.
                            discard = const $ mkcomp id