Preserve leading comments/whitespace when formatting code (#146)

Partial fix for #145

Before this change `dhall-format` would get rid of all comments when formatting
code.  After this change `dhall-format` will preserve any leading comments and
whitespace so that users can at least add top-level comment headers to their
files

dhall-format/Main.hs

@@ -13,7 +13,12 @@
 
     Note that this does not yet support:
 
-    * Preserving comments (currently, this just removes them)
+    * Preserving all comments
+        * Currently, this only preserves all leading comments and whitespace
+          up until the last newline preceding the code
+        * This lets you preserve a comment header but if you want to document
+          subexpressions then you will need to split them into a separate
+          file for now
     * Preserving multi-line strings (this reduces them to ordinary strings)
     * Preserving string interpolation (this expands interpolation to @++@)
 
@@ -23,8 +28,9 @@ module Main where
 
 import Control.Exception (SomeException)
 import Control.Monad (when)
+import Data.Monoid ((<>))
 import Data.Version (showVersion)
-import Dhall.Parser (exprFromText)
+import Dhall.Parser (exprAndHeaderFromText)
 import Filesystem.Path.CurrentOS (FilePath)
 import Options.Generic (Generic, ParseRecord, type (<?>)(..))
 import Prelude hiding (FilePath)
@@ -74,20 +80,21 @@ main = do
                 let fileString = Filesystem.Path.CurrentOS.encodeString file
                 strictText <- Data.Text.IO.readFile fileString
                 let lazyText = Data.Text.Lazy.fromStrict strictText
-                expr <- case exprFromText (Directed "(stdin)" 0 0 0 0) lazyText of
-                    Left  err  -> Control.Exception.throwIO err
-                    Right expr -> return expr
+                (header, expr) <- case exprAndHeaderFromText (Directed "(stdin)" 0 0 0 0) lazyText of
+                    Left  err -> Control.Exception.throwIO err
+                    Right x   -> return x
 
-                let doc = Pretty.pretty expr
+                let doc = Pretty.pretty header <> Pretty.pretty expr
                 System.IO.withFile fileString System.IO.WriteMode (\handle -> do
-                    Pretty.renderIO handle (Pretty.layoutSmart opts doc) )
+                    Pretty.renderIO handle (Pretty.layoutSmart opts doc)
+                    Data.Text.IO.hPutStrLn handle "" )
             Nothing -> do
                 inText <- Data.Text.Lazy.IO.getContents
 
-                expr <- case exprFromText (Directed "(stdin)" 0 0 0 0) inText of
-                    Left  err  -> Control.Exception.throwIO err
-                    Right expr -> return expr
+                (header, expr) <- case exprAndHeaderFromText (Directed "(stdin)" 0 0 0 0) inText of
+                    Left  err -> Control.Exception.throwIO err
+                    Right x   -> return x
 
-                let doc = Pretty.pretty expr
+                let doc = Pretty.pretty header <> Pretty.pretty expr
                 Pretty.renderIO System.IO.stdout (Pretty.layoutSmart opts doc)
                 Data.Text.IO.putStrLn "" )

src/Dhall/Parser.hs

@@ -8,6 +8,7 @@
 module Dhall.Parser (
     -- * Utilities
       exprFromText
+    , exprAndHeaderFromText
 
     -- * Parsers
     , expr, exprA
@@ -26,6 +27,7 @@ import Data.CharSet (CharSet)
 import Data.Map (Map)
 import Data.Monoid ((<>))
 import Data.Sequence (ViewL(..))
+import Data.String (fromString)
 import Data.Text.Buildable (Buildable(..))
 import Data.Text.Lazy (Text)
 import Data.Typeable (Typeable)
@@ -46,6 +48,8 @@ import qualified Data.Map
 import qualified Data.ByteString.Lazy
 import qualified Data.List
 import qualified Data.Sequence
+import qualified Data.Text
+import qualified Data.Text.Encoding
 import qualified Data.Text.Lazy
 import qualified Data.Text.Lazy.Builder
 import qualified Data.Text.Lazy.Encoding
@@ -1010,16 +1014,39 @@ instance Exception ParseError
 
 -- | Parse an expression from `Text` containing a Dhall program
 exprFromText :: Delta -> Text -> Either ParseError (Expr Src Path)
-exprFromText delta text = case result of
-    Success r       -> Right r
-    Failure errInfo -> Left (ParseError (Text.Trifecta._errDoc errInfo))
+exprFromText delta text = fmap snd (exprAndHeaderFromText delta text)
+
+{-| Like `exprFromText` but also returns the leading comments and whitespace
+    (i.e. header) up to the last newline before the code begins
+
+    In other words, if you have a Dhall file of the form:
+
+> -- Comment 1
+> {- Comment -} 2
+
+    Then this will preserve @Comment 1@, but not @Comment 2@
+
+    This is used by @dhall-format@ to preserve leading comments and whitespace
+-}
+exprAndHeaderFromText
+    :: Delta
+    -> Text
+    -> Either ParseError (Text, Expr Src Path)
+exprAndHeaderFromText delta text = case result of
+    Failure errInfo    -> Left (ParseError (Text.Trifecta._errDoc errInfo))
+    Success (bytes, r) -> case Data.Text.Encoding.decodeUtf8' bytes of
+        Left  errInfo -> Left (ParseError (fromString (show errInfo)))
+        Right txt     -> do
+            let stripped = Data.Text.dropWhileEnd (/= '\n') txt
+            let lazyText = Data.Text.Lazy.fromStrict stripped
+            Right (lazyText, r)
   where
     string = Data.Text.Lazy.unpack text
 
     parser = unParser (do
-        Text.Parser.Token.whiteSpace
+        bytes <- Text.Trifecta.slicedWith (\_ x -> x) (Text.Parser.Token.whiteSpace)
         r <- expr
         Text.Parser.Combinators.eof
-        return r )
+        return (bytes, r) )
 
     result = Text.Trifecta.parseString parser delta string

src/Dhall/Tutorial.hs

@@ -1591,12 +1591,18 @@ import Dhall
 -- >       +0
 -- >   )
 --
--- Carefully note that the code formatter does not yet preserve comments:
+-- Carefully note that the code formatter does not preserve all comments.
+-- Currently, the formatter only preserves leading comments and whitespace
+-- up until the last newline preceding the code.  In other words:
 --
 -- > $ dhall-format
--- > -- Hello!
--- > 1
+-- > {- This comment will be preserved by the formatter -}
+-- > -- ... and this comment will be preserved, too
+-- > {- This comment will *NOT* be preserved -} 1
+-- > -- ... and this comment will also *NOT* be preserved
 -- > <Ctrl-D>
+-- > {- This comment will be preserved by the formatter -}
+-- > -- ... and this comment will be preserved, too
 -- > 1
 
 -- $builtins