summaryrefslogtreecommitdiff
path: root/monkeypatch.hs
diff options
context:
space:
mode:
authorJoe Crayne <joe@jerkface.net>2019-02-25 20:35:29 -0500
committerJoe Crayne <joe@jerkface.net>2019-02-25 20:35:29 -0500
commite34407b0080fa5c7176522b42783ad3c55a0f722 (patch)
tree488ceebc1c651e9915cce43cead685b341166c85 /monkeypatch.hs
parent516e3520940959b378c71a8738456cc91878eb49 (diff)
cabal file and license
Diffstat (limited to 'monkeypatch.hs')
-rw-r--r--monkeypatch.hs956
1 files changed, 956 insertions, 0 deletions
diff --git a/monkeypatch.hs b/monkeypatch.hs
new file mode 100644
index 0000000..7c9d75d
--- /dev/null
+++ b/monkeypatch.hs
@@ -0,0 +1,956 @@
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE BangPatterns #-}
3{-# LANGUAGE DeriveFunctor #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE NondecreasingIndentation #-}
7{-# LANGUAGE QuasiQuotes #-}
8{-# LANGUAGE TemplateHaskell #-}
9module Main where
10
11import Control.Arrow (left)
12import Data.Generics.Aliases
13import Data.Generics.Schemes
14-- import Debug.Trace
15import Control.Monad
16import qualified Data.ByteString.Char8 as B
17import Data.Char
18import Data.Data
19import Data.List
20import qualified Data.IntMap as IntMap
21 ;import Data.IntMap (IntMap)
22import qualified Data.Map as Map
23 ;import Data.Map (Map)
24import Data.Maybe
25import qualified Data.Set as Set
26 ;import Data.Set (Set)
27import Language.C.Data.Ident as C
28import Language.C as C hiding (prettyUsingInclude)
29import qualified Language.C as C
30import Language.C.System.GCC
31import Language.C.System.Preprocess
32import Language.C.Data.Position
33import Language.Haskell.Exts.Parser as HS
34import Language.Haskell.Exts.Pretty as HS
35import Language.Haskell.Exts.Syntax as HS
36import Language.Haskell.TH
37import Language.Haskell.TH.Ppr
38import Language.Haskell.TH.Syntax as TH
39import System.Directory
40import System.Environment
41import System.IO
42import System.Process
43import System.Exit
44import Text.PrettyPrint (Doc, doubleQuotes, empty, text, vcat, ($$),
45 (<+>))
46import Text.Show.Pretty
47
48trace _ = id
49
50-- | Pretty print the given tranlation unit, but replace declarations from header files with @#include@ directives.
51--
52-- The resulting file may not compile (because of missing @#define@ directives and similar things), but is very useful
53-- for testing, as otherwise the pretty printed file will be cluttered with declarations from system headers.
54prettyUsingInclude :: IncludeStack -> CTranslUnit -> Doc
55prettyUsingInclude incs (CTranslUnit edecls _) =
56 vcat (map (either includeHeader pretty) $ sortBy sysfst mappedDecls)
57 where
58 (headerFiles,mappedDecls) = foldr (addDecl . tagIncludedDecls) (Set.empty,[]) edecls
59 tagIncludedDecls edecl | maybe False isHeaderFile (fileOfNode edecl) = Left ((includeTopLevel incs . posFile . posOf) edecl)
60 | otherwise = Right edecl
61 addDecl decl@(Left headerRef) (headerSet, ds)
62 | null headerRef || Set.member headerRef headerSet
63 = (headerSet, ds)
64 | otherwise = (Set.insert headerRef headerSet, decl : ds)
65 addDecl decl (headerSet,ds) = (headerSet, decl : ds)
66
67 includeHeader hFile = text "#include" <+> text hFile
68 isHeaderFile = (".h" `isSuffixOf`)
69
70 sysfst (Left ('"':a)) (Left ('<':b)) = Prelude.GT
71 sysfst _ _ = Prelude.LT
72
73includeTopLevel (IncludeStack incs) f = do
74 stacks <- maybeToList $ Map.lookup f incs
75 stack <- take 1 stacks
76 top <- take 1 $ drop 4 $ reverse (f:stack)
77 if take 1 top == "/"
78 then let ws = groupBy (\_ c -> c /='/') top
79 (xs,ys) = break (=="/include") ws
80 ys' = drop 1 ys
81 in if not (null ys') then '<': drop 1 (concat ys') ++ ">"
82 else '"':top++"\""
83 else '"':top ++"\""
84
85specs :: CExternalDeclaration a -> [CDeclarationSpecifier a]
86specs (CFDefExt (CFunDef ss _ _ _ _)) = ss
87specs (CDeclExt (CDecl ss _ _)) = ss
88specs _ = []
89
90declrSym :: CDeclarator t -> Maybe Ident
91declrSym (CDeclr m _ _ _ _) = m
92
93-- Used by update to add a symbols to the database.
94sym :: CExternalDeclaration a -> [Maybe Ident]
95sym (CFDefExt (CFunDef specs m _ _ _)) = [ declrSym m ]
96sym (CDeclExt (CDecl specs ms _)) = ms >>= \(m,_,_) -> maybe [] (pure . declrSym) m
97sym _ = []
98
99isStatic :: CDeclarationSpecifier a -> Bool
100isStatic (CStorageSpec (CStatic _)) = True
101isStatic _ = False
102
103capitalize :: String -> String
104capitalize xs = concatMap (cap . drop 1) gs
105 where
106 gs = groupBy (\a b -> b/='_') $ '_':xs
107 cap (c:cs) = toUpper c : cs
108
109transField :: CDeclaration t -> [(TH.Name, TH.Bang, TH.Type)]
110transField (CDecl [CTypeSpec (CTypeDef ctyp _)] vars _)
111 = do
112 let typname = mkName . capitalize . identToString $ ctyp
113 (var,Nothing,Nothing) <- vars
114 CDeclr (Just fident) ptrdeclr Nothing [] _ <- maybeToList var
115 let fieldName = mkName $ identToString fident
116 ftyp = case ptrdeclr of
117 [] -> ConT typname
118 [CPtrDeclr [] _] -> AppT (ConT (mkName "Ptr")) (ConT typname)
119 [ (fieldName, Bang NoSourceUnpackedness NoSourceStrictness, ftyp) ]
120transField (CDecl [CTypeSpec (CSUType (CStruct CStructTag mctyp Nothing [] _) _)] vars _)
121 | Just typname <- mkName . capitalize . identToString <$> mctyp
122 = do
123 (var,Nothing,Nothing) <- vars
124 CDeclr (Just fident) ptrdeclr Nothing [] _ <- maybeToList var
125 let fieldName = mkName $ identToString fident
126 ftyp = case ptrdeclr of
127 [] -> ConT typname
128 [CPtrDeclr [] _] -> AppT (ConT (mkName "Ptr")) (ConT typname)
129 [ (fieldName, Bang NoSourceUnpackedness NoSourceStrictness, ftyp) ]
130
131
132transField _ = []
133
134transpile (CDeclExt (CDecl [ CTypeSpec (CSUType
135 (CStruct CStructTag mbIdent (Just fields) [] _)
136 _) ]
137 []
138 _) )
139 | Just struct_name <- capitalize . identToString <$> mbIdent
140 , let typ = mkName struct_name
141 = Just $ returnQ $ DataD [] typ [] Nothing [RecC typ fs] []
142 where fs = fields >>= transField
143
144transpile _ = Nothing
145
146
147isHeaderDecl :: CNode a => a -> Bool
148isHeaderDecl = maybe False (isSuffixOf ".h") . fileOfNode
149
150-- bar :: CExternalDeclaration NodeInfo -> ()
151-- bar (CDeclExt (CDecl xs [] (NodeInfo pos poslen name))) = ()
152
153data SymbolInformation c = SymbolInformation
154 { symbolLocal :: Bool
155 , symbolStatic :: Bool
156 , symbolSource :: c
157 }
158 deriving (Eq,Ord,Show,Functor)
159
160symbolInformation = SymbolInformation
161 { symbolLocal = False
162 , symbolStatic = False
163 , symbolSource = mempty
164 }
165
166data Transpile c = Transpile
167 { syms :: Map String (SymbolInformation c)
168 }
169
170initTranspile = Transpile
171 { syms = Map.empty
172 }
173
174-- grokSymbol :: CExternalDeclaration a -> String -> Maybe SymbolInformation -> Maybe SymbolInformation
175grokSymbol d k msi =
176 let si = fromMaybe symbolInformation msi
177 in Just $ si
178 { symbolLocal = symbolLocal si || not (isHeaderDecl d)
179 , symbolStatic = symbolStatic si || any isStatic (specs d)
180 , symbolSource = d : symbolSource si
181 }
182
183update :: CExternalDeclaration NodeInfo
184 -> Transpile [CExternalDeclaration NodeInfo]
185 -> Transpile [CExternalDeclaration NodeInfo]
186update d transpile = transpile
187 { syms = foldr (\k m -> Map.alter (grokSymbol d k) k m) (syms transpile)
188 $ map (maybe "" identToString) $ sym d
189 }
190
191data FunctionSignature t = FunctionSignature
192 { funReturnType :: t
193 , funArgTypes :: [t]
194 }
195
196hsMkName :: String -> HS.QName ()
197hsMkName str = HS.UnQual () (foo () str)
198 where
199 foo = HS.Ident -- alternative: HS.Symbol
200
201
202notKnown "Word8" = False
203notKnown "Word16" = False
204notKnown "Word32" = False
205notKnown "Word64" = False
206notKnown "Int8" = False
207notKnown "Int16" = False
208notKnown "Int32" = False
209notKnown "Int64" = False
210notKnown "Bool" = False
211notKnown "Word" = False
212notKnown "Int" = False
213notKnown "Char" = False
214notKnown "()" = False
215notKnown _ = True
216
217hsTypeSpec :: CDeclarationSpecifier t -> [Either Ident String]
218hsTypeSpec (CTypeSpec (CVoidType _)) = [ Right "()" ]
219hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "size_t" _ _) _)) = [ Right "Word"]
220hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "uint8_t" _ _) _)) = [ Right "Word8"]
221hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "uint16_t" _ _) _)) = [ Right "Word16"]
222hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "uint32_t" _ _) _)) = [ Right "Word32"]
223hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "uint64_t" _ _) _)) = [ Right "Word64"]
224hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "int8_t" _ _) _)) = [ Right "Int8"]
225hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "int16_t" _ _) _)) = [ Right "Int16"]
226hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "int32_t" _ _) _)) = [ Right "Int32"]
227hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "int64_t" _ _) _)) = [ Right "Int64"]
228hsTypeSpec (CTypeSpec (CTypeDef ctyp _)) = [ Left ctyp ]
229hsTypeSpec (CTypeSpec (CBoolType _)) = [ Right "Bool"]
230hsTypeSpec (CTypeSpec (CIntType _)) = [ Right "Int"]
231hsTypeSpec (CTypeSpec (CCharType _)) = [ Right "Char"]
232hsTypeSpec (CTypeSpec (CSUType (CStruct CStructTag mctyp Nothing [] _) _)) = maybeToList $ fmap Left mctyp
233
234hsTypeSpec (CTypeSpec unhandled) = trace ("hsTypeSpec unhandled: "++ show (const () <$> unhandled)) $ []
235hsTypeSpec _ = []
236
237
238-- fieldInfo :: CDeclarator b -> (Maybe (CDeclarator b), Maybe (CInitializer b), Maybe (CExpression b))
239-- fieldInfo var = (Just var,Nothing,Nothing)
240fieldInfo :: (Maybe (CDeclarator b), Maybe (CInitializer b), Maybe (CExpression b)) -> [CDeclarator b]
241fieldInfo (Just var,_,_) = [var]
242fieldInfo _ = []
243
244-- hsTransField :: [CDeclarationSpecifier t3] -> [(Maybe (CDeclarator t2), Maybe t1, Maybe t)] -> [HS.Decl ()]
245-- recursive for function signatures.
246hsTransField :: Show b =>
247 [CDeclarationSpecifier b] -- c structure name
248 -- -> [(Maybe (CDeclarator b), Maybe (CInitializer b), Maybe (CExpression b))] -- c variable declarations
249 -> [CDeclarator b] -- c variable declarations
250 -> [(String{-field name-}, HS.Type () {- haskell type -}) ]
251hsTransField ctyps vars
252 = do
253 typname <- hsMkName . either (capitalize . identToString) id <$> (hsTypeSpec =<< ctyps)
254 trace ("typname="++show typname) $ return ()
255 -- (var,Nothing,Nothing) <- vars
256 var <- vars
257 trace ("var="++show var) $ return ()
258 -- CDeclr (Just fident) ptrdeclr Nothing [] _ <- maybeToList var
259 let CDeclr mfident ptrdeclr Nothing [] _ = var -- TODO: Look into: Irrefutable pattern failed (ctox/toxcore/DHT.c)
260 -- let CDeclr mfident ptrdeclr _ _ _ = var
261 trace ("fident="++show mfident) $ return ()
262 trace ("ptrdeclr="++show ptrdeclr) $ return ()
263 let btyp = HS.TyCon () typname
264 grok bs b = case bs of
265 [] -> b
266 (CPtrDeclr [] _:cs) -> HS.TyApp () (HS.TyCon () (hsMkName "Ptr")) (grok cs b)
267 CFunDeclr (Right (args,flg)) attrs _:p ->
268 let (as,ts) = unzip $ concatMap (\(CDecl rs as _) -> hsTransField rs $ concatMap fieldInfo as) args
269 b0 = case p of
270 CPtrDeclr [] _:cs -> HS.TyApp () (HS.TyCon () (hsMkName "Ptr")) (grok cs b)
271 [] -> b
272 in foldr (HS.TyFun ()) b0 ts
273 _ -> HS.TyCon () (hsMkName $ show $ map (fmap (const ())) ptrdeclr)
274 ftyp = grok ptrdeclr btyp
275 fieldName = maybe ("_") identToString mfident
276 [ ( fieldName, ftyp ) ]
277{-
278transField (CDecl [CTypeSpec (CSUType (CStruct CStructTag mctyp Nothing [] _) _)] vars _)
279 | Just typname <- mkName . capitalize . identToString <$> mctyp
280 = do
281 (var,Nothing,Nothing) <- vars
282 CDeclr (Just fident) ptrdeclr Nothing [] _ <- maybeToList var
283 let fieldName = mkName $ identToString fident
284 ftyp = case ptrdeclr of
285 [] -> ConT typname
286 [CPtrDeclr [] _] -> AppT (ConT (mkName "Ptr")) (ConT typname)
287 [ (fieldName, Bang NoSourceUnpackedness NoSourceStrictness, ftyp) ]
288hsTransField _ _ = []
289-}
290
291extractType (HS.TypeDecl _ _ ftyp) = ftyp
292extractType (HS.TypeSig _ _ ftyp) = ftyp
293extractType _ = TyCon () (Special () (UnitCon ()))
294
295{-
296hsTransFieldExt :: Show b =>
297 [CDeclarationSpecifier b]
298 -> [(Maybe (CDeclarator b), Maybe (CInitializer b),
299 Maybe (CExpression b))]
300 -> [Decl ()]
301-}
302hsTransFieldExt :: Show b =>
303 [CDeclarationSpecifier b] -> [CDeclarator b] -> [Decl ()]
304hsTransFieldExt rs as = concatMap (\(fieldName,ftyp)-> [ HS.TypeSig () [ HS.Ident () fieldName ] ftyp ])
305 $ hsTransField rs as
306
307hsTransSig rs as = concatMap (\(fieldName,ftyp)-> [ HS.TypeDecl () (DHead () (HS.Ident () ("Sig_" ++ fieldName))) ftyp ])
308 $ hsTransField rs as
309
310types (HS.TypeDecl _ _ typ) = primtypes typ
311
312primtypes (HS.TyFun _ a b) = primtypes a ++ primtypes b
313primtypes t = [t]
314
315tname (HS.TyCon () (HS.UnQual () (HS.Ident () str))) = str
316tname _ = "_unkonwn"
317
318getPtrType (HS.TyApp _ (HS.TyCon _ (HS.UnQual _ (HS.Ident _ "Ptr"))) x) = Just x
319getPtrType _ = Nothing
320
321-- pointers :: [HS.Decl ()] -> [String]
322pointers :: [HS.Type l] -> [HS.Type l]
323pointers decls = do
324 d <- decls
325 maybeToList $ getPtrType d
326
327unpointer t = case getPtrType t of
328 Nothing -> t
329 Just t' -> t'
330
331-- sig :: Show t => CExternalDeclaration t -> [HS.Decl ()]
332sig :: CExternalDeclaration NodeInfo -> [Decl ()]
333sig = sigf hsTransFieldExt
334
335-- • Couldn't match expected type ‘CDerivedDeclarator a -> (Maybe (CDeclarator a), Maybe (CInitializer a), Maybe (CExpression a))’
336-- with actual type ‘(CDerivedDeclarator NodeInfo -> Maybe (CDeclarator NodeInfo), Maybe a0, Maybe a1)’
337
338
339-- CDeclr (Maybe Ident)
340-- [CDerivedDeclarator a]
341-- (Maybe (CStringLiteral a))
342-- [CAttribute a]
343-- a
344-- sigf f d@(CDeclExt (CDecl rs ((Just (CDeclr i x j k l),b,c):zs) n)) = f rs $ map (\v -> (Just (CDeclr Nothing [v] Nothing [] n),Nothing,Nothing)) x
345sigf :: ([CDeclarationSpecifier b] -> [CDeclarator b] -> p) -> CExternalDeclaration b -> p
346sigf f (CDeclExt (CDecl rs as _)) = f rs $ concatMap fieldInfo as
347sigf f (CFDefExt (CFunDef rs cdeclr [] bdy _)) = f rs [cdeclr]
348{-
349sigf f d = f (getReturnValue d) $ do
350 arg <- getArgList d
351 let node (CDeclExt (CDecl rs as n)) = n
352 node (CFDefExt (CFunDef rs cdeclr [] bdy n)) = n
353 s = listToMaybe $ catMaybes $ sym d
354 return $ CDeclr s [arg] Nothing [] (node d)
355-}
356
357body0 (CFDefExt (CFunDef rs cdeclr [] bdy _)) = Just bdy
358body0 _ = Nothing
359
360body (CFDefExt (CFunDef rs cdeclr [] (CCompound [] bdy _) _)) = bdy
361body _ = []
362
363data SideEffect = PointerWrite | FunctionCall
364
365calls :: Data t => t -> [CExpression NodeInfo]
366calls = everything (++) (mkQ [] (\case { cc@C.CCall {} -> [cc] ; _ -> [] }))
367
368mutations1 e@(CAssign {}) = [e]
369mutations1 e@(CUnary CPreIncOp _ _) = [e]
370mutations1 e@(CUnary CPreDecOp _ _) = [e]
371mutations1 e@(CUnary CPostIncOp _ _) = [e]
372mutations1 e@(CUnary CPostDecOp _ _) = [e]
373mutations1 _ = []
374
375mutations :: Data t => t -> [CExpression NodeInfo]
376mutations = everything (++) (mkQ [] mutations1)
377
378
379-- gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b) -> (forall g. g -> c g) -> a -> c a
380--
381-- gfoldl app con
382--
383-- does is to turn such a value into
384--
385-- con C `app` x_1 `app` x_2 ... `app` x_n
386
387
388commented :: String -> String
389commented s = unlines $ map ("-- " ++) (lines s)
390
391data C2HaskellOptions = C2HaskellOptions
392 { selectFunction :: Maybe String
393 , prettyC :: Bool
394 , prettyTree :: Bool
395 , verbose :: Bool
396 , preprocess :: Bool
397 }
398
399defopts = C2HaskellOptions
400 { selectFunction = Nothing
401 , prettyC = False
402 , prettyTree = False
403 , verbose = False
404 , preprocess = False
405 }
406
407parseOptions [] opts = opts
408parseOptions ("-f":f:args) opts = parseOptions args opts
409 { selectFunction = Just f
410 }
411parseOptions ("-t":args) opts = parseOptions args opts
412 { prettyTree = True
413 }
414parseOptions ("-p":args) opts = parseOptions args opts
415 { prettyC = True
416 }
417parseOptions ("--cpp":args) opts = parseOptions args opts
418 { preprocess = True
419 }
420parseOptions ("-v":args) opts = parseOptions args opts
421 { verbose = True
422 }
423parseOptions as x = error (show as)
424
425getsig (k,si) = do
426 d0 <- take 1 $ symbolSource si
427 let d = case getArgList d0 of
428 oargs:xs -> let args = fst $ makeParameterNames oargs
429 in changeArgList (const $ args:xs) d0
430 _ -> d0
431 ts = filter notKnown $ map tname $ map unpointer $ concatMap types $ sigf hsTransSig d
432 s = sig d
433 [(ts,(k,s,d))]
434
435isAcceptableImport (HS.TyFun _ (TyCon _ (UnQual _ (HS.Ident _ x))) xs) | not (notKnown x) = isAcceptableImport xs
436isAcceptableImport (HS.TyFun _ (TyApp _ (TyCon _ (UnQual _ (HS.Ident _ "Ptr"))) x) xs) = isAcceptableImport xs
437isAcceptableImport (TyCon _ _) = True
438isAcceptableImport (TyApp _ _ _) = True
439isAcceptableImport _ = False
440
441makeFunctionUseIO :: HS.Type () -> HS.Type ()
442makeFunctionUseIO (HS.TyFun a x xs) = (HS.TyFun a x (makeFunctionUseIO xs))
443makeFunctionUseIO t@(TyApp a (TyCon b (UnQual c (HS.Ident d "IO"))) x) = t
444makeFunctionUseIO t = TyApp () (TyCon () (UnQual () (HS.Ident () "IO"))) t
445
446
447makeAcceptableImport (HS.TyFun a (TyCon b (UnQual c (HS.Ident d x))) xs) | not (notKnown x)
448 = (HS.TyFun a (TyCon b (UnQual c (HS.Ident d x))) (makeAcceptableImport xs))
449makeAcceptableImport (HS.TyFun a (TyApp b (TyCon c (UnQual d (HS.Ident e "Ptr"))) x) xs)
450 = (HS.TyFun a (TyApp b (TyCon c (UnQual d (HS.Ident e "Ptr"))) x) (makeAcceptableImport xs))
451makeAcceptableImport (HS.TyFun a (TyCon c (UnQual d (HS.Ident e x))) xs)
452 = (HS.TyFun a (TyApp c (TyCon c (UnQual d (HS.Ident e "Ptr"))) (TyCon e (UnQual e (HS.Ident e x)))) (makeAcceptableImport xs))
453makeAcceptableImport t = t
454
455-- c2haskell :: Foldable t => C2HaskellOptions -> p -> t String -> CTranslationUnit NodeInfo -> IO ()
456c2haskell :: C2HaskellOptions
457 -> p1 -> FilePath -> [String] -> IncludeStack -> CTranslationUnit NodeInfo -> IO ()
458c2haskell opts cs cmodname missings incs (CTranslUnit edecls _) = do
459 let db = foldr update initTranspile edecls
460 es = Map.filter (\d -> symbolLocal d && not (symbolStatic d)) (syms db)
461 case selectFunction opts of
462 Nothing -> do
463 createDirectoryIfMissing False "MonkeyPatch"
464 let fname = ("MonkeyPatch/" ++ modname ++ ".hs")
465 basename f = case break (=='.') $ takeWhile (/='/') $ reverse f of
466 (ext,_:rname) -> reverse rname
467 (rname,_) -> reverse rname
468 modname = capitalize $ basename cmodname
469 stubsname = "MonkeyPatch/" ++ modname ++ "_patch.c"
470 putStrLn $ "writing " ++ fname
471 withFile fname WriteMode $ \haskmod -> do
472 hPutStrLn haskmod $ "module MonkeyPatch." ++ modname ++" where"
473 hPutStrLn haskmod $ "import Foreign.Ptr"
474 hPutStrLn haskmod $ "import Data.Word"
475 hPutStrLn haskmod $ "import Data.Int"
476 putStrLn $ "-- " ++ show (fmap (fmap (fmap (const ()))) <$> Map.lookup "ip_is_lan" (syms db))
477 let sigs = concatMap getsig (Map.toList es)
478 sigs2 = concatMap (\s -> do
479 x <- maybeToList $ Map.lookup s (syms db)
480 (y,_) <- getsig (s,x)
481 y)
482 missings
483 ts = concatMap fst sigs
484 putStrLn $ "-- IP `elem` db = " ++ show (length . symbolSource <$> Map.lookup "IP" (syms db))
485 putStrLn $ "-- IP `elem` sigs2 = " ++ show (elem "IP" sigs2)
486 putStrLn $ "-- ip_is_lan `elem` db = " ++ show (length . symbolSource <$> Map.lookup "ip_is_lan" (syms db))
487 putStrLn $ "-- ip_is_lan `elem` sigs2 = " ++ show (elem "ip_is_lan" sigs2)
488 forM_ (uniq $ ts ++ sigs2) $ \t -> do
489 hPutStrLn haskmod $ "data " ++ t
490 forM_ sigs $ \(_,(k,hs,d)) -> do
491 forM_ hs $ \hdecl -> do
492 {-
493 hPutStr haskmod (commented k)
494 hPutStr haskmod (commented $ show $ pretty d)
495 hPutStr haskmod (commented $ show $ getReturnValue d)
496 hPutStr haskmod (commented $ show hdecl)
497 -- hPutStr haskmod $ commented $ show $ length $ symbolSource si
498 forM_ (take 1 $ symbolSource si) $ \d -> do
499 let ts = filter notKnown $ map tname $ pointers $ concatMap types $ sigf hsTransSig d
500 -- putStr $ commented (ppShow (fmap (const ()) d))
501 -- putStr $ commented (show $ pretty d)
502 let typ = (TyCon () (Special () (UnitCon ())))
503 -- when (null $ sig d) $ putStr $ commented (ppShow (fmap (const ()) d))
504 forM_ (sig d) $ \hs -> case hs of
505 htyp -> -- putStr $ commented $ "Unsupported haskell type: " ++ HS.prettyPrint htyp
506 -}
507 let htyp = makeFunctionUseIO $ extractType hdecl
508 hPutStrLn haskmod $ (if isAcceptableImport htyp then id else commented)
509 $ HS.prettyPrint $ (HS.ForImp () (HS.CCall ()) Nothing (Just k)
510 (HS.Ident () k)
511 htyp)
512 forM_ missings $ \sym -> goMissing haskmod db sym
513 {-
514 forM_ (Map.lookup sym $ syms db) $ \si -> do
515 forM_ (take 1 $ symbolSource si) $ \d -> do
516 let ts = filter notKnown $ map tname $ pointers $ concatMap types $ sigf hsTransSig d
517 -- putStr $ commented (ppShow (fmap (const ()) d))
518 -- putStr $ commented (show $ pretty d)
519 let typ = (TyCon () (Special () (UnitCon ())))
520 -- when (null $ sig d) $ putStr $ commented (ppShow (fmap (const ()) d))
521 forM_ (sig d) $ \htyp -> do
522 putStrLn $ HS.prettyPrint htyp
523
524 -- mapM_ (putStrLn . HS.prettyPrint) (sig d)
525 {-
526 forM_ (body d) $ \stmt -> do
527 putStr $ commented (take 130 $ show (fmap (const ()) stmt))
528 putStr $ commented (ppShow (fmap (const ()) stmt))
529 putStrLn $ commented . show . pretty $ stmt
530 putStr $ commented "calls"
531 mapM_ (putStr . commented . show . pretty) (calls (body d))
532 putStrLn "--"
533 putStr $ commented "mutations"
534 mapM_ (putStr . commented . show . pretty) (mutations (body d))
535 -}
536 -}
537 putStrLn $ "writing " ++ stubsname
538 withFile stubsname WriteMode $ \stubsfile -> do
539 {-
540 forM_ missings $ \sym ->
541 forM_ (Map.lookup sym$ syms db) $ \si -> do
542 forM_ (take 1 $ symbolSource si) $ \d -> do
543 hPutStrLn stubsfile $ show $ pretty $ makeFunctionPointer d
544 hPutStrLn stubsfile $ show $ pretty $ makeSetter d
545 hPutStrLn stubsfile $ show $ pretty $ makeStub d
546 -}
547 -- mkNodeInfo :: Position -> Name -> NodeInfo
548 let decls = map (setPos $ initPos stubsname) $ do
549 sym <- missings
550 si <- maybeToList $ Map.lookup sym (syms db)
551 d <- take 1 $ symbolSource si
552 [ makeFunctionPointer d, makeSetter d, makeStub d]
553 ns = listify (mkQ False (\ni -> let _ = ni :: C.NodeInfo in True)) decls :: [C.NodeInfo]
554 headerOfNode n = do
555 f <- fileOfNode n
556 case includeTopLevel incs f of
557 "" -> Nothing
558 h -> Just h
559 is = uniq $ mapMaybe headerOfNode ns
560 hPutStrLn stubsfile "#include <stdio.h>"
561 hPutStrLn stubsfile $ concatMap (\i -> "#include " ++ i ++ "\n") is
562 hPutStrLn stubsfile $ show $ pretty $ CTranslUnit decls undefNode
563
564 Just cfun -> do
565 forM_ (Map.lookup cfun $ syms db) $ \si -> do
566 forM_ (take 1 $ symbolSource si) $ \d -> do
567 putStrLn $ concatMap HS.prettyPrint $ sig d
568 putStrLn $ show $ pretty d
569 putStrLn $ show $ pretty $ makeFunctionPointer d
570 putStrLn $ show $ pretty $ makeSetter d
571 putStrLn $ show $ pretty $ makeStub d
572 putStrLn $ ppShow $ everywhere (mkT eraseNodeInfo) d -- <$> makeFunctionPointer d
573
574-- TODO: make idempotent
575makeStatic :: [CDeclarationSpecifier NodeInfo] -> [CDeclarationSpecifier NodeInfo]
576makeStatic xs = CStorageSpec (CStatic undefNode) : xs
577-- makeStatic xs = CStorageSpec (CStatic ()) : xs
578
579makePointer1 (Just (CDeclr a bs c d e))
580 = (Just (CDeclr a (p:bs) c d e))
581 where
582 p = CPtrDeclr [] undefNode
583 -- p = CPtrDeclr [] ()
584
585makePointer :: [(Maybe (CDeclarator NodeInfo), b, c)]
586 -> [(Maybe (CDeclarator NodeInfo), b, c)]
587makePointer ((a,b,c):zs) = (makePointer1 a,b,c):zs
588
589setNull1 :: Maybe (CInitializer NodeInfo)
590setNull1 = Just (CInitExpr (CVar (C.Ident "NULL" 0 undefNode) undefNode) undefNode)
591
592setNull ((a,_,b):zs) = (a,setNull1,b):zs
593
594makeFunctionPointer :: CExternalDeclaration NodeInfo
595 -> CExternalDeclaration NodeInfo
596makeFunctionPointer d@(CDeclExt (CDecl xs ys pos)) = changeName ("f_"++) $ CDeclExt (CDecl (makeStatic xs) (setNull $ makePointer ys) pos)
597makeFunctionPointer d = d
598
599changeName2 f (Just (CDeclr (Just (C.Ident nm n p)) bs c d e))
600 = (Just (CDeclr (Just (C.Ident (f nm) n p)) bs c d e))
601changeName2 f d = d
602
603changeName1 f ((a,b,c):zs) = (changeName2 f a,b,c):zs
604
605changeName f d@(CDeclExt (CDecl xs ys pos)) = CDeclExt (CDecl xs (changeName1 f ys) pos)
606changeName f d = d
607
608makeAcceptableDecl (HS.TypeDecl a (DHead b (HS.Ident c signame)) ftyp)
609 = (HS.TypeDecl a (DHead b (HS.Ident c signame)) (makeFunctionUseIO $ makeAcceptableImport ftyp))
610makeAcceptableDecl (HS.TypeSig a b ftyp) = HS.TypeSig a b (makeFunctionUseIO $ makeAcceptableImport ftyp)
611
612makeSetter d = -- @(CDeclExt (CDecl xs ys pos)) =
613 let name = concatMap identToString $ take 1 $ catMaybes $ sym d
614 in setBody (setterBody ("f_"++name)) $ changeReturnValue (const voidReturnType) $ changeArgList (const voidp) $ changeName ("setf_"++) d
615
616changeArgList1 f (CDeclr a xs b c d) = CDeclr a (f xs) b c d
617
618changeArgList2 f ((a,b,c):zs) = (changeArgList3 f a,b,c):zs
619
620changeArgList3 f (Just (CDeclr a x b c d)) = Just (CDeclr a (f x) b c d)
621
622changeArgList :: ([CDerivedDeclarator a] -> [CDerivedDeclarator a])
623 -> CExternalDeclaration a -> CExternalDeclaration a
624changeArgList f (CFDefExt (CFunDef xs ys zs c d)) = CFDefExt (CFunDef xs (changeArgList1 f ys) zs c d)
625changeArgList f (CDeclExt (CDecl xs ys pos)) = (CDeclExt (CDecl xs (changeArgList2 f ys) pos))
626
627setPosOfNode :: Position -> NodeInfo -> NodeInfo
628setPosOfNode pos n = maybe (mkNodeInfoOnlyPos pos) (mkNodeInfo pos) $ nameOfNode n
629
630setPos pos (CFDefExt (CFunDef xs ys zs c n)) = (CFDefExt (CFunDef xs ys zs c $ setPosOfNode pos n))
631setPos pos (CDeclExt (CDecl xs ys n)) = (CDeclExt (CDecl xs ys $ setPosOfNode pos n))
632
633getArgList1 (CDeclr a xs b c d) = xs
634
635getArgList2 ((a,b,c):zs) = getArgList3 a
636
637getArgList3 (Just (CDeclr a x b c d)) = x
638
639getArgList :: CExternalDeclaration a -> [CDerivedDeclarator a]
640getArgList (CFDefExt (CFunDef xs ys zs c d)) = getArgList1 ys
641getArgList (CDeclExt (CDecl xs ys pos)) = getArgList2 ys
642
643changeReturnValue f (CFDefExt (CFunDef xs ys zs c d)) = (CFDefExt (CFunDef (f xs) ys zs c d))
644changeReturnValue f (CDeclExt (CDecl xs ys pos)) = (CDeclExt (CDecl (f xs) ys pos))
645
646getReturnValue (CFDefExt (CFunDef xs ys zs c d)) = xs
647getReturnValue (CDeclExt (CDecl xs ys pos)) = xs
648
649voidReturnType = [ CTypeSpec (CVoidType undefNode) ]
650
651setBody bdy (CFDefExt (CFunDef xs ys zs c d)) = (CFDefExt (CFunDef xs ys zs bdy d))
652setBody bdy (CDeclExt (CDecl xs ys pos)) = (CFDefExt (CFunDef xs v [] bdy pos))
653 where v = case ys of
654 (Just y,_,_):_ -> y
655 _ -> CDeclr Nothing [] Nothing [] pos
656
657makeStub d = -- @(CDeclExt (CDecl xs ys pos)) =
658 let rval = case getReturnValue d of
659 [ CTypeSpec (CVoidType _) ] -> False -- void function.
660 _ -> True
661 name = concatMap identToString $ take 1 $ catMaybes $ sym d
662 msg = "undefined: " ++ concatMap (HS.prettyPrint . makeAcceptableDecl) (take 1 $ sig d) ++ "\n"
663 in case getArgList d of
664 oargs:xs ->
665 let (args,vs) = makeParameterNames oargs
666 in setBody (stubBody ("f_"++name) vs rval msg) $ changeArgList (const $ args:xs) d
667 [] -> setBody (stubBody ("f_"++name) [] rval msg) d
668
669
670parameterIdent :: CDeclaration a -> Maybe Ident
671parameterIdent (CDecl _ xs n) = listToMaybe $ do
672 (Just (CDeclr (Just x) _ _ _ _),_,_) <- xs
673 return x
674
675
676-- makeParameterNames :: CDerivedDeclarator NodeInfo -> (CDerivedDeclarator NodeInfo,[CExpression NodeInfo])
677makeParameterNames :: CDerivedDeclarator n -> (CDerivedDeclarator n,[CExpression n])
678makeParameterNames (CFunDeclr (Right (ps, flg)) z2 z3) = case ps of
679 [CDecl [CTypeSpec (CVoidType _)] [] _] -> ( CFunDeclr (Right (ps, flg)) z2 z3 , []) -- void argument list.
680 _ -> ( CFunDeclr (Right (qs, flg)) z2 z3 , map expr qs )
681 where
682 -- TODO: ensure uniqueness of generated parameter names
683 qs = zipWith mkp [0..] ps
684 mkp num (CDecl rtyp ((Just (CDeclr Nothing typ x ys z),a,b):xs) n)
685 = (CDecl rtyp ((Just (CDeclr (Just $ mkidn num undefNode) typ x ys z),a,b):xs) n)
686 mkp num (CDecl rtyp [] n)
687 = (CDecl rtyp ((Just (CDeclr (Just $ mkidn num undefNode) [] Nothing [] n),Nothing,Nothing):[]) n)
688 mkp num p = p
689
690expr :: CDeclaration a -> CExpression a
691expr (CDecl rtyp ((Just (CDeclr (Just i) typ x ys z),a,b):xs) n) = CVar i n
692
693mkidn :: Show a => a -> NodeInfo -> Ident
694mkidn num n = C.Ident ("a"++show num) 0 n
695
696voidp :: [CDerivedDeclarator NodeInfo]
697voidp = [ CFunDeclr
698 (Right ( [ CDecl
699 [ CTypeSpec (CVoidType n) ]
700 [ ( Just (CDeclr
701 (Just (C.Ident "p" 0 n))
702 [ CPtrDeclr [] n ]
703 Nothing
704 []
705 n)
706 , Nothing
707 , Nothing
708 )
709 ]
710 n
711 ]
712 , False))
713 []
714 n]
715 where n = undefNode
716
717
718stubBody name vs rval msg =
719 CCompound []
720 [ CBlockStmt
721 (CIf
722 (CVar (C.Ident name 0 undefNode) undefNode)
723 (if rval
724 then (CReturn
725 (Just
726 (C.CCall
727 (CVar (C.Ident name 0 undefNode) undefNode)
728 vs
729 undefNode))
730 undefNode)
731 else (CExpr (Just (C.CCall (CVar (C.Ident name 0 undefNode) undefNode)
732 vs
733 undefNode))
734 undefNode))
735 (Just
736 (if rval
737 then CCompound []
738 [ CBlockStmt printmsg
739 , CBlockStmt (CReturn (Just $ CConst (CIntConst (cInteger 0) undefNode)) undefNode)]
740 undefNode
741 else printmsg))
742 undefNode)
743 ]
744 undefNode
745 where
746 printmsg = (CExpr (Just (C.CCall (CVar (C.Ident "fputs" 0 undefNode) undefNode)
747 [ CConst (CStrConst (cString msg) undefNode)
748 , CVar (C.Ident "stderr" 0 undefNode) undefNode
749 ]
750 undefNode)) undefNode)
751
752setterBody :: String -> CStatement NodeInfo
753setterBody name =
754 CCompound []
755 [ CBlockStmt
756 (CExpr
757 (Just
758 (CAssign
759 CAssignOp
760 (CVar (C.Ident name 0 undefNode) undefNode)
761 (CVar (C.Ident "p" 0 undefNode) undefNode)
762 undefNode))
763 undefNode)
764 ]
765 undefNode
766
767
768goMissing :: Show b =>
769 Handle -> Transpile [CExternalDeclaration b] -> String -> IO ()
770goMissing haskmod db cfun = do
771 forM_ (Map.lookup cfun $ syms db) $ \si -> do
772 forM_ (take 1 $ symbolSource si) $ \d0 -> do
773 -- putStr $ commented (ppShow (fmap (const ()) d))
774 -- putStr $ commented (show $ pretty d)
775 -- when (verbose opts) $ print (sig d)
776 let d = case getArgList d0 of
777 oargs:xs -> let args = fst $ makeParameterNames oargs
778 in changeArgList (const $ args:xs) d0
779 _ -> d0
780 let ts = filter notKnown $ map tname $ pointers $ concatMap types $ sigf hsTransSig d
781 -- forM_ ts $ \t -> putStrLn $ "data " ++ t
782 forM_ (sigf hsTransSig d) $ \hs -> do
783 hPutStrLn haskmod . HS.prettyPrint $ makeAcceptableDecl hs
784 case hs of
785 HS.TypeDecl _ (DHead _ (HS.Ident _ signame)) ftyp -> do
786 let wrapname = "wrap" ++ drop 3 signame
787 settername = "setf" ++ drop 3 signame
788 funptr = (TyApp () (TyCon () (UnQual () (HS.Ident () "FunPtr")))
789 (TyCon () (UnQual () (HS.Ident () signame))))
790 -- hPutStrLn haskmod $ ppShow $ HS.parseDecl "foreign import ccall \"wrapper\" fname :: Spec -> IO (FunPtr Spec)"
791 -- mapM_ (hPutStrLn haskmod . HS.prettyPrint) (importWrapper $ sigf hsTransSig d)
792 hPutStrLn haskmod $ HS.prettyPrint $
793 (HS.ForImp () (HS.CCall ()) Nothing (Just "wrapper")
794 (HS.Ident () wrapname)
795 (TyFun ()
796 (TyCon () (UnQual () (HS.Ident () signame)))
797 (TyApp ()
798 (TyCon () (UnQual () (HS.Ident () "IO")))
799 (TyParen () funptr))))
800 hPutStrLn haskmod $ HS.prettyPrint $
801 (HS.ForImp () (HS.CCall ()) Nothing (Just settername)
802 (HS.Ident () settername)
803 (TyFun ()
804 funptr
805 (TyApp ()
806 (TyCon () (UnQual () (HS.Ident () "IO")))
807 (TyCon () (Special () (UnitCon ()))))))
808
809
810 htyp -> hPutStr haskmod $ commented $ "Unsupported haskell type: " ++ HS.prettyPrint htyp
811
812
813readComments :: (Num lin, Num col) =>
814 FilePath -> IO [(lin, col, [Char])]
815readComments fname = parseComments 1 1 <$> readFile fname
816
817findCloser :: (Num a4, Num a3, Num a2, Num a1, Eq a1) =>
818 a1 -> (a4, a2, a3) -> [Char] -> (a4, a2, a3)
819findCloser !1 (l,c,b) ('*':'/':_) = (l,c+2,b+2)
820findCloser !d (l,c,b) ('*':'/':xs) = findCloser (d - 1) (l,c+2,b+2) xs
821findCloser !d (l,c,b) ('/':'*':xs) = findCloser (d + 1) (l,c+2,b+2) xs
822findCloser !d (l,c,b) ('\n':xs) = findCloser d (l+1,1,b+1) xs
823findCloser !d (l,c,b) (_:xs) = findCloser d (l,c+1,b+1) xs
824findCloser !d (l,c,b) [] = (l,c,b)
825
826mkComment :: a -> b -> c -> (a, b, c)
827mkComment lin no str = (lin,no,str)
828
829parseComments :: (Num col, Num lin) => lin -> col -> [Char] -> [(lin, col, [Char])]
830parseComments !lin !col = \case
831 ('/':'*':cs) -> let (lcnt,col',bcnt) = findCloser 1 (0,col,0) cs
832 (xs,cs') = splitAt bcnt cs
833 in mkComment lin col xs : parseComments (lin + lcnt) col' cs'
834 ('/':'/':cs) -> let (comment,ds) = break (=='\n') cs
835 in mkComment lin col comment : parseComments (lin + 1) 1 cs
836 ('\n' : cs) -> parseComments (lin+1) 1 cs
837 ( x : cs) -> parseComments lin (col+1) cs
838 [] -> []
839
840sanitizeArgs :: [String] -> [String]
841sanitizeArgs (('-':'M':_):args) = sanitizeArgs args
842sanitizeArgs (('-':'O':_):args) = sanitizeArgs args
843sanitizeArgs (('-':'c':_):args) = sanitizeArgs args
844sanitizeArgs ("-o":args) = sanitizeArgs $ drop 1 args
845sanitizeArgs (arg:args) = arg : sanitizeArgs args
846sanitizeArgs [] = []
847
848isModule :: FilePath -> Bool
849isModule fname = (".c" `isSuffixOf` fname) || (".o" `isSuffixOf` fname)
850
851usage :: [String] -> Maybe (C2HaskellOptions, [String], [FilePath])
852usage args =
853 case break (=="--") args of
854 (targs,_:cargs0) -> do
855 let (rfs,ropts) = span isModule $ reverse cargs0
856 opts = reverse ropts
857 cargs = (sanitizeArgs opts)
858 hopts = parseOptions targs defopts
859 return (hopts,cargs,rfs)
860 _ -> Nothing
861
862(<&>) :: Functor f => f a -> (a -> b) -> f b
863m <&> f = fmap f m
864
865uniq :: (Ord k, Foldable t) => t k -> [k]
866uniq xs = Map.keys $ foldr (\x m -> Map.insert x () m) Map.empty xs
867
868unquote :: String -> String
869unquote xs = zipWith const (drop 1 xs) (drop 2 xs)
870
871missingSymbols :: String -> [String]
872missingSymbols s = uniq $ do
873 e <- lines s
874 let (_,us) = break (=="undefined") $ words e
875 if null us then []
876 else do
877 let q = concat $ take 1 $ reverse us
878 c <- take 1 q
879 guard $ c=='`' || c=='\''
880 return $ unquote q
881
882
883linker :: [String] -> String -> IO [String]
884linker cargs fname = do
885 print (cargs,fname)
886 (hin,hout,Just herr,hproc) <- createProcess (proc "gcc" $ cargs ++ [fname])
887 { std_err = CreatePipe }
888 linkerrs <- hGetContents herr
889 ecode <- waitForProcess hproc
890 case ecode of
891 ExitSuccess -> hPutStrLn stderr $ "Oops: "++fname++" has main() symbol."
892 _ -> return ()
893 return $ missingSymbols linkerrs
894
895eraseNodeInfo :: NodeInfo -> NodeInfo
896eraseNodeInfo _ = OnlyPos p (p,0) -- undefNode value doesn't ppShow well.
897 where
898 p = position 0 "" 0 0 Nothing
899
900
901newtype IncludeStack = IncludeStack
902 { includes :: Map FilePath [[FilePath]]
903 }
904 deriving Show
905
906emptyIncludes = IncludeStack Map.empty
907
908openInclude fname stack (IncludeStack m) = IncludeStack $ Map.alter go fname m
909 where
910 go Nothing = Just [stack]
911 go (Just s) = Just $ stack : s
912
913findQuoted xs = takeWhile (/='"') $ drop 1 $ dropWhile (/='"') xs
914
915includeStack bs = foldr go (const emptyIncludes) incs []
916 where
917 incs = filter (\b -> fmap fst (B.uncons b) == Just '#') $ B.lines bs
918
919 fp inc = findQuoted $ B.unpack inc
920 -- fno inc = read $ concat $ take 1 $ words $ drop 2 $ B.unpack inc
921
922 go inc xs stack
923 | "1" `elem` B.words inc = let f = fp inc in openInclude f stack (xs (f : stack))
924 | "2" `elem` B.words inc = xs (drop 1 stack)
925 | otherwise = xs stack
926
927main :: IO ()
928main = do
929 self <- getProgName
930 args <- getArgs
931 let usageString = self ++ " [--cpp | -p | -t ] [-v] [-f <sym>] -- [gcc options] [modules] <cfile>"
932 let m = usage args
933 fromMaybe (putStrLn usageString) $ m <&> \(hopts,cargs,fname:fs) -> do
934 prer <- runPreprocessor (newGCC "gcc") (rawCppArgs cargs fname)
935 let r = do
936 pre <- left Left $ prer
937 c <- left Right $ parseC pre (initPos fname)
938 return (includeStack pre,c)
939 -- putStrLn $ "fname = " ++ fname
940 -- putStrLn $ "includes = " ++ ppShow (fmap fst r)
941 cs <- readComments fname
942 case () of
943 _ | preprocess hopts -- --cpp
944 -> do
945 case prer of
946 Left e -> print e
947 Right bs -> putStrLn $ ppShow $ includeStack $ bs
948 _ | prettyC hopts -- -p
949 -> do
950 either print (\(incs,decls) -> print $ prettyUsingInclude incs decls) r
951 _ | prettyTree hopts -- -t
952 -> do
953 putStrLn $ ppShow $ everywhere (mkT eraseNodeInfo) . snd <$> r
954 _ -> do
955 syms <- linker (cargs ++ reverse fs) fname
956 either print (uncurry $ c2haskell hopts cs fname syms) r
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-19 14:29:01 +0000