Represent comments as functions.

1 files 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