diff options
author | Joe Crayne <joe@jerkface.net> | 2019-03-17 23:55:52 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2019-03-17 23:55:52 -0400 |
commit | 5ea1ee91c2ad1db38ada2590f30dc0ea4ed6ef29 (patch) | |
tree | 2cfe12502ce621f4490c662c4297874e6133befe /monkeypatch.hs | |
parent | 16d4397e2cbe550c473117dae7ec1ef577fb7937 (diff) |
Use refactored comment parser.
Diffstat (limited to 'monkeypatch.hs')
-rw-r--r-- | monkeypatch.hs | 40 |
1 files changed, 12 insertions, 28 deletions
diff --git a/monkeypatch.hs b/monkeypatch.hs index 4942859..9060c3e 100644 --- a/monkeypatch.hs +++ b/monkeypatch.hs | |||
@@ -46,6 +46,8 @@ import Text.PrettyPrint (Doc, doubleQuotes, empty, text, vcat, ($$), | |||
46 | (<+>)) | 46 | (<+>)) |
47 | import Text.Show.Pretty | 47 | import Text.Show.Pretty |
48 | 48 | ||
49 | import Comments | ||
50 | |||
49 | -- trace _ = id | 51 | -- trace _ = id |
50 | 52 | ||
51 | -- | Pretty print the given tranlation unit, but replace declarations from header files with @#include@ directives. | 53 | -- | Pretty print the given tranlation unit, but replace declarations from header files with @#include@ directives. |
@@ -144,6 +146,10 @@ data Computation st = Computation | |||
144 | } | 146 | } |
145 | deriving (Eq,Ord,Functor) | 147 | deriving (Eq,Ord,Functor) |
146 | 148 | ||
149 | {- | ||
150 | CUnary CAdrOp (CVar _) LT) LT | ||
151 | -} | ||
152 | |||
147 | grokExpression (CVar cv _) = Just Computation | 153 | grokExpression (CVar cv _) = Just Computation |
148 | { compFree = Map.singleton (identToString cv) () | 154 | { compFree = Map.singleton (identToString cv) () |
149 | , compIntro = Map.empty | 155 | , compIntro = Map.empty |
@@ -272,11 +278,12 @@ transpile o fname incs (CTranslUnit edecls _) = do | |||
272 | -- putStrLn $ show (fmap (const LT) c) | 278 | -- putStrLn $ show (fmap (const LT) c) |
273 | putStrLn . HS.prettyPrint $ changeType makeFunctionUseIO hh | 279 | putStrLn . HS.prettyPrint $ changeType makeFunctionUseIO hh |
274 | putStrLn $ unwords (hname:as) ++ " =" | 280 | putStrLn $ unwords (hname:as) ++ " =" |
281 | cleanTree d = fmap (const LT) $ everywhere (mkT eraseNodeInfo) $ d | ||
275 | forM_ mprintHeader $ \printHeader -> do | 282 | forM_ mprintHeader $ \printHeader -> do |
276 | let bdy = concat $ take 1 $ dropWhile null $ map body $ symbolSource sym | 283 | let bdy = concat $ take 1 $ dropWhile null $ map body $ symbolSource sym |
277 | if oPrettyTree o | 284 | if oPrettyTree o |
278 | then do printHeader | 285 | then do printHeader |
279 | forM_ bdy $ \d -> putStrLn $ ppShow $ fmap (const LT) $ everywhere (mkT eraseNodeInfo) $ d | 286 | forM_ bdy $ \d -> putStrLn $ ppShow $ cleanTree d |
280 | else do | 287 | else do |
281 | let mhask = do | 288 | let mhask = do |
282 | xs <- sequence $ map grokStatement bdy | 289 | xs <- sequence $ map grokStatement bdy |
@@ -287,8 +294,10 @@ transpile o fname incs (CTranslUnit edecls _) = do | |||
287 | Nothing -> forM_ (oSelectFunction o) $ \_ -> do | 294 | Nothing -> forM_ (oSelectFunction o) $ \_ -> do |
288 | printHeader | 295 | printHeader |
289 | forM_ bdy $ \d -> do | 296 | forM_ bdy $ \d -> do |
290 | putStrLn . show . pretty $ d | 297 | putStrLn $ " C: " ++ show (pretty d) |
291 | mapM_ (putStrLn . HS.prettyPrint . comp) (grokStatement d) | 298 | case grokStatement d of |
299 | Just hd -> putStrLn $ "HS: " ++ HS.prettyPrint (comp hd) | ||
300 | Nothing -> putStrLn $ "??: " ++ ppShow (cleanTree d) | ||
292 | return () | 301 | return () |
293 | 302 | ||
294 | isHeaderDecl :: CNode a => a -> Bool | 303 | isHeaderDecl :: CNode a => a -> Bool |
@@ -1105,31 +1114,6 @@ goMissing haskmod db cfun = do | |||
1105 | readComments :: (Num lin, Num col) => FilePath -> IO [(lin, col, [Char])] | 1114 | readComments :: (Num lin, Num col) => FilePath -> IO [(lin, col, [Char])] |
1106 | readComments fname = parseComments 1 1 <$> readFile fname | 1115 | readComments fname = parseComments 1 1 <$> readFile fname |
1107 | 1116 | ||
1108 | findCloser :: (Num a4, Num a3, Num a2, Num a1, Eq a1) => | ||
1109 | a1 -> (a4, a2, a3) -> [Char] -> (a4, a2, a3) | ||
1110 | findCloser !1 (l,c,b) ('*':'/':_) = (l,c+2,b+2) | ||
1111 | findCloser !d (l,c,b) ('*':'/':xs) = findCloser (d - 1) (l,c+2,b+2) xs | ||
1112 | findCloser !d (l,c,b) ('/':'*':xs) = findCloser (d + 1) (l,c+2,b+2) xs | ||
1113 | findCloser !d (l,c,b) ('\n':xs) = findCloser d (l+1,1,b+1) xs | ||
1114 | findCloser !d (l,c,b) (_:xs) = findCloser d (l,c+1,b+1) xs | ||
1115 | findCloser !d (l,c,b) [] = (l,c,b) | ||
1116 | |||
1117 | mkComment :: a -> b -> c -> (a, b, c) | ||
1118 | mkComment lin no str = (lin,no,str) | ||
1119 | |||
1120 | parseComments :: (Num col, Num lin) => lin -> col -> [Char] -> [(lin, col, [Char])] | ||
1121 | parseComments !lin !col = \case | ||
1122 | ('/':'*':cs) -> let (lcnt,col',bcnt) = findCloser 1 (0,col,0) cs | ||
1123 | (xs,cs') = case drop (bcnt-2) cs of | ||
1124 | '*':'/':_ -> second (drop 2) $ splitAt (bcnt-2) cs | ||
1125 | _ -> splitAt bcnt cs | ||
1126 | in mkComment lin col xs : parseComments (lin + lcnt) col' cs' | ||
1127 | ('/':'/':cs) -> let (comment,ds) = break (=='\n') cs | ||
1128 | in mkComment lin col comment : parseComments (lin + 1) 1 cs | ||
1129 | ('\n' : cs) -> parseComments (lin+1) 1 cs | ||
1130 | ( x : cs) -> parseComments lin (col+1) cs | ||
1131 | [] -> [] | ||
1132 | |||
1133 | sanitizeArgs :: [String] -> [String] | 1117 | sanitizeArgs :: [String] -> [String] |
1134 | sanitizeArgs (('-':'M':_):args) = sanitizeArgs args | 1118 | sanitizeArgs (('-':'M':_):args) = sanitizeArgs args |
1135 | sanitizeArgs (('-':'O':_):args) = sanitizeArgs args | 1119 | sanitizeArgs (('-':'O':_):args) = sanitizeArgs args |