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,10 @@ 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. Use
+  Ormolu with CPP at your own risk.
 * 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

src/Ormolu/Processing/Cpp.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Support for CPP.
+module Ormolu.Processing.Cpp
+  ( State (..),
+    processLine,
+    unmaskLine,
+  )
+where
+
+import Control.Monad
+import Data.Char (isSpace)
+import qualified Data.List as L
+import Data.Maybe (isJust)
+import Data.String
+import Data.Text (Text)
+import qualified Data.Text as T
+
+-- | State of the CPP processor.
+data State
+  = -- | Outside of CPP directives
+    Outside
+  | -- | In a conditional expression
+    InConditional
+  | -- | In a continuation (after @\\@)
+    InContinuation
+  deriving (Eq, Show)
+
+-- | Automatically mask the line when needed and update the 'State'.
+processLine :: String -> State -> (String, State)
+processLine line state
+  | for "define " = (masked, state')
+  | for "include " = (masked, state')
+  | for "undef " = (masked, state')
+  | for "ifdef " = (masked, InConditional)
+  | for "ifndef " = (masked, InConditional)
+  | for "if " = (masked, InConditional)
+  | for "else" = (masked, InConditional)
+  | for "elif" = (masked, InConditional)
+  | for "endif" = (masked, state')
+  | otherwise =
+    case state of
+      Outside -> (line, Outside)
+      InConditional -> (masked, InConditional)
+      InContinuation -> (masked, state')
+  where
+    for directive = isJust $ do
+      s <- dropWhile isSpace <$> L.stripPrefix "#" line
+      void (L.stripPrefix directive s)
+    masked = maskLine line
+    state' =
+      if "\\" `L.isSuffixOf` line
+        then InContinuation
+        else Outside
+
+-- | Mask the given line.
+maskLine :: String -> String
+maskLine x = maskPrefix ++ x
+
+-- | If the given line is masked, unmask it. Otherwise return the line
+-- unchanged.
+unmaskLine :: Text -> Text
+unmaskLine x =
+  case T.stripPrefix maskPrefix (T.stripStart x) of
+    Nothing -> x
+    Just x' -> x'
+
+-- | Mask prefix for CPP.
+maskPrefix :: IsString s => s
+maskPrefix = "-- ORMOLU_CPP_MASK"

src/Ormolu/Processing/Postprocess.hs

@@ -7,10 +7,15 @@ where
 import Data.Text (Text)
 import qualified Data.Text as T
 import Ormolu.Processing.Common
+import qualified Ormolu.Processing.Cpp as Cpp
 
 -- | Postprocess output of the formatter.
 postprocess :: Text -> Text
-postprocess = T.unlines . filter (not . magicComment) . T.lines
+postprocess =
+  T.unlines
+    . fmap Cpp.unmaskLine
+    . filter (not . magicComment)
+    . T.lines
   where
     magicComment x =
       x == startDisabling || x == endDisabling

src/Ormolu/Processing/Preprocess.hs

@@ -15,10 +15,11 @@ import Data.Maybe (maybeToList)
 import FastString
 import Ormolu.Parser.Shebang (isShebang)
 import Ormolu.Processing.Common
+import qualified Ormolu.Processing.Cpp as Cpp
 import SrcLoc
 
 -- | Transform given input possibly returning comments extracted from it.
--- This handles LINE pragmas, shebangs, and the magic comments for
+-- This handles LINE pragmas, CPP, shebangs, and the magic comments for
 -- enabling\/disabling of Ormolu.
 preprocess ::
   -- | File name, just to use in the spans
@@ -27,9 +28,9 @@ preprocess ::
   String ->
   -- | Adjusted input with comments extracted from it
   (String, [Located String])
-preprocess path input = go 1 OrmoluEnabled id id (lines input)
+preprocess path input = go 1 OrmoluEnabled Cpp.Outside id id (lines input)
   where
-    go !n ormoluState inputSoFar csSoFar = \case
+    go !n ormoluState cppState inputSoFar csSoFar = \case
       [] ->
         let input' = unlines (inputSoFar [])
          in ( case ormoluState of
@@ -38,10 +39,12 @@ preprocess path input = go 1 OrmoluEnabled id id (lines input)
               csSoFar []
             )
       (x : xs) ->
-        let (x', ormoluState', cs) = processLine path n ormoluState x
+        let (x', ormoluState', cppState', cs) =
+              processLine path n ormoluState cppState x
          in go
               (n + 1)
               ormoluState'
+              cppState'
               (inputSoFar . (x' :))
               (csSoFar . (maybeToList cs ++))
               xs
@@ -54,34 +57,41 @@ processLine ::
   Int ->
   -- | Whether Ormolu is currently enabled
   OrmoluState ->
+  -- | CPP state
+  Cpp.State ->
   -- | The actual line
   String ->
   -- | Adjusted line and possibly a comment extracted from it
-  (String, OrmoluState, Maybe (Located String))
-processLine path n ormoluState line
+  (String, OrmoluState, Cpp.State, Maybe (Located String))
+processLine path n ormoluState Cpp.Outside line
   | "{-# LINE" `L.isPrefixOf` line =
     let (pragma, res) = getPragma line
         size = length pragma
         ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (size + 1))
-     in (res, ormoluState, Just (L ss pragma))
+     in (res, ormoluState, Cpp.Outside, Just (L ss pragma))
   | isOrmoluEnable line =
     case ormoluState of
       OrmoluEnabled ->
-        (enableMarker, OrmoluEnabled, Nothing)
+        (enableMarker, OrmoluEnabled, Cpp.Outside, Nothing)
       OrmoluDisabled ->
-        (endDisabling ++ enableMarker, OrmoluEnabled, Nothing)
+        (endDisabling ++ enableMarker, OrmoluEnabled, Cpp.Outside, Nothing)
   | isOrmoluDisable line =
     case ormoluState of
       OrmoluEnabled ->
-        (disableMarker ++ startDisabling, OrmoluDisabled, Nothing)
+        (disableMarker ++ startDisabling, OrmoluDisabled, Cpp.Outside, Nothing)
       OrmoluDisabled ->
-        (disableMarker, OrmoluDisabled, Nothing)
+        (disableMarker, OrmoluDisabled, Cpp.Outside, Nothing)
   | isShebang line =
     let ss = mkSrcSpan (mkSrcLoc' 1) (mkSrcLoc' (length line))
-     in ("", ormoluState, Just (L ss line))
-  | otherwise = (line, ormoluState, Nothing)
+     in ("", ormoluState, Cpp.Outside, Just (L ss line))
+  | otherwise =
+    let (line', cppState') = Cpp.processLine line Cpp.Outside
+     in (line', ormoluState, cppState', Nothing)
   where
     mkSrcLoc' = mkSrcLoc (mkFastString path) n
+processLine _ _ ormoluState cppState line =
+  let (line', cppState') = Cpp.processLine line cppState
+   in (line', ormoluState, cppState', Nothing)
 
 -- | Take a line pragma and output its replacement (where line pragma is
 -- replaced with spaces) and the contents of the pragma itself.