From ee6ab44b37c184aef0b8260aad3b345fb2c41db7 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Thu, 21 Mar 2019 20:27:33 -0400 Subject: Represent comments as functions. --- monkeypatch.hs | 105 ++++++++++++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 96 insertions(+), 9 deletions(-) diff --git a/monkeypatch.hs b/monkeypatch.hs index ea97252..8646b5b 100644 --- a/monkeypatch.hs +++ b/monkeypatch.hs @@ -28,6 +28,7 @@ import Data.Ord import qualified Data.Set as Set ;import Data.Set (Set) import Language.C.Data.Ident as C +import Language.C.Data.Node as C import Language.C as C hiding (prettyUsingInclude) import qualified Language.C as C import Language.C.System.GCC @@ -505,6 +506,36 @@ getSymbolExtent sym bdy = stop = maximumBy (comparing posRow) allposss in SymbolExtent start stop +lastRowOf x = case getLastTokenPos $ nodeInfo x of + (p,len) | isSourcePos p -> posRow p + len + _ -> maxBound + +firstRowOf x = case posOfNode $ nodeInfo x of + p | isSourcePos p -> posRow p + _ -> minBound + +columnOf x = case posOfNode $ nodeInfo x of + p | isSourcePos p -> posColumn p + _ -> minBound + +comesBefore x c = lastRowOf x < commentRow c + +comesAfter x c = firstRowOf x > commentRow c + +insertComment :: Data t => StyledComment -> t -> t +insertComment c stmts = everywhere (mkT go) stmts + where + go :: [CCompoundBlockItem NodeInfo] -> [CCompoundBlockItem NodeInfo] + go xs = case span (\a -> comesBefore a c) xs of + (a:as,b:bs) | b `comesAfter` c -> a:as ++ mkst c ++ b:bs + ([],b:bs) | commentRow c + 1 == firstRowOf b -> mkst c ++ b : bs + (as,[]) | (y:ys) <- reverse as, lastRowOf y + 1 == commentRow c -> as ++ mkst c + _ -> xs + + mkst c = let x = rewriteComment c in [CBlockStmt (CExpr (Just x) $ nodeInfo x)] + +mixComments :: [StyledComment] -> [CCompoundBlockItem NodeInfo] -> [CCompoundBlockItem NodeInfo] +mixComments cs stmts = foldr insertComment stmts cs transpile :: C2HaskellOptions -> FilePath -> IncludeStack -> CTranslationUnit NodeInfo -> IO () transpile o fname incs (CTranslUnit edecls _) = do @@ -533,7 +564,14 @@ transpile o fname incs (CTranslUnit edecls _) = do putStrLn . HS.prettyPrint $ changeType makeFunctionUseIO hh putStrLn $ unwords (hname:as) ++ " =" forM_ mprintHeader $ \printHeader -> do - let bdy = concat $ take 1 $ dropWhile null $ map body $ symbolSource sym + let bdy0 = concat $ take 1 $ dropWhile null $ map body $ symbolSource sym + + let extent = getSymbolExtent sym bdy0 + cs0 <- readComments (posFile $ startExtent extent) -- TODO: Avoid parsing the same file multiple times. + let (_,cs1) = seekComment (startExtent extent) cs0 + (cs,_ ) = seekComment (stopExtent extent) cs1 + bdy = mixComments (map reflowComment cs) bdy0 + if oPrettyTree o then do printHeader forM_ bdy $ \d -> putStrLn $ ppShow $ cleanTree d @@ -555,15 +593,20 @@ transpile o fname incs (CTranslUnit edecls _) = do Nothing -> putStrLn $ "??: " ++ ppShow (cleanTree d) putStrLn "" - let extent = getSymbolExtent sym bdy - cs <- readComments (posFile $ startExtent extent) - let (pcs,cs') = seekComment (startExtent extent) cs - (cs'',ds) = seekComment (stopExtent extent) cs' - -- lineOfComment - forM_ cs' $ \(_,col,cmt) -> do - putStrLn "" - putStrLn $ replicate col ' ' ++ cmt print extent + {- + -- Display comments as c functions. + forM_ cs $ \c@(_,col,cmt) -> do + putStrLn "" + let cc = reflowComment c + putStrLn $ replicate col ' ' ++ show (commentRow cc,commentCol cc) ++ show (pretty $ rewriteComment cc) + -- putStrLn $ replicate col ' ' ++ cmt + + putStrLn "\n{" + forM_ bdy $ \x -> + putStrLn $ {- show (firstRowOf x,lastRowOf x) ++ " " ++ -} (show . pretty $ x) + putStrLn "}" + -} return () isHeaderDecl :: CNode a => a -> Bool @@ -855,6 +898,7 @@ data C2HaskellOptions = C2HaskellOptions , oVerbose :: Bool , oPreprocess :: Bool , oTranspile :: Bool + , oCommentsOnly :: Bool } defopts :: C2HaskellOptions @@ -865,6 +909,7 @@ defopts = C2HaskellOptions , oVerbose = False , oPreprocess = False , oTranspile = False + , oCommentsOnly = False } parseOptions :: [String] -> C2HaskellOptions -> C2HaskellOptions @@ -875,6 +920,7 @@ parseOptions ("-p":args) o = parseOptions args o{ oPrettyC = True } parseOptions ("--cpp":args) o = parseOptions args o{ oPreprocess = True } parseOptions ("-v":args) o = parseOptions args o{ oVerbose = True } parseOptions ("--tohs":args) o = parseOptions args o{ oTranspile = True } +parseOptions ("--comments":args) o = parseOptions args o{ oCommentsOnly = True } parseOptions as o = error (show as) @@ -1392,6 +1438,42 @@ goMissing haskmod db cfun = do htyp -> hPutStr haskmod $ commented $ "Unsupported haskell type: " ++ HS.prettyPrint htyp +-- Represent a comment as a C function call, so that it can be preserved in +-- syntax tree manipulations. +rewriteComment :: StyledComment -> CExpression NodeInfo +rewriteComment c = C.CCall (CVar (internalIdent "__cmt") ni) + [ CConst (CIntConst (cInteger $ fromIntegral $ fromEnum (commentStyle c)) ni) + , CConst (CStrConst (cString $ styledComment c) ni) ] + ni + + where + ni = mkNodeInfoOnlyPos $ position 0 "" (commentRow c) (commentCol c) Nothing + +data CommentStyle = VanillaComment | StarBarComment + deriving (Eq,Ord,Enum,Show) + +data StyledComment = StyledComment + { styledComment :: String + , commentStyle :: CommentStyle + , commentRow :: Int + , commentCol :: Int + } + deriving (Eq,Ord,Show) + +reflowComment :: (Int,Int,String) -> StyledComment +reflowComment (row,col,s) = StyledComment s' (if allstar then StarBarComment else VanillaComment) row col + where + xs = map (reverse . dropWhile isSpace . reverse) $ lines s + ys = reverse $ dropWhile (null . snd) $ reverse $ map (span isSpace) xs + countCols '\t' = 8 + countCols _ = 1 + starred (sp,'*':_) = sum (map countCols sp) == col + starred _ = False + allstar = all starred (drop 1 ys) + unstar (_,'*':xs) | allstar = dropWhile isSpace xs + unstar (_,x) = x + s' = unwords $ map unstar ys + readComments :: Num lin => FilePath -> IO [(lin, Int, [Char])] readComments fname = grepCComments 1 1 <$> readFile fname @@ -1512,6 +1594,11 @@ main = do -- putStrLn $ "includes = " ++ ppShow (fmap fst r) -- cs <- readComments fname case () of + _ | oCommentsOnly hopts + -> do cs <- readComments fname + forM_ cs $ \c -> do + putStrLn $ show c + putStrLn $ show (reflowComment c) _ | oPreprocess hopts -- --cpp -> case prer of Left e -> print e -- cgit v1.2.3