Merge pull request #132 from avh4/retain-comments

Formatting retains comments (module header and paren expressions)

builder/src/Build.hs

@@ -269,7 +269,7 @@ crawlFile env@(Env _ root projectType _ _ buildID _ _) mvar docsNeed expectedNam
     case Parse.fromByteString projectType source of
       Left err ->
         return $ SBadSyntax path time source err
-      Right modul@(Src.Module maybeActualName _ _ imports values _ _ _ _) ->
+      Right modul@(Src.Module maybeActualName _ _ imports values _ _ _ _ _) ->
         case maybeActualName of
           Nothing ->
             return $ SBadSyntax path time source (Syntax.ModuleNameUnspecified expectedName)
@@ -335,11 +335,11 @@ checkModule env@(Env _ root projectType _ _ _ _ _) foreigns resultsMVar name sta
                 RProblem $
                   Error.Module name path time source $
                     case Parse.fromByteString projectType source of
-                      Right (Src.Module _ _ _ imports _ _ _ _ _) ->
+                      Right (Src.Module _ _ _ imports _ _ _ _ _ _) ->
                         Error.BadImports (toImportErrors env results imports problems)
                       Left err ->
                         Error.BadSyntax err
-    SChanged local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) docsNeed ->
+    SChanged local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _ _) docsNeed ->
       do
         results <- readMVar resultsMVar
         depsStatus <- checkDeps root results deps lastCompile
@@ -760,7 +760,7 @@ fromRepl root details source =
     case Parse.fromByteString projectType source of
       Left syntaxError ->
         return $ Left $ Exit.ReplBadInput source $ Error.BadSyntax syntaxError
-      Right modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
+      Right modul@(Src.Module _ _ _ imports _ _ _ _ _ _) ->
         do
           dmvar <- Details.loadInterfaces root details
 
@@ -785,7 +785,7 @@ fromRepl root details source =
                 finalizeReplArtifacts env source modul depsStatus resultMVars results
 
 finalizeReplArtifacts :: Env -> B.ByteString -> Src.Module -> DepsStatus -> ResultDict -> Map.Map ModuleName.Raw Result -> IO (Either Exit.Repl ReplArtifacts)
-finalizeReplArtifacts env@(Env _ root projectType platform _ _ _ _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) depsStatus resultMVars results =
+finalizeReplArtifacts env@(Env _ root projectType platform _ _ _ _) source modul@(Src.Module _ _ _ imports _ _ _ _ _ _) depsStatus resultMVars results =
   let pkg =
         projectTypeToPkg projectType
 
@@ -951,7 +951,7 @@ crawlRoot env@(Env _ _ projectType _ _ buildID _ _) mvar root =
         time <- File.getTime path
         source <- File.readUtf8 path
         case Parse.fromByteString projectType source of
-          Right modul@(Src.Module _ _ _ imports values _ _ _ _) ->
+          Right modul@(Src.Module _ _ _ imports values _ _ _ _ _) ->
             do
               let deps = map Src.getImportName imports
               let local = Details.Local path time deps (any (isMain . snd) values) buildID buildID
@@ -976,7 +976,7 @@ checkRoot env@(Env _ root _ _ _ _ _ _) results rootStatus =
       return (RInside name)
     SOutsideErr err ->
       return (ROutsideErr err)
-    SOutsideOk local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
+    SOutsideOk local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _ _) ->
       do
         depsStatus <- checkDeps root results deps lastCompile
         case depsStatus of

builder/src/Gren/Details.hs

@@ -486,7 +486,7 @@ crawlFile foreignDeps mvar pkg src docsStatus expectedName path =
   do
     bytes <- File.readUtf8 path
     case Parse.fromByteString (Parse.Package pkg) bytes of
-      Right modul@(Src.Module (Just (A.At _ actualName)) _ _ imports _ _ _ _ _) | expectedName == actualName ->
+      Right modul@(Src.Module (Just (A.At _ actualName)) _ _ imports _ _ _ _ _ _) | expectedName == actualName ->
         do
           deps <- crawlImports foreignDeps mvar pkg src imports
           return (Just (SLocal docsStatus deps modul))

compiler/src/AST/Source.hs

@@ -34,24 +34,16 @@ module AST.Source
   )
 where
 
+import AST.SourceComments (Comment, GREN_COMMENT)
+import AST.SourceComments qualified as SC
 import AST.Utils.Binop qualified as Binop
 import Data.Name (Name)
 import Data.Name qualified as Name
-import Data.Utf8 qualified as Utf8
 import Gren.Float qualified as EF
 import Gren.String qualified as ES
 import Parse.Primitives qualified as P
 import Reporting.Annotation qualified as A
 
--- COMMENTS
-
-data Comment
-  = BlockComment (Utf8.Utf8 GREN_COMMENT)
-  | LineComment (Utf8.Utf8 GREN_COMMENT)
-  deriving (Show)
-
-data GREN_COMMENT
-
 -- EXPRESSIONS
 
 type Expr = A.Located Expr_
@@ -76,6 +68,7 @@ data Expr_
   | Access Expr (A.Located Name)
   | Update Expr [(A.Located Name, Expr)]
   | Record [(A.Located Name, Expr)]
+  | Parens [Comment] Expr [Comment]
   deriving (Show)
 
 data VarType = LowVar | CapVar
@@ -136,12 +129,13 @@ data Module = Module
     _unions :: [(SourceOrder, A.Located Union)],
     _aliases :: [(SourceOrder, A.Located Alias)],
     _binops :: [A.Located Infix],
+    _headerComments :: SC.HeaderComments,
     _effects :: Effects
   }
   deriving (Show)
 
 getName :: Module -> Name
-getName (Module maybeName _ _ _ _ _ _ _ _) =
+getName (Module maybeName _ _ _ _ _ _ _ _ _) =
   case maybeName of
     Just (A.At _ name) ->
       name
@@ -176,14 +170,14 @@ data Port = Port (A.Located Name) Type
 
 data Effects
   = NoEffects
-  | Ports [(SourceOrder, Port)]
-  | Manager A.Region Manager
+  | Ports [(SourceOrder, Port)] SC.PortsComments
+  | Manager A.Region Manager SC.ManagerComments
   deriving (Show)
 
 data Manager
-  = Cmd (A.Located Name)
-  | Sub (A.Located Name)
-  | Fx (A.Located Name) (A.Located Name)
+  = Cmd (A.Located Name) SC.CmdComments
+  | Sub (A.Located Name) SC.SubComments
+  | Fx (A.Located Name) (A.Located Name) SC.FxComments
   deriving (Show)
 
 data Docs

compiler/src/AST/SourceComments.hs

@@ -0,0 +1,56 @@
+module AST.SourceComments where
+
+import Data.Utf8 qualified as Utf8
+
+data GREN_COMMENT
+
+data Comment
+  = BlockComment (Utf8.Utf8 GREN_COMMENT)
+  | LineComment (Utf8.Utf8 GREN_COMMENT)
+  deriving (Show)
+
+-- Module
+
+data HeaderComments = HeaderComments
+  { _beforeModuleLine :: [Comment],
+    _afterModuleKeyword :: [Comment],
+    _afterModuleName :: [Comment],
+    _afterExposingKeyword :: [Comment],
+    _afterModuleLine :: [Comment],
+    _afterModuleDocComment :: [Comment]
+  }
+  deriving (Show)
+
+-- Effects
+
+data PortsComments = PortsComments
+  { _afterPortKeyword :: [Comment]
+  }
+  deriving (Show)
+
+data ManagerComments = ManagerComments
+  { _afterEffectKeyword :: [Comment],
+    _afterWhereKeyword :: [Comment],
+    _afterManager :: [Comment]
+  }
+  deriving (Show)
+
+-- Manager
+
+data CmdComments = CmdComments
+  { _beforeCommandKeyword :: [Comment],
+    _afterCommand :: [Comment]
+  }
+  deriving (Show)
+
+data SubComments = SubComments
+  { _beforeSubscriptionsKeyword :: [Comment],
+    _afterSubscriptions :: [Comment]
+  }
+  deriving (Show)
+
+data FxComments = FxComments
+  { _cmdComments :: CmdComments,
+    _subComments :: SubComments
+  }
+  deriving (Show)

compiler/src/Canonicalize/Effects.hs

@@ -37,26 +37,26 @@ canonicalize env values unions effects =
   case effects of
     Src.NoEffects ->
       Result.ok Can.NoEffects
-    Src.Ports ports ->
+    Src.Ports ports _ ->
       do
         pairs <- traverse (canonicalizePort env) (fmap snd ports)
         return $ Can.Ports (Map.fromList pairs)
-    Src.Manager region manager ->
+    Src.Manager region manager _ ->
       let dict = Map.fromList (map toNameRegion values)
        in Can.Manager
             <$> verifyManager region dict "init"
             <*> verifyManager region dict "onEffects"
             <*> verifyManager region dict "onSelfMsg"
             <*> case manager of
-              Src.Cmd cmdType ->
+              Src.Cmd cmdType _ ->
                 Can.Cmd
                   <$> verifyEffectType cmdType unions
                   <* verifyManager region dict "cmdMap"
-              Src.Sub subType ->
+              Src.Sub subType _ ->
                 Can.Sub
                   <$> verifyEffectType subType unions
                   <* verifyManager region dict "subMap"
-              Src.Fx cmdType subType ->
+              Src.Fx cmdType subType _ ->
                 Can.Fx
                   <$> verifyEffectType cmdType unions
                   <*> verifyEffectType subType unions

compiler/src/Canonicalize/Environment/Local.hs

@@ -46,7 +46,7 @@ addVars module_ (Env.Env home vs ts cs bs qvs qts qcs) =
     Result.ok $ Env.Env home vs2 ts cs bs qvs qts qcs
 
 collectVars :: Src.Module -> Result i w (Map.Map Name.Name Env.Var)
-collectVars (Src.Module _ _ _ _ values _ _ _ effects) =
+collectVars (Src.Module _ _ _ _ values _ _ _ _ effects) =
   let addDecl dict (A.At _ (Src.Value (A.At region name) _ _ _)) =
         Dups.insert name region (Env.TopLevel region) dict
    in Dups.detect Error.DuplicateDecl $
@@ -57,17 +57,17 @@ toEffectDups effects =
   case effects of
     Src.NoEffects ->
       Dups.none
-    Src.Ports ports ->
+    Src.Ports ports _ ->
       let addPort dict (Src.Port (A.At region name) _) =
             Dups.insert name region (Env.TopLevel region) dict
        in List.foldl' addPort Dups.none (fmap snd ports)
-    Src.Manager _ manager ->
+    Src.Manager _ manager _ ->
       case manager of
-        Src.Cmd (A.At region _) ->
+        Src.Cmd (A.At region _) _ ->
           Dups.one "command" region (Env.TopLevel region)
-        Src.Sub (A.At region _) ->
+        Src.Sub (A.At region _) _ ->
           Dups.one "subscription" region (Env.TopLevel region)
-        Src.Fx (A.At regionCmd _) (A.At regionSub _) ->
+        Src.Fx (A.At regionCmd _) (A.At regionSub _) _ ->
           Dups.union
             (Dups.one "command" regionCmd (Env.TopLevel regionCmd))
             (Dups.one "subscription" regionSub (Env.TopLevel regionSub))
@@ -75,7 +75,7 @@ toEffectDups effects =
 -- ADD TYPES
 
 addTypes :: Src.Module -> Env.Env -> Result i w Env.Env
-addTypes (Src.Module _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs qts qcs) =
+addTypes (Src.Module _ _ _ _ _ unions aliases _ _ _) (Env.Env home vs ts cs bs qvs qts qcs) =
   let addAliasDups dups (A.At _ (Src.Alias (A.At region name) _ _)) = Dups.insert name region () dups
       addUnionDups dups (A.At _ (Src.Union (A.At region name) _ _)) = Dups.insert name region () dups
       typeNameDups =
@@ -199,7 +199,7 @@ addFreeVars freeVars (A.At region tipe) =
 -- ADD CTORS
 
 addCtors :: Src.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)
-addCtors (Src.Module _ _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs qvs qts qcs) =
+addCtors (Src.Module _ _ _ _ _ unions aliases _ _ _) env@(Env.Env home vs ts cs bs qvs qts qcs) =
   do
     unionInfo <- traverse (canonicalizeUnion env) (fmap snd unions)
     aliasInfo <- traverse (canonicalizeAlias env) (fmap snd aliases)

compiler/src/Canonicalize/Expression.hs

@@ -120,6 +120,8 @@ canonicalize env (A.At region expression) =
         do
           fieldDict <- Dups.checkFields fields
           Can.Record <$> traverse (canonicalize env) fieldDict
+      Src.Parens _ expr _ ->
+        A.toValue <$> (canonicalize env expr)
 
 -- CANONICALIZE IF BRANCH
 

compiler/src/Canonicalize/Module.hs

@@ -35,7 +35,7 @@ type Result i w a =
 -- MODULES
 
 canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Result i [W.Warning] Can.Module
-canonicalize pkg ifaces modul@(Src.Module _ exports docs imports valuesWithSourceOrder _ _ binops effects) =
+canonicalize pkg ifaces modul@(Src.Module _ exports docs imports valuesWithSourceOrder _ _ binops _ effects) =
   do
     let values = fmap snd valuesWithSourceOrder
     let home = ModuleName.Canonical pkg (Src.getName modul)

compiler/src/Gren/Format.hs

@@ -1,11 +1,13 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -Werror=incomplete-patterns #-}
 {-# OPTIONS_GHC -Wno-error=unused-matches #-}
 
 module Gren.Format (toByteStringBuilder) where
 
 import AST.Source qualified as Src
+import AST.SourceComments qualified as SC
 import AST.Utils.Binop qualified as Binop
 import Control.Monad (join)
 import Data.Bifunctor (second)
@@ -126,23 +128,47 @@ extendedGroup open baseSep sep fieldSep close base fields =
           value
         ]
 
+withCommentsBefore :: [Src.Comment] -> Block -> Block
+withCommentsBefore [] block = block
+withCommentsBefore (first : rest) block =
+  spaceOrStack
+    [ spaceOrStack $ fmap formatComment (first :| rest),
+      block
+    ]
+
 --
 -- AST -> Block
 --
+
+formatComment :: Src.Comment -> Block
+formatComment = \case
+  Src.BlockComment text ->
+    let open = if Utf8.startsWithChar (== ' ') text then "{-" else "{- "
+        close = if Utf8.endsWithWord8 0x20 {- space -} text then "-}" else " -}"
+     in Block.line $ Block.string7 open <> utf8 text <> Block.string7 close
+  Src.LineComment text ->
+    let open = if Utf8.startsWithChar (== ' ') text then "--" else "-- "
+     in Block.mustBreak $ Block.string7 open <> utf8 text
+
+formatCommentBlock :: [Src.Comment] -> Maybe Block
+formatCommentBlock = fmap spaceOrStack . nonEmpty . fmap formatComment
+
 formatModule :: Src.Module -> Block
-formatModule (Src.Module moduleName exports docs imports values unions aliases binops effects) =
-  -- TODO: implement actual formating
+formatModule (Src.Module moduleName exports docs imports values unions aliases binops comments effects) =
   Block.stack $
     NonEmpty.fromList $
       catMaybes
-        [ Just $
+        [ formatCommentBlock commentsBeforeLine,
+          Just $
             spaceOrIndent $
               NonEmpty.fromList $
                 catMaybes
                   [ Just $ Block.line $ Block.string7 moduleKeyword,
+                    formatCommentBlock commentsAfterKeyword,
                     Just $ Block.line $ maybe (Block.string7 "Main") (utf8 . A.toValue) moduleName,
+                    formatCommentBlock commentsAfterName,
                     formatEffectsModuleWhereClause effects,
-                    formatExposing $ A.toValue exports
+                    formatExposing commentsAfterExposingKeyword (A.toValue exports)
                   ],
           case docs of
             Src.NoDocs _ -> Nothing
@@ -152,6 +178,7 @@ formatModule (Src.Module moduleName exports docs imports values unions aliases b
                   [ Block.blankLine,
                     formatDocComment moduleDocs
                   ],
+          formatCommentBlock (commentsAfterLine <> commentsAfterDocComment),
           Just $ Block.stack $ Block.blankLine :| fmap formatImport imports,
           infixDefs,
           let defs =
@@ -163,17 +190,19 @@ formatModule (Src.Module moduleName exports docs imports values unions aliases b
                         fmap (formatWithDocComment aliasName formatAlias . A.toValue) <$> aliases,
                         case effects of
                           Src.NoEffects -> []
-                          Src.Ports ports -> fmap (formatWithDocComment portName formatPort) <$> ports
-                          Src.Manager _ _ -> []
+                          Src.Ports ports _ -> fmap (formatWithDocComment portName formatPort) <$> ports
+                          Src.Manager _ _ _ -> []
                       ]
            in fmap Block.stack $ nonEmpty $ fmap (addBlankLines 2) defs
         ]
   where
+    (SC.HeaderComments commentsBeforeLine commentsAfterKeyword commentsAfterName commentsAfterExposingKeyword commentsAfterLine commentsAfterDocComment) = comments
+
     moduleKeyword =
       case effects of
         Src.NoEffects -> "module"
-        Src.Ports _ -> "port module"
-        Src.Manager _ _ -> "effect module"
+        Src.Ports _ (SC.PortsComments afterPortKeyword) -> "port module"
+        Src.Manager _ _ (SC.ManagerComments afterEffectKeyword _ _) -> "effect module"
 
     defDocs :: Map Name Src.DocComment
     defDocs =
@@ -209,8 +238,9 @@ formatModule (Src.Module moduleName exports docs imports values unions aliases b
 formatEffectsModuleWhereClause :: Src.Effects -> Maybe Block
 formatEffectsModuleWhereClause = \case
   Src.NoEffects -> Nothing
-  Src.Ports _ -> Nothing
-  Src.Manager _ manager -> Just $ formatManager manager
+  Src.Ports _ _ -> Nothing
+  Src.Manager _ manager (SC.ManagerComments _ afterWhereKeyword afterManager) ->
+    Just $ formatManager manager
 
 formatManager :: Src.Manager -> Block
 formatManager manager =
@@ -219,33 +249,48 @@ formatManager manager =
       group '{' ',' '}' False $
         fmap (formatPair . second A.toValue) $
           case manager of
-            Src.Cmd cmd ->
-              [("command", cmd)]
-            Src.Sub sub ->
-              [("subscription", sub)]
-            Src.Fx cmd sub ->
-              [ ("command", cmd),
-                ("subscription", sub)
+            Src.Cmd cmd (SC.CmdComments comments1 comments2) ->
+              [(comments1 ++ comments2, "command", cmd)]
+            Src.Sub sub (SC.SubComments comments1 comments2) ->
+              [(comments1 ++ comments2, "subscription", sub)]
+            Src.Fx cmd sub (SC.FxComments (SC.CmdComments commentsCmd1 commentsCmd2) (SC.SubComments commentsSub1 commentsSub2)) ->
+              [ (commentsCmd1 ++ commentsCmd2, "command", cmd),
+                (commentsSub1 ++ commentsSub2, "subscription", sub)
               ]
     ]
   where
-    formatPair (key, name) =
-      Block.line $
-        sconcat
-          [ Block.string7 key,
-            Block.string7 " = ",
-            utf8 name
-          ]
+    formatPair (comments, key, name) =
+      spaceOrStack $
+        NonEmpty.prependList
+          (fmap formatComment comments)
+          ( NonEmpty.singleton $
+              Block.line $
+                sconcat
+                  [ Block.string7 key,
+                    Block.string7 " = ",
+                    utf8 name
+                  ]
+          )
 
-formatExposing :: Src.Exposing -> Maybe Block
-formatExposing = \case
-  Src.Open -> Just $ Block.line $ Block.string7 "exposing (..)"
-  Src.Explicit [] -> Nothing
+formatExposing :: [Src.Comment] -> Src.Exposing -> Maybe Block
+formatExposing commentsAfterKeyword = \case
+  Src.Open ->
+    Just $
+      spaceOrIndent
+        [ Block.line $ Block.string7 "exposing",
+          withCommentsBefore commentsAfterKeyword $
+            Block.line $
+              Block.string7 "(..)"
+        ]
+  Src.Explicit [] ->
+    formatCommentBlock commentsAfterKeyword
   Src.Explicit exposed ->
     Just $
       spaceOrIndent
         [ Block.line $ Block.string7 "exposing",
-          group '(' ',' ')' False $ fmap formatExposed exposed
+          withCommentsBefore commentsAfterKeyword $
+            group '(' ',' ')' False $
+              fmap formatExposed exposed
         ]
 
 formatExposed :: Src.Exposed -> Block
@@ -262,7 +307,7 @@ formatImport (Src.Import name alias exposing) =
         [ Just $ Block.line $ Block.string7 "import",
           Just $ Block.line $ utf8 $ A.toValue name,
           fmap formatImportAlias alias,
-          formatExposing exposing
+          formatExposing [] exposing
         ]
 
 formatImportAlias :: Name -> Block
@@ -558,6 +603,18 @@ formatExpr = \case
           [ Block.line $ utf8 (A.toValue name) <> Block.space <> Block.char7 '=',
             exprParensNone $ formatExpr (A.toValue expr)
           ]
+  Src.Parens [] expr [] ->
+    formatExpr $ A.toValue expr
+  Src.Parens commentsBefore expr commentsAfter ->
+    NoExpressionParens $
+      parens $
+        spaceOrStack $
+          NonEmpty.fromList $
+            catMaybes
+              [ formatCommentBlock commentsBefore,
+                Just $ exprParensNone $ formatExpr (A.toValue expr),
+                formatCommentBlock commentsAfter
+              ]
 
 opForcesMultiline :: Name -> Bool
 opForcesMultiline op =

compiler/src/Parse/Expression.hs

@@ -66,7 +66,7 @@ parenthesizedExpr :: A.Position -> Parser E.Expr Src.Expr
 parenthesizedExpr start@(A.Position row col) =
   inContext E.Parenthesized (word1 0x28 {-(-} E.Start) $
     do
-      Space.chompAndCheckIndent E.ParenthesizedSpace E.ParenthesizedIndentOpen
+      comments1 <- Space.chompAndCheckIndent E.ParenthesizedSpace E.ParenthesizedIndentOpen
       oneOf
         E.ParenthesizedOpen
         [ do
@@ -79,17 +79,17 @@ parenthesizedExpr start@(A.Position row col) =
                       word1 0x29 {-)-} E.ParenthesizedOperatorClose
                       addEnd start (Src.Op op),
                     do
-                      (expr, end) <-
+                      (comments2, (expr, end)) <-
                         specialize E.ParenthesizedExpr $
                           do
                             negatedExpr@(A.At (A.Region _ end) _) <- term
-                            Space.chomp E.Space
+                            comments2_ <- Space.chomp E.Space
                             let exprStart = A.Position row (col + 2)
                             let expr = A.at exprStart end (Src.Negate negatedExpr)
-                            chompExprEnd exprStart (State [] expr [] end)
+                            (,) comments2_ <$> chompExprEnd exprStart (State [] expr [] end)
                       Space.checkIndent end E.ParenthesizedIndentEnd
                       word1 0x29 {-)-} E.ParenthesizedOperatorClose
-                      return expr
+                      addEnd start (Src.Parens comments1 expr comments2)
                   ]
               else do
                 word1 0x29 {-)-} E.ParenthesizedOperatorClose
@@ -97,7 +97,7 @@ parenthesizedExpr start@(A.Position row col) =
           do
             (expr, _) <- specialize E.ParenthesizedExpr expression
             word1 0x29 {-)-} E.ParenthesizedEnd
-            return expr
+            addEnd start (Src.Parens comments1 expr [])
         ]
 
 accessor :: A.Position -> Parser E.Expr Src.Expr

compiler/src/Parse/Module.hs

@@ -14,6 +14,7 @@ module Parse.Module
 where
 
 import AST.Source qualified as Src
+import AST.SourceComments qualified as SC
 import Data.ByteString qualified as BS
 import Data.Name qualified as Name
 import Gren.Compiler.Imports qualified as Imports
@@ -78,15 +79,16 @@ checkModule :: ProjectType -> Module -> Either E.Error Src.Module
 checkModule projectType (Module maybeHeader imports infixes decls) =
   let (values, unions, aliases, ports) = categorizeDecls [] [] [] [] 0 decls
    in case maybeHeader of
-        Just (Header name effects exports docs) ->
-          Src.Module (Just name) exports (toDocs docs decls) imports values unions aliases infixes
+        Just (Header name effects exports docs comments) ->
+          Src.Module (Just name) exports (toDocs docs decls) imports values unions aliases infixes comments
             <$> checkEffects projectType ports effects
         Nothing ->
-          Right $
-            Src.Module Nothing (A.At A.one Src.Open) (Src.NoDocs A.one) imports values unions aliases infixes $
-              case ports of
-                [] -> Src.NoEffects
-                _ : _ -> Src.Ports ports
+          let comments = SC.HeaderComments [] [] [] [] [] []
+           in Right $
+                Src.Module Nothing (A.At A.one Src.Open) (Src.NoDocs A.one) imports values unions aliases infixes comments $
+                  case ports of
+                    [] -> Src.NoEffects
+                    _ : _ -> Src.Ports ports (SC.PortsComments [])
 
 checkEffects :: ProjectType -> [(Src.SourceOrder, Src.Port)] -> Effects -> Either E.Error Src.Effects
 checkEffects projectType ports effects =
@@ -99,18 +101,18 @@ checkEffects projectType ports effects =
           case projectType of
             Package _ -> Left (E.NoPortsInPackage name)
             Application -> Left (E.UnexpectedPort region)
-    Ports region ->
+    Ports region comments ->
       case projectType of
         Package _ ->
           Left (E.NoPortModulesInPackage region)
         Application ->
           case ports of
             [] -> Left (E.NoPorts region)
-            _ : _ -> Right (Src.Ports ports)
-    Manager region manager ->
+            _ : _ -> Right (Src.Ports ports comments)
+    Manager region manager comments ->
       if isKernel projectType
         then case ports of
-          [] -> Right (Src.Manager region manager)
+          [] -> Right (Src.Manager region manager comments)
           _ : _ -> Left (E.UnexpectedPort region)
         else Left (E.NoEffectsOutsideKernel region)
 
@@ -198,131 +200,149 @@ chompInfixes infixes =
 
 -- MODULE DOC COMMENT
 
-chompModuleDocCommentSpace :: Parser E.Module (Either A.Region Src.DocComment)
+chompModuleDocCommentSpace :: Parser E.Module ([Src.Comment], (Either A.Region Src.DocComment), [Src.Comment])
 chompModuleDocCommentSpace =
   do
-    (A.At region comments) <- addLocation (freshLine E.FreshLine)
+    (A.At region preComments) <- addLocation (freshLine E.FreshLine)
     oneOfWithFallback
       [ do
           docComment <- Space.docComment E.ImportStart E.ModuleSpace
-          Space.chomp E.ModuleSpace
+          postComments <- Space.chomp E.ModuleSpace
           Space.checkFreshLine E.FreshLine
-          return (Right docComment)
+          return (preComments, (Right docComment), postComments)
       ]
-      (Left region)
+      (preComments, (Left region), [])
 
 -- HEADER
 
 data Header
-  = Header (A.Located Name.Name) Effects (A.Located Src.Exposing) (Either A.Region Src.DocComment)
+  = Header
+      (A.Located Name.Name)
+      Effects
+      (A.Located Src.Exposing)
+      (Either A.Region Src.DocComment)
+      SC.HeaderComments
 
 data Effects
   = NoEffects A.Region
-  | Ports A.Region
-  | Manager A.Region Src.Manager
+  | Ports A.Region SC.PortsComments
+  | Manager A.Region Src.Manager SC.ManagerComments
 
 chompHeader :: Parser E.Module (Maybe Header)
 chompHeader =
   do
-    freshLine E.FreshLine
+    commentsBeforeModuleLine <- freshLine E.FreshLine
     start <- getPosition
     oneOfWithFallback
       [ -- module MyThing exposing (..)
         do
           Keyword.module_ E.ModuleProblem
           effectEnd <- getPosition
-          Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem
+          commentsAfterModuleKeyword <- Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem
           name <- addLocation (Var.moduleName E.ModuleName)
-          Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem
+          commentsAfterModuleName <- Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem
           Keyword.exposing_ E.ModuleProblem
-          Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem
+          commentsAfterExposingKeyword <- Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem
           exports <- addLocation (specialize E.ModuleExposing exposing)
-          comment <- chompModuleDocCommentSpace
+          (commentsBeforeDocComment, docComment, commentsAfterDocComment) <- chompModuleDocCommentSpace
+          let comments = SC.HeaderComments commentsBeforeModuleLine commentsAfterModuleKeyword commentsAfterModuleName commentsAfterExposingKeyword commentsBeforeDocComment commentsAfterDocComment
           return $
             Just $
-              Header name (NoEffects (A.Region start effectEnd)) exports comment,
+              Header name (NoEffects (A.Region start effectEnd)) exports docComment comments,
         -- port module MyThing exposing (..)
         do
           Keyword.port_ E.PortModuleProblem
-          Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
+          commentsAfterPortKeyword <- Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
           Keyword.module_ E.PortModuleProblem
           effectEnd <- getPosition
-          Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
+          commentsAfterModuleKeyword <- Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
           name <- addLocation (Var.moduleName E.PortModuleName)
-          Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
+          commentsAfterModuleName <- Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
           Keyword.exposing_ E.PortModuleProblem
-          Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
+          commentsAfterExposingKeyword <- Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
           exports <- addLocation (specialize E.PortModuleExposing exposing)
-          comment <- chompModuleDocCommentSpace
+          (commentsBeforeDocComment, docComment, commentsAfterDocComment) <- chompModuleDocCommentSpace
+          let comments = SC.HeaderComments commentsBeforeModuleLine commentsAfterModuleKeyword commentsAfterModuleName commentsAfterExposingKeyword commentsBeforeDocComment commentsAfterDocComment
+          let portsComments = SC.PortsComments commentsAfterPortKeyword
           return $
             Just $
-              Header name (Ports (A.Region start effectEnd)) exports comment,
+              Header name (Ports (A.Region start effectEnd) portsComments) exports docComment comments,
         -- effect module MyThing where { command = MyCmd } exposing (..)
         do
           Keyword.effect_ E.Effect
-          Space.chompAndCheckIndent E.ModuleSpace E.Effect
+          commentsAfterEffectKeyword <- Space.chompAndCheckIndent E.ModuleSpace E.Effect
           Keyword.module_ E.Effect
           effectEnd <- getPosition
-          Space.chompAndCheckIndent E.ModuleSpace E.Effect
+          commentsAfterModuleKeyword <- Space.chompAndCheckIndent E.ModuleSpace E.Effect
           name <- addLocation (Var.moduleName E.ModuleName)
-          Space.chompAndCheckIndent E.ModuleSpace E.Effect
+          commentsAfterModuleName <- Space.chompAndCheckIndent E.ModuleSpace E.Effect
           Keyword.where_ E.Effect
-          Space.chompAndCheckIndent E.ModuleSpace E.Effect
-          manager <- chompManager
-          Space.chompAndCheckIndent E.ModuleSpace E.Effect
+          commentsAfterWhereKeyword <- Space.chompAndCheckIndent E.ModuleSpace E.Effect
+          (manager, commentsAfterManager1) <- chompManager
+          commentsAfterManager2 <- Space.chompAndCheckIndent E.ModuleSpace E.Effect
           Keyword.exposing_ E.Effect
-          Space.chompAndCheckIndent E.ModuleSpace E.Effect
+          commentsAfterExposingKeyword <- Space.chompAndCheckIndent E.ModuleSpace E.Effect
           exports <- addLocation (specialize (const E.Effect) exposing)
-          comment <- chompModuleDocCommentSpace
+          (commentsBeforeDocComment, docComment, commentsAfterDocComment) <- chompModuleDocCommentSpace
+          let comments = SC.HeaderComments commentsBeforeModuleLine commentsAfterModuleKeyword commentsAfterModuleName commentsAfterExposingKeyword commentsBeforeDocComment commentsAfterDocComment
+          let managerComments = SC.ManagerComments commentsAfterEffectKeyword commentsAfterWhereKeyword (commentsAfterManager1 <> commentsAfterManager2)
           return $
             Just $
-              Header name (Manager (A.Region start effectEnd) manager) exports comment
+              Header name (Manager (A.Region start effectEnd) manager managerComments) exports docComment comments
       ]
       -- default header
       Nothing
 
-chompManager :: Parser E.Module Src.Manager
+chompManager :: Parser E.Module (Src.Manager, [Src.Comment])
 chompManager =
   do
     word1 0x7B {- { -} E.Effect
-    spaces_em
+    commentsAfterOpenBrace <- spaces_em
     oneOf
       E.Effect
       [ do
           cmd <- chompCommand
-          spaces_em
+          commentsAfterCmd <- spaces_em
           oneOf
             E.Effect
             [ do
                 word1 0x7D {-}-} E.Effect
-                spaces_em
-                return (Src.Cmd cmd),
+                commentsAfterCloseBrace <- spaces_em
+                let comments = SC.CmdComments commentsAfterOpenBrace commentsAfterCmd
+                return (Src.Cmd cmd comments, commentsAfterCloseBrace),
               do
                 word1 0x2C {-,-} E.Effect
-                spaces_em
+                commentsAfterComma <- spaces_em
                 sub <- chompSubscription
-                spaces_em
+                commentsAfterSub <- spaces_em
                 word1 0x7D {-}-} E.Effect
-                spaces_em
-                return (Src.Fx cmd sub)
+                commentsAfterCloseBrace <- spaces_em
+                let cmdComments = SC.CmdComments commentsAfterOpenBrace commentsAfterCmd
+                let subComments = SC.SubComments commentsAfterComma commentsAfterSub
+                let comments = SC.FxComments cmdComments subComments
+                return (Src.Fx cmd sub comments, commentsAfterCloseBrace)
             ],
         do
           sub <- chompSubscription
-          spaces_em
+          commentsAfterSub <- spaces_em
           oneOf
             E.Effect
             [ do
                 word1 0x7D {-}-} E.Effect
-                spaces_em
-                return (Src.Sub sub),
+                commentsAfterCloseBrace <- spaces_em
+                let comments = SC.SubComments commentsAfterOpenBrace commentsAfterSub
+                return (Src.Sub sub comments, commentsAfterCloseBrace),
               do
                 word1 0x2C {-,-} E.Effect
-                spaces_em
+                commentsAfterComma <- spaces_em
                 cmd <- chompCommand
-                spaces_em
+                commentsAfterCmd <- spaces_em
                 word1 0x7D {-}-} E.Effect
-                spaces_em
-                return (Src.Fx cmd sub)
+                commentsAfterCloseBrace <- spaces_em
+                let subComments = SC.SubComments commentsAfterOpenBrace commentsAfterSub
+                let cmdComments = SC.CmdComments commentsAfterComma commentsAfterCmd
+                let comments = SC.FxComments cmdComments subComments
+                return (Src.Fx cmd sub comments, commentsAfterCloseBrace)
             ]
       ]
 

compiler/src/Reporting/Error/Syntax.hs

@@ -70,6 +70,7 @@ data Error
   | NoPortModulesInPackage A.Region
   | NoEffectsOutsideKernel A.Region
   | ParseError Module
+  deriving (Show)
 
 -- MODULE
 
@@ -104,6 +105,7 @@ data Module
     Infix Row Col
   | --
     Declarations Decl Row Col
+  deriving (Show)
 
 data Exposing
   = ExposingSpace Space Row Col
@@ -117,6 +119,7 @@ data Exposing
   | --
     ExposingIndentEnd Row Col
   | ExposingIndentValue Row Col
+  deriving (Show)
 
 -- DECLARATIONS
 
@@ -129,6 +132,7 @@ data Decl
   | DeclDef Name.Name DeclDef Row Col
   | --
     DeclFreshLineAfterDocComment Row Col
+  deriving (Show)
 
 data DeclDef
   = DeclDefSpace Space Row Col
@@ -142,6 +146,7 @@ data DeclDef
     DeclDefIndentType Row Col
   | DeclDefIndentEquals Row Col
   | DeclDefIndentBody Row Col
+  deriving (Show)
 
 data Port
   = PortSpace Space Row Col
@@ -151,6 +156,7 @@ data Port
   | PortIndentName Row Col
   | PortIndentColon Row Col
   | PortIndentType Row Col
+  deriving (Show)
 
 -- TYPE DECLARATIONS
 
@@ -161,6 +167,7 @@ data DeclType
   | DT_Union CustomType Row Col
   | --
     DT_IndentName Row Col
+  deriving (Show)
 
 data TypeAlias
   = AliasSpace Space Row Col
@@ -170,6 +177,7 @@ data TypeAlias
   | --
     AliasIndentEquals Row Col
   | AliasIndentBody Row Col
+  deriving (Show)
 
 data CustomType
   = CT_Space Space Row Col
@@ -183,6 +191,7 @@ data CustomType
   | CT_IndentBar Row Col
   | CT_IndentAfterBar Row Col
   | CT_IndentAfterEquals Row Col
+  deriving (Show)
 
 -- EXPRESSIONS
 

compiler/src/Reporting/Render/Type/Localizer.hs

@@ -66,7 +66,7 @@ fromNames names =
 -- FROM MODULE
 
 fromModule :: Src.Module -> Localizer
-fromModule modul@(Src.Module _ _ _ imports _ _ _ _ _) =
+fromModule modul@(Src.Module _ _ _ imports _ _ _ _ _ _) =
   Localizer $
     Map.fromList $
       (Src.getName modul, Import Nothing All) : map toPair imports

gren.cabal

@@ -128,6 +128,7 @@ Common gren-common
         AST.Canonical
         AST.Optimized
         AST.Source
+        AST.SourceComments
         AST.Utils.Binop
         AST.Utils.Type
         Canonicalize.Effects
@@ -249,8 +250,9 @@ Test-Suite gren-tests
         Helpers.Parse
 
         -- tests
-        Parse.SpaceSpec
+        Integration.FormatSpec
         Parse.RecordUpdateSpec
+        Parse.SpaceSpec
         Parse.UnderscorePatternSpec
 
     Build-Depends:

terminal/src/Format.hs

@@ -3,6 +3,7 @@
 module Format
   ( Flags (..),
     run,
+    formatByteString,
   )
 where
 

tests/Integration/FormatSpec.hs

@@ -0,0 +1,145 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Integration tests for formatting that cover both the parsing and formatting
+-- (tests go from text to text).
+module Integration.FormatSpec where
+
+import Data.ByteString.Builder qualified as Builder
+import Data.Text (Text)
+import Data.Text qualified as Text
+import Data.Text.Encoding qualified as TE
+import Data.Text.Lazy qualified as LazyText
+import Data.Text.Lazy.Encoding qualified as LTE
+import Format qualified
+import Test.Hspec
+
+spec :: Spec
+spec = do
+  describe "module header" $ do
+    let formattedModuleBody = "\n\n\nf =\n    {}"
+    describe "normal module" $
+      do
+        it "formats already formatted" $
+          assertFormatted
+            [ "module Normal exposing (..)",
+              formattedModuleBody
+            ]
+        it "formats" $
+          [ "module ",
+            " Normal ",
+            " exposing ",
+            " ( ",
+            " .. ",
+            " )  ",
+            "  ",
+            "",
+            formattedModuleBody
+          ]
+            `shouldFormatAs` [ "module Normal exposing (..)",
+                               formattedModuleBody
+                             ]
+        it "formats with comments" $
+          [ "{-A-}",
+            "module{-B-}Normal{-C-}exposing{-D-}({-E-}..{-F-}){-G-}",
+            "{-H-}",
+            formattedModuleBody
+          ]
+            `shouldFormatAs` [ "{- A -}",
+                               "module {- B -} Normal {- C -} exposing {- D -} (..)",
+                               "{- G -} {- H -}",
+                               formattedModuleBody
+                             ]
+
+  describe "top-level definition" $ do
+    it "formats already formatted" $
+      assertFormattedModuleBody
+        [ "f x =",
+          "    {}"
+        ]
+    it "formats" $
+      ["f = {}"]
+        `shouldFormatModuleBodyAs` [ "f =",
+                                     "    {}"
+                                   ]
+  describe "expressions" $ do
+    describe "record" $ do
+      describe "empty" $ do
+        it "formats already formatted" $
+          assertFormattedExpression
+            ["{}"]
+        it "formats" $
+          [ "{",
+            " }"
+          ]
+            `shouldFormatExpressionAs` ["{}"]
+      it "formats with fields" $
+        ["{a=1,   b = 2}"]
+          `shouldFormatExpressionAs` [ "{ a = 1",
+                                       ", b = 2",
+                                       "}"
+                                     ]
+  describe "parentheses" $ do
+    it "removes unnecessary parentheses" $
+      ["(a)"]
+        `shouldFormatExpressionAs` ["a"]
+    describe "retains necessary parentheses" $ do
+      it "protects nested function application" $
+        assertFormattedExpression
+          ["f (g x)"]
+      it "retains parentheses used to group comments" $
+        assertFormattedExpression
+          ["({- A -} x)"]
+
+assertFormatted :: [Text] -> IO ()
+assertFormatted lines_ =
+  lines_ `shouldFormatAs` lines_
+
+shouldFormatAs :: [Text] -> [Text] -> IO ()
+shouldFormatAs inputLines expectedOutputLines =
+  let input = TE.encodeUtf8 $ Text.unlines inputLines
+      expectedOutput = LazyText.unlines $ fmap LazyText.fromStrict expectedOutputLines
+      actualOutput = LTE.decodeUtf8 . Builder.toLazyByteString <$> Format.formatByteString input
+   in case actualOutput of
+        Nothing ->
+          expectationFailure "shouldFormatAs: failed to format"
+        Just actualModuleBody ->
+          actualModuleBody `shouldBe` expectedOutput
+
+assertFormattedModuleBody :: [Text] -> IO ()
+assertFormattedModuleBody lines_ =
+  lines_ `shouldFormatModuleBodyAs` lines_
+
+shouldFormatModuleBodyAs :: [Text] -> [Text] -> IO ()
+shouldFormatModuleBodyAs inputLines expectedOutputLines =
+  let input = TE.encodeUtf8 $ Text.unlines inputLines
+      expectedOutput = LazyText.unlines $ fmap LazyText.fromStrict expectedOutputLines
+      actualOutput = LTE.decodeUtf8 . Builder.toLazyByteString <$> Format.formatByteString input
+   in case LazyText.stripPrefix "module Main exposing (..)\n\n\n\n" <$> actualOutput of
+        Nothing ->
+          expectationFailure "shouldFormatModuleBodyAs: failed to format"
+        Just Nothing ->
+          expectationFailure "shouldFormatModuleBodyAs: internal error: could not strip module header"
+        Just (Just actualModuleBody) ->
+          actualModuleBody `shouldBe` expectedOutput
+
+assertFormattedExpression :: [Text] -> IO ()
+assertFormattedExpression lines_ =
+  lines_ `shouldFormatExpressionAs` lines_
+
+shouldFormatExpressionAs :: [Text] -> [Text] -> IO ()
+shouldFormatExpressionAs inputLines expectedOutputLines =
+  let input = TE.encodeUtf8 $ "expr =\n" <> Text.unlines (fmap ("    " <>) inputLines)
+      expectedOutput = LazyText.unlines $ fmap LazyText.fromStrict expectedOutputLines
+      actualOutput = LTE.decodeUtf8 . Builder.toLazyByteString <$> Format.formatByteString input
+      cleanOutput i =
+        LazyText.stripPrefix "module Main exposing (..)\n\n\n\nexpr =\n" i
+          >>= (return . LazyText.lines)
+          >>= traverse (LazyText.stripPrefix "    ")
+          >>= (return . LazyText.unlines)
+   in case fmap cleanOutput actualOutput of
+        Nothing ->
+          expectationFailure "shouldFormatExpressionAs: failed to format"
+        Just Nothing ->
+          expectationFailure "shouldFormatExpressionAs: internal error: could clean output"
+        Just (Just actualExpression) ->
+          actualExpression `shouldBe` expectedOutput