Generate settable function pointer for monkey patching.

1 files changed, 59 insertions, 6 deletions

diff --git a/c2haskell.hs b/c2haskell.hs
index 832e613..4f2644b 100644
--- a/c2haskell.hs
+++ b/c2haskell.hs
@@ -21,6 +21,7 @@ import qualified Data.Set           as Set
 import Language.C.Data.Ident        as C
 import Language.C                   as C hiding (prettyUsingInclude)
 import Language.C.System.GCC
+import Language.C.Data.Position
 import Language.Haskell.Exts.Parser as HS
 import Language.Haskell.Exts.Pretty as HS
 import Language.Haskell.Exts.Syntax as HS
@@ -331,13 +332,15 @@ commented s = unlines $ map ("-- " ++) (lines s)
 
 data C2HaskellOptions = C2HaskellOptions
     { selectFunction :: Maybe String
-    , prettyC :: Bool
-    , verbose :: Bool
+    , prettyC        :: Bool
+    , prettyTree     :: Bool
+    , verbose        :: Bool
     }
 
 defopts = C2HaskellOptions
     { selectFunction = Nothing
     , prettyC        = False
+    , prettyTree     = False
     , verbose        = False
     }
 
@@ -345,6 +348,9 @@ parseOptions []            opts = opts
 parseOptions ("-f":f:args) opts = parseOptions args opts
     { selectFunction = Just f
     }
+parseOptions ("-t":args) opts = parseOptions args opts
+    { prettyTree = True
+    }
 parseOptions ("-p":args) opts = parseOptions args opts
     { prettyC = True
     }
@@ -446,7 +452,46 @@ c2haskell opts cs missings (CTranslUnit edecls _) = do
                 mapM_ (putStr . commented . show . pretty) (mutations (body d))
                 -}
             -}
-        Just cfun -> goMissing db cfun
+        Just cfun -> do
+          forM_ (Map.lookup cfun $ syms db) $ \si -> do
+            forM_ (take 1 $ symbolSource si) $ \d -> do
+                putStrLn $ show $ pretty d
+                putStrLn $ show $ pretty $ makeFunctionPointer d
+                putStrLn $ take 2048 $ ppShow $ everywhere (mkT eraseNodeInfo) <$> makeFunctionPointer d
+
+-- TODO: make idempotent
+makeStatic :: [CDeclarationSpecifier NodeInfo] -> [CDeclarationSpecifier NodeInfo]
+makeStatic xs = CStorageSpec (CStatic undefNode) : xs
+-- makeStatic xs = CStorageSpec (CStatic ()) : xs
+
+makePointer1 (Just (CDeclr a bs c d e))
+           = (Just (CDeclr a (p:bs) c d e))
+ where
+    p = CPtrDeclr [] undefNode
+    -- p = CPtrDeclr [] ()
+
+makePointer :: [(Maybe (CDeclarator NodeInfo), b, c)]
+                     -> [(Maybe (CDeclarator NodeInfo), b, c)]
+makePointer ((a,b,c):zs) = (makePointer1 a,b,c):zs
+
+setNull1 :: Maybe (CInitializer NodeInfo)
+setNull1 = Just (CInitExpr (CVar (C.Ident "NULL" 0 undefNode) undefNode) undefNode)
+
+setNull ((a,_,b):zs) = (a,setNull1,b):zs
+
+makeFunctionPointer :: CExternalDeclaration NodeInfo
+                             -> CExternalDeclaration NodeInfo
+makeFunctionPointer d@(CDeclExt (CDecl xs ys pos)) = changeName ("f_"++) $ CDeclExt (CDecl (makeStatic xs) (setNull $ makePointer ys) pos)
+makeFunctionPointer d = d
+
+changeName2 f     (Just (CDeclr (Just (C.Ident nm     n p)) bs c d e))
+                = (Just (CDeclr (Just (C.Ident (f nm) n p)) bs c d e))
+changeName2 f d = d
+
+changeName1 f ((a,b,c):zs) = (changeName2 f a,b,c):zs
+
+changeName f d@(CDeclExt (CDecl xs ys pos)) = CDeclExt (CDecl xs (changeName1 f ys) pos)
+changeName f d                              = d
 
 makeAcceptableDecl (HS.TypeDecl a (DHead b (HS.Ident c signame)) ftyp)
                 =  (HS.TypeDecl a (DHead b (HS.Ident c signame)) (makeFunctionUseIO $ makeAcceptableImport ftyp))
@@ -560,6 +605,10 @@ linker cargs fname = do
         _           -> return ()
     return $ missingSymbols linkerrs
 
+eraseNodeInfo :: NodeInfo -> NodeInfo
+eraseNodeInfo _ = OnlyPos p (p,0) -- undefNode value doesn't ppShow well.
+ where
+    p = position 0 "" 0 0 Nothing
 
 main :: IO ()
 main = do
@@ -570,9 +619,13 @@ main = do
     fromMaybe (putStrLn usageString) $ m <&> \(hopts,cargs,fname) -> do
         r <- parseCFile (newGCC "gcc") Nothing cargs fname
         cs <- readComments fname
-        if prettyC hopts -- -p
-            then do
+        case () of
+            _ | prettyC hopts -- -p
+                 -> do
                 print (fmap prettyUsingInclude r)
-            else do
+            _ | prettyTree hopts -- -t
+                 -> do
+                putStrLn $ ppShow $ everywhere (mkT eraseNodeInfo) <$> r
+            _    -> do
                 syms <- linker cargs fname
                 either print (c2haskell hopts cs syms) r