Implement experimental support for CPP

CHANGELOG.md

@@ -12,6 +12,9 @@
 * Ormolu can now be enabled and disabled via special comments. [Issue
   435](https://github.com/tweag/ormolu/issues/435).
 
+* Added experimental support for simple CPP. [Issue
+  415](https://github.com/tweag/ormolu/issues/415).
+
 ## Ormolu 0.0.4.0
 
 * When given several files to format, Ormolu does not stop on the first

README.md

@@ -114,7 +114,9 @@ independent top-level definitions.
 
 ## Current limitations
 
-* Does not handle CPP (wontfix, see [the design document][design]).
+* CPP support is experimental. CPP is virtually impossible to handle
+  correctly, so we process them as a sort of unchangeable snippets. This
+  works only in simple cases when CPP conditionals are self-contained.
 * Input modules should be parsable by Haddock, which is a bit stricter
   criterion than just being valid Haskell modules.
 * Various minor idempotence issues, most of them are related to comments.

app/Main.hs

@@ -169,11 +169,6 @@ configParser =
         short 'd',
         help "Output information useful for debugging"
       ]
-    <*> (switch . mconcat)
-      [ long "tolerate-cpp",
-        short 'p',
-        help "Do not fail if CPP pragma is present"
-      ]
     <*> (switch . mconcat)
       [ long "check-idempotency",
         short 'c',

data/examples/declaration/annotation/annotation-out.hs

@@ -18,4 +18,5 @@ foo = 5
 
 data Foo = Foo Int
 {-# ANN type Foo ("HLint: ignore") #-}
+
 {- Comment -}

data/examples/module-header/stack-header-0-out.hs

@@ -3,4 +3,5 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 main = return ()
+
 -- stack runhaskell

data/examples/module-header/stack-header-1-out.hs

@@ -4,4 +4,5 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 main = return ()
+
 -- stack runhaskell

data/examples/other/cpp/lonely-hash-out.hs

@@ -0,0 +1,14 @@
+module Main (main) where
+
+import Data.Void
+import Test.Hspec
+import Test.Hspec.Megaparsec
+import Text.Megaparsec
+import Text.Megaparsec.Char
+
+# if !MIN_VERSION_base(4,13,0)
+import Data.Semigroup ((<>))
+# endif
+
+main :: IO ()
+main = return ()

data/examples/other/cpp/lonely-hash.hs

@@ -0,0 +1,14 @@
+module Main (main) where
+
+import Data.Void
+import Test.Hspec
+import Test.Hspec.Megaparsec
+import Text.Megaparsec
+import Text.Megaparsec.Char
+
+# if !MIN_VERSION_base(4,13,0)
+import Data.Semigroup ((<>))
+# endif
+
+main :: IO ()
+main = return ()

data/examples/other/cpp/separation-0a-out.hs

@@ -0,0 +1,7 @@
+instance Stream s => Monad (ParsecT e s m) where
+  return = pure
+  (>>=) = pBind
+
+#if !(MIN_VERSION_base(4,13,0))
+  fail   = Fail.fail
+#endif

data/examples/other/cpp/separation-0a.hs

@@ -0,0 +1,6 @@
+instance Stream s => Monad (ParsecT e s m) where
+  return = pure
+  (>>=)  = pBind
+#if !(MIN_VERSION_base(4,13,0))
+  fail   = Fail.fail
+#endif

data/examples/other/cpp/separation-0b-out.hs

@@ -0,0 +1,10 @@
+instance Stream s => Monad (ParsecT e s m) where
+  return = pure
+  (>>=) = pBind
+
+#if !(MIN_VERSION_base(4,13,0))
+  fail   = Fail.fail
+#endif
+
+foo :: Int
+foo = undefined

data/examples/other/cpp/separation-0b.hs

@@ -0,0 +1,9 @@
+instance Stream s => Monad (ParsecT e s m) where
+  return = pure
+  (>>=)  = pBind
+#if !(MIN_VERSION_base(4,13,0))
+  fail   = Fail.fail
+#endif
+
+foo :: Int
+foo = undefined

data/examples/other/cpp/separation-1a-out.hs

@@ -0,0 +1,12 @@
+decompressingPipe ::
+  (PrimMonad m, MonadThrow m, MonadResource m) =>
+  CompressionMethod ->
+  ConduitT ByteString ByteString m ()
+decompressingPipe Store = C.awaitForever C.yield
+decompressingPipe Deflate = Z.decompress $ Z.WindowBits (-15)
+
+#ifdef ENABLE_BZIP2
+decompressingPipe BZip2   = BZ.bunzip2
+#else
+decompressingPipe BZip2   = throwM BZip2Unsupported
+#endif

data/examples/other/cpp/separation-1a.hs

@@ -0,0 +1,11 @@
+decompressingPipe
+  :: (PrimMonad m, MonadThrow m, MonadResource m)
+  => CompressionMethod
+  -> ConduitT ByteString ByteString m ()
+decompressingPipe Store   = C.awaitForever C.yield
+decompressingPipe Deflate = Z.decompress $ Z.WindowBits (-15)
+#ifdef ENABLE_BZIP2
+decompressingPipe BZip2   = BZ.bunzip2
+#else
+decompressingPipe BZip2   = throwM BZip2Unsupported
+#endif

data/examples/other/cpp/separation-1b-out.hs

@@ -0,0 +1,15 @@
+decompressingPipe ::
+  (PrimMonad m, MonadThrow m, MonadResource m) =>
+  CompressionMethod ->
+  ConduitT ByteString ByteString m ()
+decompressingPipe Store = C.awaitForever C.yield
+decompressingPipe Deflate = Z.decompress $ Z.WindowBits (-15)
+
+#ifdef ENABLE_BZIP2
+decompressingPipe BZip2   = BZ.bunzip2
+#else
+decompressingPipe BZip2   = throwM BZip2Unsupported
+#endif
+
+foo :: Int
+foo = undefined

data/examples/other/cpp/separation-1b.hs

@@ -0,0 +1,14 @@
+decompressingPipe
+  :: (PrimMonad m, MonadThrow m, MonadResource m)
+  => CompressionMethod
+  -> ConduitT ByteString ByteString m ()
+decompressingPipe Store   = C.awaitForever C.yield
+decompressingPipe Deflate = Z.decompress $ Z.WindowBits (-15)
+#ifdef ENABLE_BZIP2
+decompressingPipe BZip2   = BZ.bunzip2
+#else
+decompressingPipe BZip2   = throwM BZip2Unsupported
+#endif
+
+foo :: Int
+foo = undefined

data/examples/other/cpp/separation-2a-out.hs

@@ -0,0 +1,9 @@
+ffff, ffffffff :: Natural
+
+#ifdef HASKELL_ZIP_DEV_MODE
+ffff     = 200
+ffffffff = 5000
+#else
+ffff     = 0xffff
+ffffffff = 0xffffffff
+#endif

data/examples/other/cpp/separation-2a.hs

@@ -0,0 +1,8 @@
+ffff, ffffffff :: Natural
+#ifdef HASKELL_ZIP_DEV_MODE
+ffff     = 200
+ffffffff = 5000
+#else
+ffff     = 0xffff
+ffffffff = 0xffffffff
+#endif

data/examples/other/cpp/separation-2b-out.hs

@@ -0,0 +1,12 @@
+ffff, ffffffff :: Natural
+
+#ifdef HASKELL_ZIP_DEV_MODE
+ffff     = 200
+ffffffff = 5000
+#else
+ffff     = 0xffff
+ffffffff = 0xffffffff
+#endif
+
+foo :: Int
+foo = undefined

data/examples/other/cpp/separation-2b.hs

@@ -0,0 +1,11 @@
+ffff, ffffffff :: Natural
+#ifdef HASKELL_ZIP_DEV_MODE
+ffff     = 200
+ffffffff = 5000
+#else
+ffff     = 0xffff
+ffffffff = 0xffffffff
+#endif
+
+foo :: Int
+foo = undefined

data/examples/other/cpp/shifted-out.hs

@@ -0,0 +1,21 @@
+sinkData h compression = do
+  (uncompressedSize, crc32, compressedSize) <-
+    case compression of
+      Store ->
+        withCompression
+          dataSink
+      Deflate ->
+        withCompression $
+          Z.compress 9 (Z.WindowBits (-15)) .| dataSink
+#ifdef ENABLE_BZIP2
+      BZip2   -> withCompression $
+        BZ.bzip2 .| dataSink
+#else
+      BZip2   -> throwM BZip2Unsupported
+#endif
+  return
+    DataDescriptor
+      { ddCRC32 = fromIntegral crc32,
+        ddCompressedSize = compressedSize,
+        ddUncompressedSize = uncompressedSize
+      }

data/examples/other/cpp/shifted.hs

@@ -0,0 +1,17 @@
+sinkData h compression = do
+  (uncompressedSize, crc32, compressedSize) <-
+    case compression of
+      Store   -> withCompression
+        dataSink
+      Deflate -> withCompression $
+        Z.compress 9 (Z.WindowBits (-15)) .| dataSink
+#ifdef ENABLE_BZIP2
+      BZip2   -> withCompression $
+        BZ.bzip2 .| dataSink
+#else
+      BZip2   -> throwM BZip2Unsupported
+#endif
+  return DataDescriptor
+    { ddCRC32            = fromIntegral crc32
+    , ddCompressedSize   = compressedSize
+    , ddUncompressedSize = uncompressedSize }

data/examples/other/cpp/simple-import-out.hs

@@ -0,0 +1,14 @@
+module Main (main) where
+
+import Data.Void
+import Test.Hspec
+import Test.Hspec.Megaparsec
+import Text.Megaparsec
+import Text.Megaparsec.Char
+
+#if !MIN_VERSION_base(4,13,0)
+import Data.Semigroup ((<>))
+#endif
+
+main :: IO ()
+main = return ()

data/examples/other/cpp/simple-import.hs

@@ -0,0 +1,14 @@
+module Main (main) where
+
+import Data.Void
+import Test.Hspec
+import Test.Hspec.Megaparsec
+import Text.Megaparsec
+import Text.Megaparsec.Char
+
+#if !MIN_VERSION_base(4,13,0)
+import Data.Semigroup ((<>))
+#endif
+
+main :: IO ()
+main = return ()

format.sh

@@ -7,6 +7,6 @@ set -e
 
 export LANG="C.UTF-8"
 
-ormolu -p -m inplace $(find app -type f -name "*.hs")
-ormolu -p -m inplace $(find src -type f \( -name "*.hs" -o -name "*.hs-boot" \))
-ormolu -p -m inplace $(find tests -type f -name "*.hs")
+ormolu -m inplace $(find app -type f -name "*.hs")
+ormolu -m inplace $(find src -type f \( -name "*.hs" -o -name "*.hs-boot" \))
+ormolu -m inplace $(find tests -type f -name "*.hs")

nix/ormolize/default.nix

@@ -34,7 +34,7 @@
         cp "$hs_file" "''${hs_file}-original"
       done
 
-      (ormolu --tolerate-cpp --check-idempotency --mode inplace $hs_files || true) 2> log.txt
+      (ormolu --check-idempotency --mode inplace $hs_files || true) 2> log.txt
     '';
     inherit doCheck;
     checkPhase =

ormolu.cabal

@@ -110,6 +110,7 @@ library
                     , Ormolu.Printer.Operators
                     , Ormolu.Printer.SpanStream
                     , Ormolu.Processing.Common
+                    , Ormolu.Processing.Cpp
                     , Ormolu.Processing.Postprocess
                     , Ormolu.Processing.Preprocess
                     , Ormolu.Utils

src/Ormolu/Config.hs

@@ -17,10 +17,6 @@ data Config = Config
     cfgUnsafe :: !Bool,
     -- | Output information useful for debugging
     cfgDebug :: !Bool,
-    -- | Do not fail if CPP pragma is present (still doesn't handle CPP but
-    -- useful for formatting of files that enable the extension without
-    -- actually containing CPP macros)
-    cfgTolerateCpp :: !Bool,
     -- | Checks if re-formatting the result is idempotent.
     cfgCheckIdempotency :: !Bool
   }
@@ -33,7 +29,6 @@ defaultConfig =
     { cfgDynOptions = [],
       cfgUnsafe = False,
       cfgDebug = False,
-      cfgTolerateCpp = False,
       cfgCheckIdempotency = False
     }
 

src/Ormolu/Exception.hs

@@ -19,9 +19,7 @@ import System.IO
 
 -- | Ormolu exception representing all cases when Ormolu can fail.
 data OrmoluException
-  = -- | Ormolu does not work with source files that use CPP
-    OrmoluCppEnabled FilePath
-  | -- | Parsing of original source code failed
+  = -- | Parsing of original source code failed
     OrmoluParsingFailed GHC.SrcSpan String
   | -- | Parsing of formatted source code failed
     OrmoluOutputParsingFailed GHC.SrcSpan String
@@ -35,11 +33,6 @@ data OrmoluException
 
 instance Exception OrmoluException where
   displayException = \case
-    OrmoluCppEnabled path ->
-      unlines
-        [ "CPP is not supported:",
-          withIndent path
-        ]
     OrmoluParsingFailed s e ->
       showParsingErr "The GHC parser (in Haddock mode) failed:" s [e]
     OrmoluOutputParsingFailed s e ->
@@ -81,8 +74,8 @@ withPrettyOrmoluExceptions m = m `catch` h
       hPutStrLn stderr (displayException e)
       exitWith . ExitFailure $
         case e of
-          -- Error code 1 is for `error` or `notImplemented`
-          OrmoluCppEnabled {} -> 2
+          -- Error code 1 is for 'error' or 'notImplemented'
+          -- 2 used to be for erroring out on CPP
           OrmoluParsingFailed {} -> 3
           OrmoluOutputParsingFailed {} -> 4
           OrmoluASTDiffers {} -> 5

src/Ormolu/Parser.hs

@@ -12,7 +12,6 @@ where
 import Bag (bagToList)
 import qualified CmdLineParser as GHC
 import Control.Exception
-import Control.Monad
 import Control.Monad.IO.Class
 import qualified Data.List as L
 import qualified Data.List.NonEmpty as NE
@@ -68,8 +67,6 @@ parseModule Config {..} path input' = liftIO $ do
                 (mkSrcLoc (GHC.mkFastString path) 1 1)
                 (mkSrcLoc (GHC.mkFastString path) 1 1)
          in throwIO (OrmoluParsingFailed loc err)
-  when (GHC.xopt Cpp dynFlags && not cfgTolerateCpp) $
-    throwIO (OrmoluCppEnabled path)
   let useRecordDot =
         "record-dot-preprocessor" == pgm_F dynFlags
           || any

src/Ormolu/Printer/Comments.hs

@@ -51,7 +51,11 @@ spitFollowingComments ref = do
 
 -- | Output all remaining comments in the comment stream.
 spitRemainingComments :: R ()
-spitRemainingComments = void $ handleCommentSeries spitRemainingComment
+spitRemainingComments = do
+  -- Make sure we have a blank a line between the last definition and the
+  -- trailing comments.
+  newline
+  void $ handleCommentSeries spitRemainingComment
 
 ----------------------------------------------------------------------------
 -- Single-comment functions