diff options
author | Joe Crayne <joe@jerkface.net> | 2019-03-19 23:58:43 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2019-03-19 23:58:43 -0400 |
commit | 8bb81e3c6c677c6118e804d03d57607f5869b29d (patch) | |
tree | bd5c1d8be8e3cfc212d3167c90d817dd4d72ae86 /monkeypatch.hs | |
parent | dd3cdaec612dd8cf598ffd73d2c437d4f2f58744 (diff) |
Support nested pointers.
Diffstat (limited to 'monkeypatch.hs')
-rw-r--r-- | monkeypatch.hs | 27 |
1 files changed, 17 insertions, 10 deletions
diff --git a/monkeypatch.hs b/monkeypatch.hs index d5889f9..b5f76d4 100644 --- a/monkeypatch.hs +++ b/monkeypatch.hs | |||
@@ -13,7 +13,7 @@ import Control.Arrow (left,first,second) | |||
13 | import Data.Either | 13 | import Data.Either |
14 | import Data.Generics.Aliases | 14 | import Data.Generics.Aliases |
15 | import Data.Generics.Schemes | 15 | import Data.Generics.Schemes |
16 | import Debug.Trace | 16 | -- import Debug.Trace |
17 | import Control.Monad | 17 | import Control.Monad |
18 | import qualified Data.ByteString.Char8 as B | 18 | import qualified Data.ByteString.Char8 as B |
19 | import Data.Char | 19 | import Data.Char |
@@ -49,7 +49,7 @@ import Text.Show.Pretty | |||
49 | 49 | ||
50 | import Comments | 50 | import Comments |
51 | 51 | ||
52 | -- trace _ = id | 52 | trace _ = id |
53 | 53 | ||
54 | -- | Pretty print the given tranlation unit, but replace declarations from header files with @#include@ directives. | 54 | -- | Pretty print the given tranlation unit, but replace declarations from header files with @#include@ directives. |
55 | -- | 55 | -- |
@@ -460,6 +460,7 @@ isFunctionDecl (CFDefExt (CFunDef _ _ _ (CCompound [] _ _) _)) = True | |||
460 | isFunctionDecl _ = False | 460 | isFunctionDecl _ = False |
461 | 461 | ||
462 | 462 | ||
463 | cleanTree d = fmap (const LT) $ everywhere (mkT eraseNodeInfo) $ d | ||
463 | 464 | ||
464 | transpile :: C2HaskellOptions -> FilePath -> IncludeStack -> CTranslationUnit NodeInfo -> IO () | 465 | transpile :: C2HaskellOptions -> FilePath -> IncludeStack -> CTranslationUnit NodeInfo -> IO () |
465 | transpile o fname incs (CTranslUnit edecls _) = do | 466 | transpile o fname incs (CTranslUnit edecls _) = do |
@@ -487,7 +488,6 @@ transpile o fname incs (CTranslUnit edecls _) = do | |||
487 | -- putStrLn $ show (fmap (const LT) c) | 488 | -- putStrLn $ show (fmap (const LT) c) |
488 | putStrLn . HS.prettyPrint $ changeType makeFunctionUseIO hh | 489 | putStrLn . HS.prettyPrint $ changeType makeFunctionUseIO hh |
489 | putStrLn $ unwords (hname:as) ++ " =" | 490 | putStrLn $ unwords (hname:as) ++ " =" |
490 | cleanTree d = fmap (const LT) $ everywhere (mkT eraseNodeInfo) $ d | ||
491 | forM_ mprintHeader $ \printHeader -> do | 491 | forM_ mprintHeader $ \printHeader -> do |
492 | let bdy = concat $ take 1 $ dropWhile null $ map body $ symbolSource sym | 492 | let bdy = concat $ take 1 $ dropWhile null $ map body $ symbolSource sym |
493 | if oPrettyTree o | 493 | if oPrettyTree o |
@@ -641,9 +641,11 @@ hsTransField ctyps vars | |||
641 | trace ("fident="++show mfident) $ return () | 641 | trace ("fident="++show mfident) $ return () |
642 | trace ("ptrdeclr="++show ptrdeclr) $ return () | 642 | trace ("ptrdeclr="++show ptrdeclr) $ return () |
643 | let btyp = HS.TyCon () typname | 643 | let btyp = HS.TyCon () typname |
644 | grok :: Show a => [CDerivedDeclarator a] -> HS.Type () -> HS.Type () | ||
644 | grok bs b = case bs of | 645 | grok bs b = case bs of |
645 | [] -> b | 646 | [] -> b |
646 | (CPtrDeclr [] _:cs) -> HS.TyApp () (HS.TyCon () (hsMkName "Ptr")) (grok cs b) | 647 | CArrDeclr [] (CNoArrSize _) _:cs -> HS.TyApp () (HS.TyCon () (hsMkName "Ptr")) (grok cs b) |
648 | CPtrDeclr [] _ :cs -> HS.TyApp () (HS.TyCon () (hsMkName "Ptr")) (grok cs b) | ||
647 | CFunDeclr (Right (args,flg)) attrs _:p -> | 649 | CFunDeclr (Right (args,flg)) attrs _:p -> |
648 | let (as,ts) = unzip $ concatMap (\(CDecl rs as _) -> map fst $ hsTransField rs $ concatMap fieldInfo as) args | 650 | let (as,ts) = unzip $ concatMap (\(CDecl rs as _) -> map fst $ hsTransField rs $ concatMap fieldInfo as) args |
649 | b0 = case p of | 651 | b0 = case p of |
@@ -706,11 +708,16 @@ primtypes t = [t] | |||
706 | -- Haskell type name as string. | 708 | -- Haskell type name as string. |
707 | tname :: HS.Type () -> String | 709 | tname :: HS.Type () -> String |
708 | tname (HS.TyCon () (HS.UnQual () (HS.Ident () str))) = str | 710 | tname (HS.TyCon () (HS.UnQual () (HS.Ident () str))) = str |
709 | tname _ = "_unkonwn" | 711 | tname t = "_unknown(" ++ show (cleanTree t)++")" |
710 | 712 | ||
711 | getPtrType :: HS.Type l -> Maybe (HS.Type l) | 713 | getPtrType :: HS.Type l -> Maybe (HS.Type l) |
712 | getPtrType (HS.TyApp _ (HS.TyCon _ (HS.UnQual _ (HS.Ident _ "Ptr"))) x) = Just x | 714 | getPtrType (HS.TyApp _ (HS.TyCon _ (HS.UnQual _ (HS.Ident _ "Ptr"))) x) | isPtrType x = getPtrType x |
713 | getPtrType _ = Nothing | 715 | | otherwise = Just x |
716 | getPtrType _ = Nothing | ||
717 | |||
718 | isPtrType :: HS.Type l -> Bool | ||
719 | isPtrType (HS.TyApp _ (HS.TyCon _ (HS.UnQual _ (HS.Ident _ "Ptr"))) x) = True | ||
720 | isPtrType _ = False | ||
714 | 721 | ||
715 | -- pointers :: [HS.Decl ()] -> [String] | 722 | -- pointers :: [HS.Decl ()] -> [String] |
716 | pointers :: [HS.Type l] -> [HS.Type l] | 723 | pointers :: [HS.Type l] -> [HS.Type l] |
@@ -921,7 +928,7 @@ c2haskell opts cs cmodname missings incs (CTranslUnit edecls _) = do | |||
921 | forM_ (uniq $ ts ++ sigs2) $ \(t,ct) -> do | 928 | forM_ (uniq $ ts ++ sigs2) $ \(t,ct) -> do |
922 | case ct >>= (`Map.lookup` syms db) of | 929 | case ct >>= (`Map.lookup` syms db) of |
923 | Just si -> case take 1 (symbolSource si) >>= enumCases of | 930 | Just si -> case take 1 (symbolSource si) >>= enumCases of |
924 | [] -> hPutStrLn haskmod $ "data " ++ t | 931 | [] -> hPutStrLn haskmod $ "data-1 " ++ t |
925 | (eni,es):_ -> do | 932 | (eni,es):_ -> do |
926 | let symfile :: Maybe FilePath | 933 | let symfile :: Maybe FilePath |
927 | symfile = (listToMaybe (symbolSource si) >>= fileOfNode) | 934 | symfile = (listToMaybe (symbolSource si) >>= fileOfNode) |
@@ -949,7 +956,7 @@ c2haskell opts cs cmodname missings incs (CTranslUnit edecls _) = do | |||
949 | -> hPutStr haskmod $ commented $ "| " ++ strip s | 956 | -> hPutStr haskmod $ commented $ "| " ++ strip s |
950 | x -> hPutStr haskmod $ commented $ "x="++show x | 957 | x -> hPutStr haskmod $ commented $ "x="++show x |
951 | hPutStrLn haskmod $ unwords ["pattern",identToString e,"=",t,show n] | 958 | hPutStrLn haskmod $ unwords ["pattern",identToString e,"=",t,show n] |
952 | Nothing -> hPutStrLn haskmod $ "data " ++ t | 959 | Nothing -> hPutStrLn haskmod $ "data-2 " ++ t ++ "-- (t,ct)="++show (t,ct) |
953 | hPutStrLn haskmod "" | 960 | hPutStrLn haskmod "" |
954 | forM_ sigs $ \(_,(k,hs,d)) -> do | 961 | forM_ sigs $ \(_,(k,hs,d)) -> do |
955 | forM_ hs $ \hdecl -> do | 962 | forM_ hs $ \hdecl -> do |
@@ -1033,7 +1040,7 @@ c2haskell opts cs cmodname missings incs (CTranslUnit edecls _) = do | |||
1033 | putStrLn $ show $ pretty $ makeFunctionPointer d | 1040 | putStrLn $ show $ pretty $ makeFunctionPointer d |
1034 | putStrLn $ show $ pretty $ makeSetter d | 1041 | putStrLn $ show $ pretty $ makeSetter d |
1035 | putStrLn $ show $ pretty $ makeStub d | 1042 | putStrLn $ show $ pretty $ makeStub d |
1036 | putStrLn $ ppShow $ everywhere (mkT eraseNodeInfo) d -- <$> makeFunctionPointer d | 1043 | putStrLn $ ppShow $ cleanTree d -- <$> makeFunctionPointer d |
1037 | 1044 | ||
1038 | -- TODO: make idempotent | 1045 | -- TODO: make idempotent |
1039 | makeStatic :: [CDeclarationSpecifier NodeInfo] -> [CDeclarationSpecifier NodeInfo] | 1046 | makeStatic :: [CDeclarationSpecifier NodeInfo] -> [CDeclarationSpecifier NodeInfo] |