Use parsed include stack for for pretty-printed C.

1 files changed, 40 insertions, 18 deletions

diff --git a/c2haskell.hs b/c2haskell.hs
index cc590c3..48b30e3 100644
--- a/c2haskell.hs
+++ b/c2haskell.hs
@@ -7,6 +7,7 @@
 {-# LANGUAGE QuasiQuotes              #-}
 {-# LANGUAGE TemplateHaskell          #-}
 
+import Control.Arrow (left)
 import Data.Generics.Aliases
 import Data.Generics.Schemes
 -- import Debug.Trace
@@ -48,23 +49,38 @@ trace _ = id
 --
 -- The resulting file may not compile (because of missing @#define@ directives and similar things), but is very useful
 -- for testing, as otherwise the pretty printed file will be cluttered with declarations from system headers.
-prettyUsingInclude :: CTranslUnit -> Doc
-prettyUsingInclude (CTranslUnit edecls _) =
-  includeWarning headerFiles
-    $$
-  vcat (map (either includeHeader pretty) mappedDecls)
+prettyUsingInclude :: IncludeStack -> CTranslUnit -> Doc
+prettyUsingInclude incs (CTranslUnit edecls _) =
+  vcat (map (either includeHeader pretty) $ sortBy sysfst mappedDecls)
   where
     (headerFiles,mappedDecls) = foldr (addDecl . tagIncludedDecls) (Set.empty,[]) edecls
-    tagIncludedDecls edecl | maybe False isHeaderFile (fileOfNode edecl) = Left ((posFile . posOf) edecl)
+    tagIncludedDecls edecl | maybe False isHeaderFile (fileOfNode edecl) = Left ((includeTopLevel incs . posFile . posOf) edecl)
                            | otherwise = Right edecl
     addDecl decl@(Left headerRef) (headerSet, ds)
-      | Set.member headerRef headerSet = (headerSet, ds)
-      | otherwise = (Set.insert headerRef headerSet, decl : ds)
+        | null headerRef || Set.member headerRef headerSet
+                                         = (headerSet, ds)
+        | otherwise                      = (Set.insert headerRef headerSet, decl : ds)
     addDecl decl (headerSet,ds) = (headerSet, decl : ds)
-    includeHeader hFile = text "#include" <+> doubleQuotes (text hFile)
+
+    includeHeader hFile = text "#include" <+> text hFile
     isHeaderFile = (".h" `isSuffixOf`)
-    includeWarning hs | Set.null hs = empty
-                      | otherwise = text "/* Warning: The #include directives in this file aren't necessarily correct. */"
+
+    sysfst (Left ('"':a)) (Left ('<':b)) = Prelude.GT
+    sysfst (Left a) (Left b) = trace (show (a,b)) $ Prelude.GT
+    sysfst _              _              = Prelude.LT
+
+
+includeTopLevel (IncludeStack incs) f = do
+    stacks <- maybeToList $ Map.lookup f incs
+    stack <- take 1 stacks
+    top <- take 1 $ drop 4 $ reverse stack
+    if take 1 top == "/"
+        then let ws = groupBy (\_ c -> c /='/') top
+                 (xs,ys) = break (=="/include") ws
+                 ys' = drop 1 ys
+             in if not (null ys') then '<': drop 1 (concat ys') ++ ">"
+                                  else '"':top++"\""
+        else '"':top ++"\""
 
 specs :: CExternalDeclaration a -> [CDeclarationSpecifier a]
 specs (CFDefExt (CFunDef ss _ _ _ _)) = ss
@@ -397,7 +413,10 @@ makeAcceptableImport (HS.TyFun a (TyCon c (UnQual d (HS.Ident e x))) xs)
 makeAcceptableImport t = t
 
 -- c2haskell :: Foldable t => C2HaskellOptions -> p -> t String -> CTranslationUnit NodeInfo -> IO ()
-c2haskell opts cs missings (CTranslUnit edecls _) = do
+c2haskell :: Foldable t =>
+                   C2HaskellOptions
+                   -> p1 -> t String -> IncludeStack -> CTranslationUnit NodeInfo -> IO ()
+c2haskell opts cs missings incs (CTranslUnit edecls _) = do
     let db = foldr update initTranspile edecls
         es = Map.filter (\d -> symbolLocal d && not (symbolStatic d)) (syms db)
     case selectFunction opts of
@@ -824,21 +843,24 @@ main = do
     let usageString = self ++ " [-v] [-p] [-f <sym>] -- [gcc options] <cfile>"
     let m = usage args
     fromMaybe (putStrLn usageString) $ m <&> \(hopts,cargs,fname) -> do
-        r <- parseCFile (newGCC "gcc") Nothing cargs fname
+        prer <- runPreprocessor (newGCC "gcc") (rawCppArgs cargs fname)
+        let r = do
+                pre <- left Left $ prer
+                c <- left Right $ parseC pre (initPos fname)
+                return (includeStack pre,c)
         cs <- readComments fname
         case () of
             _ | preprocess hopts -- --cpp
                 -> do
-                r2 <- runPreprocessor (newGCC "gcc") (rawCppArgs cargs fname)
-                case r2 of
+                case prer of
                     Left e -> print e
                     Right bs -> putStrLn $ ppShow $ includeStack $ bs
             _ | prettyC hopts -- -p
                  -> do
-                print (fmap prettyUsingInclude r)
+                print (fmap (\(incs,decls) -> prettyUsingInclude incs decls) r)
             _ | prettyTree hopts -- -t
                  -> do
-                putStrLn $ ppShow $ everywhere (mkT eraseNodeInfo) <$> r
+                putStrLn $ ppShow $ everywhere (mkT eraseNodeInfo) . snd <$> r
             _    -> do
                 syms <- linker cargs fname
-                either print (c2haskell hopts cs syms) r
+                either print (uncurry $ c2haskell hopts cs syms) r