Merge pull request #117 from avh4/format

Implement formatting logic (without comments/linebreak support)

builder/src/Build.hs

@@ -277,7 +277,7 @@ crawlFile env@(Env _ root projectType _ _ buildID _ _) mvar docsNeed expectedNam
             if expectedName == actualName
               then
                 let deps = map Src.getImportName imports
-                    local = Details.Local path time deps (any isMain values) lastChange buildID
+                    local = Details.Local path time deps (any (isMain . snd) values) lastChange buildID
                  in crawlDeps env mvar deps (SChanged local source modul docsNeed)
               else return $ SBadSyntax path time source (Syntax.ModuleNameMismatch expectedName name)
 
@@ -954,7 +954,7 @@ crawlRoot env@(Env _ _ projectType _ _ buildID _ _) mvar root =
           Right modul@(Src.Module _ _ _ imports values _ _ _ _) ->
             do
               let deps = map Src.getImportName imports
-              let local = Details.Local path time deps (any isMain values) buildID buildID
+              let local = Details.Local path time deps (any (isMain . snd) values) buildID buildID
               crawlDeps env mvar deps (SOutsideOk local source modul)
           Left syntaxError ->
             return $

compiler/src/AST/Source.hs

@@ -14,6 +14,7 @@ module AST.Source
     RecordFieldPattern_ (..),
     Type,
     Type_ (..),
+    SourceOrder,
     Module (..),
     getName,
     getImportName,
@@ -124,14 +125,16 @@ data Type_
 
 -- MODULE
 
+type SourceOrder = Int
+
 data Module = Module
   { _name :: Maybe (A.Located Name),
     _exports :: A.Located Exposing,
     _docs :: Docs,
     _imports :: [Import],
-    _values :: [A.Located Value],
-    _unions :: [A.Located Union],
-    _aliases :: [A.Located Alias],
+    _values :: [(SourceOrder, A.Located Value)],
+    _unions :: [(SourceOrder, A.Located Union)],
+    _aliases :: [(SourceOrder, A.Located Alias)],
     _binops :: [A.Located Infix],
     _effects :: Effects
   }
@@ -173,7 +176,7 @@ data Port = Port (A.Located Name) Type
 
 data Effects
   = NoEffects
-  | Ports [Port]
+  | Ports [(SourceOrder, Port)]
   | Manager A.Region Manager
   deriving (Show)
 

compiler/src/Canonicalize/Effects.hs

@@ -39,7 +39,7 @@ canonicalize env values unions effects =
       Result.ok Can.NoEffects
     Src.Ports ports ->
       do
-        pairs <- traverse (canonicalizePort env) ports
+        pairs <- traverse (canonicalizePort env) (fmap snd ports)
         return $ Can.Ports (Map.fromList pairs)
     Src.Manager region manager ->
       let dict = Map.fromList (map toNameRegion values)

compiler/src/Canonicalize/Environment/Local.hs

@@ -50,7 +50,7 @@ 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 $
-        List.foldl' addDecl (toEffectDups effects) values
+        List.foldl' addDecl (toEffectDups effects) (fmap snd values)
 
 toEffectDups :: Src.Effects -> Dups.Dict Env.Var
 toEffectDups effects =
@@ -60,7 +60,7 @@ toEffectDups effects =
     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 ports
+       in List.foldl' addPort Dups.none (fmap snd ports)
     Src.Manager _ manager ->
       case manager of
         Src.Cmd (A.At region _) ->
@@ -79,11 +79,11 @@ addTypes (Src.Module _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs
   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 =
-        List.foldl' addUnionDups (List.foldl' addAliasDups Dups.none aliases) unions
+        List.foldl' addUnionDups (List.foldl' addAliasDups Dups.none (fmap snd aliases)) (fmap snd unions)
    in do
         _ <- Dups.detect Error.DuplicateType typeNameDups
-        ts1 <- foldM (addUnion home) ts unions
-        addAliases aliases (Env.Env home vs ts1 cs bs qvs qts qcs)
+        ts1 <- foldM (addUnion home) ts (fmap snd unions)
+        addAliases (fmap snd aliases) (Env.Env home vs ts1 cs bs qvs qts qcs)
 
 addUnion :: ModuleName.Canonical -> Env.Exposed Env.Type -> A.Located Src.Union -> Result i w (Env.Exposed Env.Type)
 addUnion home types union@(A.At _ (Src.Union (A.At _ name) _ _)) =
@@ -201,8 +201,8 @@ addFreeVars freeVars (A.At region tipe) =
 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) =
   do
-    unionInfo <- traverse (canonicalizeUnion env) unions
-    aliasInfo <- traverse (canonicalizeAlias env) aliases
+    unionInfo <- traverse (canonicalizeUnion env) (fmap snd unions)
+    aliasInfo <- traverse (canonicalizeAlias env) (fmap snd aliases)
 
     ctors <-
       Dups.detect Error.DuplicateCtor $

compiler/src/Canonicalize/Module.hs

@@ -35,8 +35,9 @@ 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 values _ _ 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)
     let cbinops = Map.fromList (map canonicalizeBinop binops)
 

compiler/src/Gren/Format.hs

@@ -0,0 +1,762 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -Wno-error=unused-matches #-}
+
+module Gren.Format (toByteStringBuilder) where
+
+import AST.Source qualified as Src
+import AST.Utils.Binop qualified as Binop
+import Control.Monad (join)
+import Data.Bifunctor (second)
+import Data.ByteString.Builder qualified as B
+import Data.List qualified as List
+import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty)
+import Data.List.NonEmpty qualified as NonEmpty
+import Data.Map.Strict (Map)
+import Data.Map.Strict qualified as Map
+import Data.Maybe (catMaybes)
+import Data.Name (Name)
+import Data.Semigroup (sconcat)
+import Data.Utf8 qualified as Utf8
+import Parse.Primitives qualified as P
+import Reporting.Annotation qualified as A
+import Text.PrettyPrint.Avh4.Block (Block)
+import Text.PrettyPrint.Avh4.Block qualified as Block
+
+toByteStringBuilder :: Src.Module -> B.Builder
+toByteStringBuilder module_ =
+  Block.render (formatModule module_)
+
+--
+-- Data structure extras
+--
+
+repair :: [(a, b)] -> a -> (a, [(b, a)])
+repair [] single = (single, [])
+repair ((first, b) : rest) final =
+  (first, repairHelp b rest final)
+
+repairHelp :: b -> [(a, b)] -> a -> [(b, a)]
+repairHelp b [] a = [(b, a)]
+repairHelp b1 ((a1, b2) : rest) a2 =
+  (b1, a1) : repairHelp b2 rest a2
+
+--
+-- Helper functions
+--
+
+utf8 :: Utf8.Utf8 any -> Block.Line
+utf8 = Block.lineFromBuilder . Utf8.toBuilder
+
+addBlankLines :: Int -> Block -> Block
+addBlankLines n block =
+  Block.stack $
+    NonEmpty.prependList
+      (replicate n Block.blankLine)
+      (NonEmpty.singleton block)
+
+spaceOrStack :: NonEmpty Block -> Block
+spaceOrStack = Block.rowOrStack (Just Block.space)
+
+spaceOrIndent :: NonEmpty Block -> Block
+spaceOrIndent = Block.rowOrIndent (Just Block.space)
+
+spaceOrIndentForce :: Bool -> NonEmpty Block -> Block
+spaceOrIndentForce forceMultiline = Block.rowOrIndentForce forceMultiline (Just Block.space)
+
+group :: Char -> Char -> Char -> Bool -> [Block] -> Block
+group open _ close _ [] = Block.line $ Block.char7 open <> Block.char7 close
+group open sep close forceMultiline (first : rest) =
+  Block.rowOrStackForce
+    forceMultiline
+    (Just Block.space)
+    [ Block.rowOrStackForce forceMultiline Nothing $
+        Block.prefix 2 (Block.char7 open <> Block.space) first
+          :| fmap (Block.prefix 2 (Block.char7 sep <> Block.space)) (rest),
+      Block.line (Block.char7 close)
+    ]
+
+surround :: Char -> Char -> Block -> Block
+surround open close block =
+  Block.rowOrStack
+    Nothing
+    [ Block.prefix 1 (Block.char7 open) block,
+      Block.line $ Block.char7 close
+    ]
+
+parens :: Block -> Block
+parens = surround '(' ')'
+
+extendedGroup :: Char -> Char -> Char -> Char -> Char -> Block -> NonEmpty (Block.Line, Block) -> Block
+extendedGroup open baseSep sep fieldSep close base fields =
+  case fields of
+    (single :| []) ->
+      spaceOrStack
+        [ spaceOrIndent
+            [ spaceOrIndent
+                [ Block.line $ Block.char7 open,
+                  base
+                ],
+              formatField baseSep single
+            ],
+          Block.line $ Block.char7 close
+        ]
+    (first :| rest) ->
+      Block.stack
+        [ spaceOrIndent
+            [ Block.line $ Block.char7 open,
+              base
+            ],
+          Block.indent $
+            Block.stack $
+              formatField baseSep first
+                :| fmap (formatField sep) rest,
+          Block.line $ Block.char7 close
+        ]
+  where
+    formatField punc (key, value) =
+      spaceOrIndent
+        [ Block.line $
+            Block.char7 punc
+              <> Block.space
+              <> key
+              <> Block.space
+              <> Block.char7 fieldSep,
+          value
+        ]
+
+--
+-- AST -> Block
+--
+formatModule :: Src.Module -> Block
+formatModule (Src.Module moduleName exports docs imports values unions aliases binops effects) =
+  -- TODO: implement actual formating
+  Block.stack $
+    NonEmpty.fromList $
+      catMaybes
+        [ Just $
+            spaceOrIndent $
+              NonEmpty.fromList $
+                catMaybes
+                  [ Just $ Block.line $ Block.string7 moduleKeyword,
+                    Just $ Block.line $ maybe (Block.string7 "Main") (utf8 . A.toValue) moduleName,
+                    formatEffectsModuleWhereClause effects,
+                    formatExposing $ A.toValue exports
+                  ],
+          case docs of
+            Src.NoDocs _ -> Nothing
+            Src.YesDocs moduleDocs _ ->
+              Just $
+                Block.stack
+                  [ Block.blankLine,
+                    formatDocComment moduleDocs
+                  ],
+          Just $ Block.stack $ Block.blankLine :| fmap formatImport imports,
+          infixDefs,
+          let defs =
+                fmap snd $
+                  List.sortOn fst $
+                    concat @[]
+                      [ fmap (formatWithDocComment valueName formatValue . A.toValue) <$> values,
+                        fmap (formatWithDocComment unionName formatUnion . A.toValue) <$> unions,
+                        fmap (formatWithDocComment aliasName formatAlias . A.toValue) <$> aliases,
+                        case effects of
+                          Src.NoEffects -> []
+                          Src.Ports ports -> fmap (formatWithDocComment portName formatPort) <$> ports
+                          Src.Manager _ _ -> []
+                      ]
+           in fmap Block.stack $ nonEmpty $ fmap (addBlankLines 2) defs
+        ]
+  where
+    moduleKeyword =
+      case effects of
+        Src.NoEffects -> "module"
+        Src.Ports _ -> "port module"
+        Src.Manager _ _ -> "effect module"
+
+    defDocs :: Map Name Src.DocComment
+    defDocs =
+      case docs of
+        Src.NoDocs _ -> Map.empty
+        Src.YesDocs _ defs -> Map.fromList defs
+
+    valueName (Src.Value name _ _ _) = A.toValue name
+    unionName (Src.Union name _ _) = A.toValue name
+    aliasName (Src.Alias name _ _) = A.toValue name
+    portName (Src.Port name _) = A.toValue name
+
+    formatWithDocComment :: (a -> Name) -> (a -> Block) -> a -> Block
+    formatWithDocComment getName render a =
+      case Map.lookup (getName a) defDocs of
+        Nothing -> render a
+        Just defDoc ->
+          Block.stack
+            [ formatDocComment defDoc,
+              render a
+            ]
+
+    infixDefs =
+      case NonEmpty.nonEmpty binops of
+        Nothing -> Nothing
+        Just some ->
+          Just $
+            Block.stack
+              [ Block.blankLine,
+                Block.stack $ fmap (formatInfix . A.toValue) some
+              ]
+
+formatEffectsModuleWhereClause :: Src.Effects -> Maybe Block
+formatEffectsModuleWhereClause = \case
+  Src.NoEffects -> Nothing
+  Src.Ports _ -> Nothing
+  Src.Manager _ manager -> Just $ formatManager manager
+
+formatManager :: Src.Manager -> Block
+formatManager manager =
+  spaceOrIndent
+    [ Block.line $ Block.string7 "where",
+      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)
+              ]
+    ]
+  where
+    formatPair (key, name) =
+      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
+  Src.Explicit exposed ->
+    Just $
+      spaceOrIndent
+        [ Block.line $ Block.string7 "exposing",
+          group '(' ',' ')' False $ fmap formatExposed exposed
+        ]
+
+formatExposed :: Src.Exposed -> Block
+formatExposed = \case
+  Src.Lower name -> Block.line $ utf8 $ A.toValue name
+  Src.Upper name privacy -> Block.line $ utf8 $ A.toValue name
+  Src.Operator _ name -> Block.line $ Block.char7 '(' <> utf8 name <> Block.char7 ')'
+
+formatImport :: Src.Import -> Block
+formatImport (Src.Import name alias exposing) =
+  spaceOrIndent $
+    NonEmpty.fromList $
+      catMaybes
+        [ Just $ Block.line $ Block.string7 "import",
+          Just $ Block.line $ utf8 $ A.toValue name,
+          fmap formatImportAlias alias,
+          formatExposing exposing
+        ]
+
+formatImportAlias :: Name -> Block
+formatImportAlias name = Block.line $ Block.string7 "as" <> Block.space <> utf8 name
+
+formatDocComment :: Src.DocComment -> Block
+formatDocComment (Src.DocComment doc) =
+  Block.line $
+    Block.string7 "{-|"
+      <> Block.lineFromBuilder (P.snippetToBuilder doc)
+      <> Block.string7 "-}"
+
+formatInfix :: Src.Infix -> Block
+formatInfix (Src.Infix name assoc (Binop.Precedence prec) fn) =
+  Block.line $
+    Block.string7 "infix "
+      <> formatAssociativity assoc
+      <> Block.space
+      <> Block.string7 (show prec)
+      <> Block.string7 " ("
+      <> utf8 name
+      <> Block.string7 ") = "
+      <> utf8 fn
+
+formatAssociativity :: Binop.Associativity -> Block.Line
+formatAssociativity = \case
+  Binop.Left -> Block.string7 "left "
+  Binop.Non -> Block.string7 "non  "
+  Binop.Right -> Block.string7 "right"
+
+formatValue :: Src.Value -> Block
+formatValue (Src.Value name args body type_) =
+  formatBasicDef (A.toValue name) (fmap A.toValue args) (A.toValue body) (fmap A.toValue type_)
+
+formatBasicDef :: Name -> [Src.Pattern_] -> Src.Expr_ -> Maybe Src.Type_ -> Block
+formatBasicDef name args body type_ =
+  Block.stack $
+    NonEmpty.fromList $
+      catMaybes
+        [ fmap (formatTypeAnnotation Nothing name) type_,
+          Just $
+            spaceOrIndent $
+              Block.line (utf8 name)
+                :| fmap (patternParensProtectSpaces . formatPattern) args
+                ++ [ Block.line $ Block.char7 '='
+                   ],
+          Just $ Block.indent $ exprParensNone $ formatExpr body
+        ]
+
+formatTypeAnnotation :: Maybe String -> Name -> Src.Type_ -> Block
+formatTypeAnnotation prefix name t =
+  spaceOrIndent
+    [ Block.line $ withPrefix $ utf8 name <> Block.space <> Block.char7 ':',
+      typeParensNone $ formatType t
+    ]
+  where
+    withPrefix a =
+      case prefix of
+        Nothing -> a
+        Just prefixString ->
+          Block.string7 prefixString <> Block.char7 ' ' <> a
+
+formatUnion :: Src.Union -> Block
+formatUnion (Src.Union name args ctors) =
+  Block.stack $
+    spaceOrIndent
+      [ Block.line (Block.string7 "type"),
+        spaceOrIndent $
+          Block.line (utf8 $ A.toValue name)
+            :| fmap (Block.line . utf8 . A.toValue) args
+      ]
+      :| fmap Block.indent formatCtors
+  where
+    formatCtors =
+      case ctors of
+        [] -> []
+        (first : rest) -> formatCtor '=' first : fmap (formatCtor '|') rest
+
+formatCtor :: Char -> (A.Located Name, [Src.Type]) -> Block
+formatCtor open (name, args) =
+  spaceOrIndent $
+    Block.line (Block.char7 open <> Block.space <> utf8 (A.toValue name))
+      :| fmap (typeParensProtectSpaces . formatType . A.toValue) args
+
+formatAlias :: Src.Alias -> Block
+formatAlias (Src.Alias name args type_) =
+  Block.stack
+    [ spaceOrIndent
+        [ Block.line (Block.string7 "type alias"),
+          spaceOrIndent $
+            Block.line (utf8 $ A.toValue name)
+              :| fmap (Block.line . utf8 . A.toValue) args,
+          Block.line (Block.char7 '=')
+        ],
+      Block.indent $ typeParensNone $ formatType (A.toValue type_)
+    ]
+
+formatPort :: Src.Port -> Block
+formatPort = \case
+  Src.Port name type_ ->
+    formatTypeAnnotation (Just "port") (A.toValue name) (A.toValue type_)
+
+data ExpressionBlock
+  = NoExpressionParens Block
+  | ExpressionContainsInfixOps Block
+  | ExpressionContainsSpaces Block
+  | ExpressionHasAmbiguousEnd Block
+
+-- "no parens"
+exprParensNone :: ExpressionBlock -> Block
+exprParensNone = \case
+  NoExpressionParens block -> block
+  ExpressionContainsInfixOps block -> block
+  ExpressionContainsSpaces block -> block
+  ExpressionHasAmbiguousEnd block -> block
+
+exprParensProtectInfixOps :: ExpressionBlock -> Block
+exprParensProtectInfixOps = \case
+  NoExpressionParens block -> block
+  ExpressionContainsInfixOps block -> parens block
+  ExpressionContainsSpaces block -> block
+  ExpressionHasAmbiguousEnd block -> parens block
+
+exprParensProtectSpaces :: ExpressionBlock -> Block
+exprParensProtectSpaces = \case
+  NoExpressionParens block -> block
+  ExpressionContainsInfixOps block -> parens block
+  ExpressionContainsSpaces block -> parens block
+  ExpressionHasAmbiguousEnd block -> parens block
+
+formatExpr :: Src.Expr_ -> ExpressionBlock
+formatExpr = \case
+  Src.Chr char ->
+    NoExpressionParens $
+      formatString StringStyleChar char
+  Src.Str string ->
+    NoExpressionParens $
+      formatString StringStyleSingleQuoted string
+  Src.Int int ->
+    NoExpressionParens $
+      Block.line $
+        Block.string7 (show int)
+  Src.Float float ->
+    NoExpressionParens $
+      Block.line $
+        utf8 float
+  Src.Var _ name ->
+    NoExpressionParens $
+      Block.line $
+        utf8 name
+  Src.VarQual _ ns name ->
+    NoExpressionParens $
+      Block.line $
+        utf8 ns <> Block.char7 '.' <> utf8 name
+  Src.Array exprs ->
+    NoExpressionParens $
+      group '[' ',' ']' True $
+        fmap (exprParensNone . formatExpr . A.toValue) exprs
+  Src.Op name ->
+    NoExpressionParens $
+      Block.line $
+        Block.char7 '(' <> utf8 name <> Block.char7 ')'
+  Src.Negate expr ->
+    NoExpressionParens $
+      Block.prefix 1 (Block.char7 '-') $
+        exprParensProtectSpaces $
+          formatExpr $
+            A.toValue expr
+  Src.Binops postfixOps final ->
+    let (first, rest) = repair postfixOps final
+     in ExpressionContainsInfixOps $
+          spaceOrIndentForce forceMultiline $
+            exprParensProtectInfixOps (formatExpr $ A.toValue first)
+              :| fmap formatPair rest
+    where
+      -- for now we just use multiline formatting for specific operators,
+      -- since we don't yet track where the linebreaks are in the source
+      forceMultiline = any (opForcesMultiline . A.toValue . snd) postfixOps
+      formatPair (op, expr) =
+        Block.prefix
+          4
+          (utf8 (A.toValue op) <> Block.space)
+          (exprParensProtectInfixOps $ formatExpr $ A.toValue expr)
+  Src.Lambda [] body ->
+    formatExpr $ A.toValue body
+  Src.Lambda (arg1 : args) body ->
+    ExpressionHasAmbiguousEnd $
+      spaceOrIndent
+        [ Block.prefix 1 (Block.char7 '\\') $
+            spaceOrStack $
+              join
+                [ fmap (patternParensProtectSpaces . formatPattern . A.toValue) (arg1 :| args),
+                  pure $ Block.line $ Block.string7 "->"
+                ],
+          exprParensNone $ formatExpr $ A.toValue body
+        ]
+  Src.Call fn [] ->
+    formatExpr $ A.toValue fn
+  Src.Call fn args ->
+    ExpressionContainsSpaces $
+      spaceOrIndent $
+        exprParensProtectInfixOps (formatExpr $ A.toValue fn)
+          :| fmap (exprParensProtectSpaces . formatExpr . A.toValue) args
+  Src.If [] else_ ->
+    formatExpr $ A.toValue else_
+  Src.If (if_ : elseifs) else_ ->
+    ExpressionHasAmbiguousEnd $
+      Block.stack $
+        NonEmpty.fromList $
+          mconcat
+            [ List.singleton $ formatIfClause "if" if_,
+              fmap (formatIfClause "else if") elseifs,
+              List.singleton $
+                Block.stack
+                  [ Block.line $ Block.string7 "else",
+                    Block.indent $ exprParensNone $ formatExpr $ A.toValue else_
+                  ]
+            ]
+    where
+      formatIfClause :: String -> (Src.Expr, Src.Expr) -> Block
+      formatIfClause keyword (predicate, body) =
+        Block.stack
+          [ spaceOrStack
+              [ spaceOrIndent
+                  [ Block.line $ Block.string7 keyword,
+                    exprParensNone $ formatExpr $ A.toValue predicate
+                  ],
+                Block.line $ Block.string7 "then"
+              ],
+            Block.indent $ exprParensNone $ formatExpr $ A.toValue body
+          ]
+  Src.Let [] body ->
+    formatExpr $ A.toValue body
+  Src.Let (def1 : defs) body ->
+    ExpressionHasAmbiguousEnd $
+      Block.stack
+        [ Block.line (Block.string7 "let"),
+          Block.indent $ Block.stack $ NonEmpty.intersperse Block.blankLine $ fmap (formatDef . A.toValue) (def1 :| defs),
+          Block.line (Block.string7 "in"),
+          exprParensNone $ formatExpr (A.toValue body)
+        ]
+  Src.Case subject branches ->
+    ExpressionHasAmbiguousEnd $
+      Block.stack $
+        spaceOrStack
+          [ spaceOrIndent
+              [ Block.line (Block.string7 "case"),
+                exprParensNone $ formatExpr (A.toValue subject)
+              ],
+            Block.line (Block.string7 "of")
+          ]
+          :| List.intersperse Block.blankLine (fmap (Block.indent . formatCaseBranch) branches)
+    where
+      formatCaseBranch (pat, expr) =
+        Block.stack
+          [ spaceOrStack
+              [ patternParensNone $ formatPattern (A.toValue pat),
+                Block.line $ Block.string7 "->"
+              ],
+            Block.indent $ exprParensNone $ formatExpr $ A.toValue expr
+          ]
+  Src.Accessor field ->
+    NoExpressionParens $
+      Block.line $
+        Block.char7 '.' <> utf8 field
+  Src.Access expr field ->
+    NoExpressionParens $
+      Block.addSuffix (Block.char7 '.' <> utf8 (A.toValue field)) (exprParensProtectSpaces $ formatExpr $ A.toValue expr)
+  Src.Update base [] ->
+    formatExpr $ A.toValue base
+  Src.Update base (first : rest) ->
+    NoExpressionParens $
+      extendedGroup
+        '{'
+        '|'
+        ','
+        '='
+        '}'
+        (exprParensNone $ formatExpr $ A.toValue base)
+        (fmap formatField $ first :| rest)
+    where
+      formatField (field, expr) =
+        ( utf8 $ A.toValue field,
+          exprParensNone $ formatExpr (A.toValue expr)
+        )
+  Src.Record fields ->
+    NoExpressionParens $
+      group '{' ',' '}' True $
+        fmap formatField fields
+    where
+      formatField (name, expr) =
+        spaceOrIndent
+          [ Block.line $ utf8 (A.toValue name) <> Block.space <> Block.char7 '=',
+            exprParensNone $ formatExpr (A.toValue expr)
+          ]
+
+opForcesMultiline :: Name -> Bool
+opForcesMultiline op =
+  op == Utf8.fromChars "|>"
+    || op == Utf8.fromChars "<|"
+
+formatDef :: Src.Def -> Block
+formatDef = \case
+  Src.Define name args body ann ->
+    formatBasicDef (A.toValue name) (fmap A.toValue args) (A.toValue body) (fmap A.toValue ann)
+  Src.Destruct pat body ->
+    Block.stack
+      [ spaceOrIndent
+          [ patternParensProtectSpaces $ formatPattern $ A.toValue pat,
+            Block.line $ Block.char7 '='
+          ],
+        Block.indent $ exprParensNone $ formatExpr $ A.toValue body
+      ]
+
+data TypeBlock
+  = NoTypeParens Block
+  | TypeContainsArrow Block
+  | TypeContainsSpaces Block
+
+typeParensNone :: TypeBlock -> Block
+typeParensNone = \case
+  NoTypeParens block -> block
+  TypeContainsArrow block -> block
+  TypeContainsSpaces block -> block
+
+typeParensProtectArrows :: TypeBlock -> Block
+typeParensProtectArrows = \case
+  NoTypeParens block -> block
+  TypeContainsArrow block -> parens block
+  TypeContainsSpaces block -> block
+
+typeParensProtectSpaces :: TypeBlock -> Block
+typeParensProtectSpaces = \case
+  NoTypeParens block -> block
+  TypeContainsArrow block -> parens block
+  TypeContainsSpaces block -> parens block
+
+collectLambdaTypes :: Src.Type -> Src.Type -> NonEmpty (Src.Type)
+collectLambdaTypes left = \case
+  (A.At _ (Src.TLambda next rest)) ->
+    NonEmpty.cons left (collectLambdaTypes next rest)
+  other ->
+    left :| [other]
+
+formatType :: Src.Type_ -> TypeBlock
+formatType = \case
+  Src.TLambda left right ->
+    TypeContainsArrow $
+      case collectLambdaTypes left right of
+        (first :| rest) ->
+          spaceOrStack $
+            (typeParensProtectArrows $ formatType (A.toValue first))
+              :| fmap (Block.prefix 3 (Block.string7 "-> ") . typeParensProtectArrows . formatType . A.toValue) rest
+  Src.TVar name ->
+    NoTypeParens $
+      Block.line (utf8 name)
+  Src.TType _ name [] ->
+    NoTypeParens $
+      Block.line (utf8 name)
+  Src.TType _ name args ->
+    TypeContainsSpaces $
+      spaceOrIndent $
+        Block.line (utf8 name)
+          :| fmap (typeParensProtectSpaces . formatType . A.toValue) args
+  Src.TTypeQual _ ns name [] ->
+    NoTypeParens $
+      Block.line (utf8 ns <> Block.char7 '.' <> utf8 name)
+  Src.TTypeQual _ ns name args ->
+    TypeContainsSpaces $
+      spaceOrIndent $
+        Block.line (utf8 ns <> Block.char7 '.' <> utf8 name)
+          :| fmap (typeParensProtectSpaces . formatType . A.toValue) args
+  Src.TRecord fields Nothing ->
+    NoTypeParens $
+      group '{' ',' '}' True $
+        fmap formatField fields
+    where
+      formatField (name, type_) =
+        spaceOrIndent
+          [ Block.line $ utf8 (A.toValue name) <> Block.space <> Block.char7 ':',
+            typeParensNone $ formatType (A.toValue type_)
+          ]
+  Src.TRecord [] (Just base) ->
+    NoTypeParens $
+      Block.line $
+        utf8 $
+          A.toValue base
+  Src.TRecord (first : rest) (Just base) ->
+    NoTypeParens $
+      extendedGroup
+        '{'
+        '|'
+        ','
+        ':'
+        '}'
+        (Block.line $ utf8 $ A.toValue base)
+        (fmap formatField $ first :| rest)
+    where
+      formatField (field, type_) =
+        ( utf8 $ A.toValue field,
+          typeParensNone $ formatType $ A.toValue type_
+        )
+
+data PatternBlock
+  = NoPatternParens Block
+  | PatternContainsSpaces Block
+
+patternParensNone :: PatternBlock -> Block
+patternParensNone = \case
+  NoPatternParens block -> block
+  PatternContainsSpaces block -> block
+
+patternParensProtectSpaces :: PatternBlock -> Block
+patternParensProtectSpaces = \case
+  NoPatternParens block -> block
+  PatternContainsSpaces block -> parens block
+
+formatPattern :: Src.Pattern_ -> PatternBlock
+formatPattern = \case
+  Src.PAnything ->
+    NoPatternParens $
+      Block.line $
+        Block.char7 '_'
+  Src.PVar name ->
+    NoPatternParens $
+      Block.line $
+        utf8 name
+  Src.PRecord fields ->
+    NoPatternParens $
+      group '{' ',' '}' False $
+        fmap (formatField . A.toValue) fields
+    where
+      formatField = \case
+        Src.RFPattern (A.At _ name) (A.At _ (Src.PVar pname))
+          | name == pname ->
+              Block.line $ utf8 name
+        Src.RFPattern name pat ->
+          spaceOrIndent
+            [ Block.line $ utf8 (A.toValue name) <> Block.space <> Block.char7 '=',
+              patternParensNone $ formatPattern (A.toValue pat)
+            ]
+  Src.PAlias pat name ->
+    PatternContainsSpaces $
+      spaceOrIndent
+        [ patternParensProtectSpaces $ formatPattern (A.toValue pat),
+          Block.line $ Block.string7 "as " <> utf8 (A.toValue name)
+        ]
+  Src.PCtor _ name [] ->
+    NoPatternParens $
+      Block.line (utf8 name)
+  Src.PCtor _ name args ->
+    PatternContainsSpaces $
+      spaceOrIndent $
+        Block.line (utf8 name)
+          :| fmap (patternParensProtectSpaces . formatPattern . A.toValue) args
+  Src.PCtorQual _ ns name [] ->
+    NoPatternParens $
+      Block.line (utf8 ns <> Block.char7 '.' <> utf8 name)
+  Src.PCtorQual _ ns name args ->
+    PatternContainsSpaces $
+      spaceOrIndent $
+        Block.line (utf8 ns <> Block.char7 '.' <> utf8 name)
+          :| fmap (patternParensProtectSpaces . formatPattern . A.toValue) args
+  Src.PArray items ->
+    NoPatternParens $
+      group '[' ',' ']' False $
+        fmap (patternParensNone . formatPattern . A.toValue) items
+  Src.PChr char ->
+    NoPatternParens $
+      formatString StringStyleChar char
+  Src.PStr string ->
+    NoPatternParens $
+      formatString StringStyleSingleQuoted string
+  Src.PInt int ->
+    NoPatternParens $
+      Block.line $
+        Block.string7 (show int)
+
+data StringStyle
+  = StringStyleChar
+  | StringStyleSingleQuoted
+  | StringStyleTripleQuoted
+  deriving (Eq)
+
+formatString :: StringStyle -> Utf8.Utf8 any -> Block
+formatString style str =
+  case style of
+    StringStyleChar ->
+      stringBox (Block.char7 '\'')
+    StringStyleSingleQuoted ->
+      stringBox (Block.char7 '"')
+    StringStyleTripleQuoted ->
+      stringBox (Block.string7 "\"\"\"")
+  where
+    stringBox :: Block.Line -> Block
+    stringBox quotes =
+      Block.line $ quotes <> utf8 str <> quotes

compiler/src/Gren/Format/Normalize.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE MagicHash #-}
+
+-- | This module is the "normalization" phase that transforms the raw source AST
+-- into an AST ready for rendering back into a text representation.
+--
+-- This is simply a place to put "formatting" logic that doesn't really make sense
+-- as a responsibility for the code that is rendering the AST into text.
+module Gren.Format.Normalize (normalize) where
+
+import AST.Source qualified as Src
+import Data.Map (Map)
+import Data.Map qualified as Map
+import Data.Maybe (mapMaybe)
+import Data.Name (Name)
+import Gren.Compiler.Imports qualified
+import Reporting.Annotation qualified as A
+
+normalize :: Src.Module -> Src.Module
+normalize module_ =
+  module_
+    { Src._imports = mapMaybe removeDefaultImports $ Src._imports module_
+    }
+
+removeDefaultImports :: Src.Import -> Maybe Src.Import
+removeDefaultImports import_@(Src.Import name alias exposing) =
+  case Map.lookup (A.toValue name) defaultImports of
+    Just (Src.Import _ defAlias defExposing) ->
+      if alias == defAlias && exposingEq exposing defExposing
+        then Nothing
+        else Just import_
+    Nothing -> Just import_
+
+defaultImports :: Map Name Src.Import
+defaultImports =
+  Map.fromList $ fmap (\import_ -> (Src.getImportName import_, import_)) Gren.Compiler.Imports.defaults
+
+exposingEq :: Src.Exposing -> Src.Exposing -> Bool
+exposingEq Src.Open Src.Open = True
+exposingEq (Src.Explicit a) (Src.Explicit b) =
+  fmap stripRegionsExposed a == fmap stripRegionsExposed b
+exposingEq _ _ = False
+
+data SimpleExposed
+  = Lower Name
+  | Upper Name SimplePrivacy
+  | Operator Name
+  deriving (Eq)
+
+data SimplePrivacy
+  = Public
+  | Private
+  deriving (Eq)
+
+stripRegionsExposed :: Src.Exposed -> SimpleExposed
+stripRegionsExposed exposed =
+  case exposed of
+    Src.Lower (A.At _ name) -> Lower name
+    Src.Upper (A.At _ name) priv -> Upper name (stripRegionsPrivacy priv)
+    Src.Operator _ name -> Operator name
+
+stripRegionsPrivacy :: Src.Privacy -> SimplePrivacy
+stripRegionsPrivacy priv =
+  case priv of
+    Src.Public _ -> Public
+    Src.Private -> Private

compiler/src/Parse/Module.hs

@@ -76,7 +76,7 @@ chompModule projectType =
 
 checkModule :: ProjectType -> Module -> Either E.Error Src.Module
 checkModule projectType (Module maybeHeader imports infixes decls) =
-  let (values, unions, aliases, ports) = categorizeDecls [] [] [] [] 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
@@ -88,14 +88,14 @@ checkModule projectType (Module maybeHeader imports infixes decls) =
                 [] -> Src.NoEffects
                 _ : _ -> Src.Ports ports
 
-checkEffects :: ProjectType -> [Src.Port] -> Effects -> Either E.Error Src.Effects
+checkEffects :: ProjectType -> [(Src.SourceOrder, Src.Port)] -> Effects -> Either E.Error Src.Effects
 checkEffects projectType ports effects =
   case effects of
     NoEffects region ->
       case ports of
         [] ->
           Right Src.NoEffects
-        Src.Port name _ : _ ->
+        (_, Src.Port name _) : _ ->
           case projectType of
             Package _ -> Left (E.NoPortsInPackage name)
             Application -> Left (E.UnexpectedPort region)
@@ -114,17 +114,28 @@ checkEffects projectType ports effects =
           _ : _ -> Left (E.UnexpectedPort region)
         else Left (E.NoEffectsOutsideKernel region)
 
-categorizeDecls :: [A.Located Src.Value] -> [A.Located Src.Union] -> [A.Located Src.Alias] -> [Src.Port] -> [Decl.Decl] -> ([A.Located Src.Value], [A.Located Src.Union], [A.Located Src.Alias], [Src.Port])
-categorizeDecls values unions aliases ports decls =
+categorizeDecls ::
+  [(Src.SourceOrder, A.Located Src.Value)] ->
+  [(Src.SourceOrder, A.Located Src.Union)] ->
+  [(Src.SourceOrder, A.Located Src.Alias)] ->
+  [(Src.SourceOrder, Src.Port)] ->
+  Src.SourceOrder ->
+  [Decl.Decl] ->
+  ( [(Src.SourceOrder, A.Located Src.Value)],
+    [(Src.SourceOrder, A.Located Src.Union)],
+    [(Src.SourceOrder, A.Located Src.Alias)],
+    [(Src.SourceOrder, Src.Port)]
+  )
+categorizeDecls values unions aliases ports index decls =
   case decls of
     [] ->
       (values, unions, aliases, ports)
     decl : otherDecls ->
       case decl of
-        Decl.Value _ value -> categorizeDecls (value : values) unions aliases ports otherDecls
-        Decl.Union _ union -> categorizeDecls values (union : unions) aliases ports otherDecls
-        Decl.Alias _ alias -> categorizeDecls values unions (alias : aliases) ports otherDecls
-        Decl.Port _ port_ -> categorizeDecls values unions aliases (port_ : ports) otherDecls
+        Decl.Value _ value -> categorizeDecls ((index, value) : values) unions aliases ports (index + 1) otherDecls
+        Decl.Union _ union -> categorizeDecls values ((index, union) : unions) aliases ports (index + 1) otherDecls
+        Decl.Alias _ alias -> categorizeDecls values unions ((index, alias) : aliases) ports (index + 1) otherDecls
+        Decl.Port _ port_ -> categorizeDecls values unions aliases ((index, port_) : ports) (index + 1) otherDecls
 
 -- TO DOCS
 

compiler/src/Parse/Primitives.hs

@@ -28,10 +28,13 @@ module Parse.Primitives
     getCharWidth,
     Snippet (..),
     fromSnippet,
+    snippetToBuilder,
   )
 where
 
 import Control.Applicative qualified as Applicative (Applicative (..))
+import Data.ByteString.Builder (Builder)
+import Data.ByteString.Builder qualified as Builder
 import Data.ByteString.Internal qualified as B
 import Data.Word (Word16, Word8)
 import Foreign.ForeignPtr (ForeignPtr, touchForeignPtr)
@@ -205,6 +208,10 @@ fromSnippet (Parser parser) toBadEnd (Snippet fptr offset length row col) =
           touchForeignPtr fptr
           return result
 
+snippetToBuilder :: Snippet -> Builder
+snippetToBuilder (Snippet fptr offset length _ _) =
+  Builder.byteString $ B.fromForeignPtr fptr offset length
+
 -- POSITION
 
 getCol :: Parser x Word16

compiler/src/Text/PrettyPrint/Avh4/Block.hs

@@ -0,0 +1,339 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE LambdaCase #-}
+{-# OPTIONS_GHC -Wno-name-shadowing #-}
+
+-- TODO: Extract Text.PrettyPrint.Avh4 to a separate library
+
+module Text.PrettyPrint.Avh4.Block
+  ( Line,
+    string7,
+    lineFromBuilder,
+    commentByteString,
+    space,
+    Block (SingleLine, MustBreak),
+    blankLine,
+    line,
+    mustBreak,
+    stack,
+    stackForce,
+    andThen,
+    indent,
+    prefix,
+    addSuffix,
+    joinMustBreak,
+    prefixOrIndent,
+    rowOrStack,
+    rowOrStackForce,
+    rowOrIndent,
+    rowOrIndentForce,
+    render,
+    char7,
+    stringUtf8,
+  )
+where
+
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as ByteString
+import Data.ByteString.Builder qualified as B
+import Data.List.NonEmpty (NonEmpty ((:|)))
+import Data.List.NonEmpty qualified as NonEmpty
+import Data.Semigroup (sconcat)
+import Text.PrettyPrint.Avh4.Indent (Indent)
+import Text.PrettyPrint.Avh4.Indent qualified as Indent
+
+-- | A `Line` is ALWAYS just one single line of text,
+-- and can always be combined horizontally with other `Line`s.
+--
+-- - `Space` is a single horizontal space,
+-- - `Blank` is a line with no content.
+-- - `Text` brings any text into the data structure. (Uses `ByteString.Builder` for the possibility of optimal performance)
+-- - `Row` joins multiple elements onto one line.
+data Line
+  = Text B.Builder
+  | Row Line Line
+  | Space
+  | Blank
+
+instance Semigroup Line where
+  a <> b = Row a b
+
+char7 :: Char -> Line
+char7 = Text . B.char7
+
+string7 :: String -> Line
+string7 = Text . B.string7
+
+-- | If you know the String only contains ASCII characters, then use `string7` instead for better performance.
+stringUtf8 :: String -> Line
+stringUtf8 = Text . B.stringUtf8
+
+-- | You must guarantee that the content of the Builder does not contain newlines and does not start with whitespace.
+lineFromBuilder :: B.Builder -> Line
+lineFromBuilder = Text
+
+{-# INLINE mkTextByteString #-}
+mkTextByteString :: ByteString -> Line
+mkTextByteString = Text . B.byteString
+
+commentByteString :: ByteString -> Line
+commentByteString bs =
+  if ByteString.null bs
+    then Blank
+    else mkTextByteString bs
+
+space :: Line
+space =
+  Space
+
+data Indented a
+  = Indented Indent a
+  deriving (Functor)
+
+-- | `Block` contains Lines (at least one; it can't be empty).
+--
+-- Block either:
+--  - can appear in the middle of a line
+--      (Stack someLine [], thus can be joined without problems), or
+--  - has to appear on its own
+--      (Stack someLine moreLines OR MustBreak someLine).
+--
+-- - `SingleLine` is a single line, and the indentation level for the line.
+-- - `MustBreak` is a single line (and its indentation level)) that cannot have anything joined to its right side.
+--  Notably, it is used for `--` comments.
+-- - `Stack` contains two or more lines, and the indentation level for each.
+--
+-- Sometimes (see `prefix`) the first line of Stack
+--  gets different treatment than the other lines.
+data Block
+  = SingleLine (Indented Line)
+  | Stack (Indented Line) (Indented Line) [Indented Line]
+  | MustBreak (Indented Line)
+
+blankLine :: Block
+blankLine =
+  line Blank
+
+line :: Line -> Block
+line =
+  SingleLine . mkIndentedLine
+
+mustBreak :: Line -> Block
+mustBreak =
+  MustBreak . mkIndentedLine
+
+mkIndentedLine :: Line -> Indented Line
+mkIndentedLine Space = Indented (Indent.spaces 1) Blank
+mkIndentedLine (Row Space next) =
+  let (Indented i rest') = mkIndentedLine next
+   in Indented (Indent.spaces 1 <> i) rest'
+mkIndentedLine other = Indented mempty other
+
+stackForce :: Block -> Block -> Block
+stackForce b1 b2 =
+  let (line1first, line1rest) = destructure b1
+      (line2first, line2rest) = destructure b2
+   in case line1rest ++ line2first : line2rest of
+        [] ->
+          error "the list will contain at least line2first"
+        first : rest ->
+          Stack line1first first rest
+
+andThen :: [Block] -> Block -> Block
+andThen rest first =
+  foldl stackForce first rest
+
+stack :: NonEmpty Block -> Block
+stack = foldr1 stackForce
+
+joinMustBreak :: Block -> Block -> Block
+joinMustBreak inner eol =
+  case (inner, eol) of
+    (SingleLine (Indented i1 inner'), SingleLine (Indented _ eol')) ->
+      SingleLine $
+        Indented i1 $
+          inner' <> space <> eol'
+    (SingleLine (Indented i1 inner'), MustBreak (Indented _ eol')) ->
+      MustBreak $
+        Indented i1 $
+          inner' <> space <> eol'
+    _ ->
+      stackForce inner eol
+
+{-# INLINE prefixOrIndent #-}
+prefixOrIndent :: Maybe Line -> Line -> Block -> Block
+prefixOrIndent joiner a b =
+  let join a b =
+        case joiner of
+          Nothing -> a <> b
+          Just j -> a <> j <> b
+   in case b of
+        SingleLine (Indented _ b') ->
+          line $ join a b'
+        MustBreak (Indented _ b') ->
+          mustBreak $ join a b'
+        _ ->
+          stackForce (line a) (indent b)
+
+mapLines :: (Indented Line -> Indented Line) -> Block -> Block
+mapLines fn =
+  mapFirstLine fn fn
+
+mapFirstLine :: (Indented Line -> Indented Line) -> (Indented Line -> Indented Line) -> Block -> Block
+mapFirstLine firstFn restFn b =
+  case b of
+    SingleLine l1 ->
+      SingleLine (firstFn l1)
+    Stack l1 l2 ls ->
+      Stack (firstFn l1) (restFn l2) (map restFn ls)
+    MustBreak l1 ->
+      MustBreak (firstFn l1)
+
+mapLastLine :: (Indented Line -> Indented Line) -> Block -> Block
+mapLastLine lastFn = \case
+  SingleLine l1 ->
+    SingleLine (lastFn l1)
+  Stack l1 l2 [] ->
+    Stack l1 (lastFn l2) []
+  Stack l1 l2 ls ->
+    Stack l1 l2 (init ls ++ [lastFn $ last ls])
+  MustBreak l1 ->
+    MustBreak (lastFn l1)
+
+indent :: Block -> Block
+indent =
+  mapLines (\(Indented i l) -> Indented (Indent.tab <> i) l)
+
+{-# INLINE rowOrStack #-}
+rowOrStack :: Maybe Line -> NonEmpty Block -> Block
+rowOrStack = rowOrStackForce False
+
+{-# INLINE rowOrStackForce #-}
+rowOrStackForce :: Bool -> Maybe Line -> NonEmpty Block -> Block
+rowOrStackForce _ _ (single :| []) = single
+rowOrStackForce forceMultiline (Just joiner) blocks =
+  case allSingles blocks of
+    Right lines
+      | not forceMultiline ->
+          line $ sconcat $ NonEmpty.intersperse joiner lines
+    _ ->
+      stack blocks
+rowOrStackForce forceMultiline Nothing blocks =
+  case allSingles blocks of
+    Right lines
+      | not forceMultiline ->
+          line $ sconcat lines
+    _ ->
+      stack blocks
+
+{-# INLINE rowOrIndent #-}
+rowOrIndent :: Maybe Line -> NonEmpty Block -> Block
+rowOrIndent = rowOrIndentForce False
+
+{-# INLINE rowOrIndentForce #-}
+rowOrIndentForce :: Bool -> Maybe Line -> NonEmpty Block -> Block
+rowOrIndentForce _ _ (single :| []) = single
+rowOrIndentForce forceMultiline (Just joiner) blocks@(b1 :| rest) =
+  case allSingles blocks of
+    Right lines
+      | not forceMultiline ->
+          line $ sconcat $ NonEmpty.intersperse joiner lines
+    _ ->
+      stack (b1 :| (indent <$> rest))
+rowOrIndentForce forceMultiline Nothing blocks@(b1 :| rest) =
+  case allSingles blocks of
+    Right lines
+      | not forceMultiline ->
+          line $ sconcat lines
+    _ ->
+      stack (b1 :| (indent <$> rest))
+
+{-# DEPRECATED isLine "Rewrite to avoid inspecting the child blocks" #-}
+isLine :: Block -> Either Block Line
+isLine b =
+  case b of
+    SingleLine (Indented _ l) ->
+      Right l
+    _ ->
+      Left b
+
+destructure :: Block -> (Indented Line, [Indented Line])
+destructure b =
+  case b of
+    SingleLine l1 ->
+      (l1, [])
+    Stack l1 l2 rest ->
+      (l1, l2 : rest)
+    MustBreak l1 ->
+      (l1, [])
+
+allSingles :: Traversable t => t Block -> Either (t Block) (t Line)
+allSingles blocks =
+  case mapM isLine blocks of
+    Right lines' ->
+      Right lines'
+    _ ->
+      Left blocks
+
+{-
+Add the prefix to the first line,
+pad the other lines with spaces of the same length
+
+NOTE: An exceptional case that we haven't really designed for is if the first line of the input Block is indented.
+
+EXAMPLE:
+abcde
+xyz
+----->
+myPrefix abcde
+         xyz
+-}
+prefix :: Word -> Line -> Block -> Block
+prefix prefixLength pref =
+  let padLineWithSpaces (Indented i l) = Indented (Indent.spaces prefixLength <> i) l
+
+      addPrefixToLine Blank = stripEnd pref
+      addPrefixToLine l = pref <> l
+   in mapFirstLine (fmap addPrefixToLine) padLineWithSpaces
+
+stripEnd :: Line -> Line
+stripEnd = \case
+  Space -> Blank
+  Row r1 r2 ->
+    case (stripEnd r1, stripEnd r2) of
+      (r1', Blank) -> r1'
+      (Blank, r2') -> r2'
+      (r1', r2') -> Row r1' r2'
+  Text t -> Text t
+  Blank -> Blank
+
+addSuffix :: Line -> Block -> Block
+addSuffix suffix =
+  mapLastLine $ fmap (<> suffix)
+
+renderIndentedLine :: Indented Line -> B.Builder
+renderIndentedLine (Indented i line') =
+  renderLine i line' <> B.char7 '\n'
+
+spaces :: Int -> B.Builder
+spaces i =
+  B.byteString (ByteString.replicate i 0x20 {- space -})
+
+renderLine :: Indent -> Line -> B.Builder
+renderLine i = \case
+  Text text ->
+    spaces (Indent.width i) <> text
+  Space ->
+    spaces (1 + Indent.width i)
+  Row left right ->
+    renderLine i left <> renderLine mempty right
+  Blank ->
+    mempty
+
+render :: Block -> B.Builder
+render = \case
+  SingleLine line' ->
+    renderIndentedLine line'
+  Stack l1 l2 rest ->
+    foldMap renderIndentedLine (l1 : l2 : rest)
+  MustBreak line' ->
+    renderIndentedLine line'

compiler/src/Text/PrettyPrint/Avh4/Indent.hs

@@ -0,0 +1,58 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+-- TODO: Extract Text.PrettyPrint.Avh4 to a separate library
+
+module Text.PrettyPrint.Avh4.Indent (Indent, tab, spaces, width) where
+
+spacesInTab :: Word
+spacesInTab = 4
+
+-- | `Indent` represents an indentation level,
+-- and the operator `<>` can be used to combine two indentations side-by-side, accounting for the tab size.
+--
+-- Each `Indent` can be thought of as:
+-- one or more TABs, followed by zero to three SPACEs.
+--
+-- Combining two indents can be thought of as
+-- typing the first and then the second sequence of
+-- TABs and SPACEs in a word processor.
+--
+-- For example:
+--
+--    [TAB] <> [TAB]     ==  [TAB][TAB]
+--    [TAB] <> ...       ==  [TAB]...
+--    [TAB] <> [TAB]...  ==  [TAB][TAB]...
+--     <> ...            ==  ...
+--    [TAB].. <> [TAB]   ==  [TAB][TAB]
+--    .. <> .            ==  ...
+--    .. <> ..           ==  [TAB]
+newtype Indent
+  = Indent [Word]
+  deriving (Semigroup, Monoid, Show)
+
+instance Eq Indent where
+  a == b =
+    width' a == width' b
+
+tab :: Indent
+tab = Indent [spacesInTab]
+
+spaces :: Word -> Indent
+spaces = Indent . pure
+
+width :: Num n => Indent -> n
+width = fromIntegral . width'
+
+width' :: Indent -> Word
+width' (Indent is) =
+  foldl combine 0 is
+
+combine :: Word -> Word -> Word
+combine pos i =
+  if i < spacesInTab
+    then -- The right side starts with spaces (and no TABs),
+    -- so just add everything together.
+      pos + i
+    else -- The right side starts with at least one TAB,
+    -- so remove the trailing spaces from the left.
+      pos - (pos `mod` spacesInTab) + i

gren.cabal

@@ -94,6 +94,8 @@ Common gren-common
         Gren.Constraint
         Gren.Docs
         Gren.Float
+        Gren.Format
+        Gren.Format.Normalize
         Gren.Interface
         Gren.Kernel
         Gren.Licenses
@@ -111,6 +113,8 @@ Common gren-common
         Data.NonEmptyList
         Data.OneOrMore
         Data.Utf8
+        Text.PrettyPrint.Avh4.Block
+        Text.PrettyPrint.Avh4.Indent
 
         -- json
         Json.Decode

terminal/src/Format.hs

@@ -9,10 +9,15 @@ where
 import AbsoluteSrcDir qualified
 import Control.Monad (filterM)
 import Data.ByteString qualified as BS
+import Data.ByteString.Builder qualified as B
+import Data.ByteString.Lazy qualified as BSL
 import Data.NonEmptyList qualified as NE
 import Directories qualified as Dirs
 import File qualified
+import Gren.Format qualified as Format
+import Gren.Format.Normalize qualified as Normalize
 import Gren.Outline qualified as Outline
+import Parse.Module qualified as Parse
 import Reporting qualified
 import Reporting.Doc qualified as D
 import Reporting.Exit qualified as Exit
@@ -20,6 +25,8 @@ import Reporting.Exit.Help qualified as Help
 import Reporting.Task qualified as Task
 import System.Directory qualified as Dir
 import System.FilePath ((</>))
+import System.FilePath qualified as FilePath
+import System.IO qualified
 
 -- FLAGS
 
@@ -91,7 +98,10 @@ resolveFile path =
     isDir <- Task.io (Dir.doesDirectoryExist path)
     if isDir
       then resolveFiles =<< Task.io (fmap (path </>) . filter (not . ignore) <$> Dir.listDirectory path)
-      else return [path]
+      else
+        if FilePath.takeExtension path == ".gren"
+          then return [path]
+          else return []
   where
     ignore dir =
       dir == ".gren"
@@ -106,8 +116,11 @@ format flags (Env inputs) =
     Stdin ->
       do
         original <- Task.io BS.getContents
-        let formatted = formatByteString original
-        Task.io $ BS.putStr formatted
+        case formatByteString original of
+          Nothing ->
+            error "TODO: report error"
+          Just formatted ->
+            Task.io $ B.hPutBuilder System.IO.stdout formatted
     Files paths ->
       do
         approved <-
@@ -144,15 +157,24 @@ formatExistingFile path =
   do
     putStr ("Formatting " ++ path)
     original <- File.readUtf8 path
-    let formatted = formatByteString original
-    if formatted == original
-      then do
-        Help.toStdout (" " <> D.dullwhite "(no changes)" <> "\n")
-      else do
-        File.writeUtf8 path formatted
-        Help.toStdout (" " <> D.green "CHANGED" <> "\n")
+    case formatByteString original of
+      Nothing ->
+        -- TODO: report error
+        Help.toStdout (" " <> D.red "ERROR: could not parse file" <> "\n")
+      Just builder ->
+        let formatted = B.toLazyByteString builder
+         in if formatted == BSL.fromStrict original
+              then do
+                Help.toStdout (" " <> D.dullwhite "(no changes)" <> "\n")
+              else do
+                B.writeFile path builder
+                Help.toStdout (" " <> D.green "CHANGED" <> "\n")
 
-formatByteString :: BS.ByteString -> BS.ByteString
+formatByteString :: BS.ByteString -> Maybe B.Builder
 formatByteString original =
-  -- TODO: implement actual formating
-  original
+  case Parse.fromByteString Parse.Application original of
+    Left _ ->
+      -- TODO: report error
+      Nothing
+    Right ast ->
+      Just (Format.toByteStringBuilder $ Normalize.normalize ast)

terminal/src/Main.hs

@@ -8,7 +8,7 @@ where
 import Bump qualified
 import Data.List qualified as List
 import Diff qualified
--- import qualified Format
+import Format qualified
 import Gren.Platform qualified as Platform
 import Gren.Version qualified as V
 import Init qualified
@@ -32,7 +32,7 @@ main =
       init,
       make,
       install,
-      -- format,
+      format,
       bump,
       diff,
       publish
@@ -266,7 +266,7 @@ diff =
    in Terminal.Command "diff" Uncommon details example diffArgs noFlags Diff.run
 
 -- FORMAT
-{-
+
 format :: Terminal.Command
 format =
   let details =
@@ -280,7 +280,6 @@ format =
           |-- onOff "yes" "Assume yes for all interactive prompts."
           |-- onOff "stdin" "Format stdin and write it to stdout."
    in Terminal.Command "format" Uncommon details example (zeroOrMore grenFileOrDirectory) formatFlags Format.run
-   -}
 
 -- HELPERS