gren-lang/compiler
1
1
Fork 0
mirror of https://github.com/gren-lang/compiler.git synced 2024-10-27 02:07:54 +03:00
Code Issues Actions Packages Projects Releases Wiki Activity

format: retain comments between top-level declarations

Browse Source
This commit is contained in:
Aaron VonderHaar 2022-11-13 19:40:59 -08:00
parent c0a4082c1a
commit 56df4e9c6b
17 changed files with 212 additions and 139 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
builder/src/Build.hs
View File

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

2
builder/src/Gren/Details.hs
View File

@ -491,7 +491,7 @@ crawlFile foreignDeps mvar pkg src docsStatus expectedName path =
do do
bytes <- File.readUtf8 path bytes <- File.readUtf8 path
case Parse.fromByteString (Parse.Package pkg) bytes of 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 do
deps <- crawlImports foreignDeps mvar pkg src imports deps <- crawlImports foreignDeps mvar pkg src imports
return (Just (SLocal docsStatus deps modul)) return (Just (SLocal docsStatus deps modul))

8
compiler/src/AST/Source.hs
View File

@ -37,6 +37,7 @@ where
import AST.SourceComments (Comment, GREN_COMMENT) import AST.SourceComments (Comment, GREN_COMMENT)
import AST.SourceComments qualified as SC import AST.SourceComments qualified as SC
import AST.Utils.Binop qualified as Binop import AST.Utils.Binop qualified as Binop
import Data.List.NonEmpty (NonEmpty)
import Data.Name (Name) import Data.Name (Name)
import Data.Name qualified as Name import Data.Name qualified as Name
import Gren.Float qualified as EF import Gren.Float qualified as EF
@ -58,9 +59,9 @@ data Expr_
| Array [Expr] | Array [Expr]
| Op Name | Op Name
| Negate Expr | Negate Expr
| Binops [(Expr, A.Located Name)] Expr | Binops [(Expr, [Comment], A.Located Name)] Expr
| Lambda [Pattern] Expr | Lambda [Pattern] Expr
| Call Expr [Expr] | Call Expr [([Comment], Expr)]
| If [(Expr, Expr)] Expr | If [(Expr, Expr)] Expr
| Let [A.Located Def] Expr | Let [A.Located Def] Expr
| Case Expr [(Pattern, Expr)] | Case Expr [(Pattern, Expr)]
@ -129,13 +130,14 @@ data Module = Module
_unions :: [(SourceOrder, A.Located Union)], _unions :: [(SourceOrder, A.Located Union)],
_aliases :: [(SourceOrder, A.Located Alias)], _aliases :: [(SourceOrder, A.Located Alias)],
_binops :: [A.Located Infix], _binops :: [A.Located Infix],
_topLevelComments :: [(SourceOrder, NonEmpty Comment)],
_headerComments :: SC.HeaderComments, _headerComments :: SC.HeaderComments,
_effects :: Effects _effects :: Effects
} }
deriving (Show) deriving (Show)
getName :: Module -> Name getName :: Module -> Name
getName (Module maybeName _ _ _ _ _ _ _ _ _) = getName (Module maybeName _ _ _ _ _ _ _ _ _ _) =
case maybeName of case maybeName of
Just (A.At _ name) -> Just (A.At _ name) ->
name name

6
compiler/src/Canonicalize/Environment/Local.hs
View File

@ -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 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 -> 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) _ _ _)) = let addDecl dict (A.At _ (Src.Value (A.At region name) _ _ _)) =
Dups.insert name region (Env.TopLevel region) dict Dups.insert name region (Env.TopLevel region) dict
in Dups.detect Error.DuplicateDecl $ in Dups.detect Error.DuplicateDecl $
@ -75,7 +75,7 @@ toEffectDups effects =
-- ADD TYPES -- ADD TYPES
addTypes :: Src.Module -> Env.Env -> Result i w Env.Env 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 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 addUnionDups dups (A.At _ (Src.Union (A.At region name) _ _)) = Dups.insert name region () dups
typeNameDups = typeNameDups =
@ -199,7 +199,7 @@ addFreeVars freeVars (A.At region tipe) =
-- ADD CTORS -- ADD CTORS
addCtors :: Src.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases) 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 do
unionInfo <- traverse (canonicalizeUnion env) (fmap snd unions) unionInfo <- traverse (canonicalizeUnion env) (fmap snd unions)
aliasInfo <- traverse (canonicalizeAlias env) (fmap snd aliases) aliasInfo <- traverse (canonicalizeAlias env) (fmap snd aliases)

6
compiler/src/Canonicalize/Expression.hs
View File

@ -93,7 +93,7 @@ canonicalize env (A.At region expression) =
Src.Call func args -> Src.Call func args ->
Can.Call Can.Call
<$> canonicalize env func <$> canonicalize env func
<*> traverse (canonicalize env) args <*> traverse (canonicalize env) (fmap snd args)
Src.If branches finally -> Src.If branches finally ->
Can.If Can.If
<$> traverse (canonicalizeIfBranch env) branches <$> traverse (canonicalizeIfBranch env) branches
@ -149,9 +149,9 @@ canonicalizeCaseBranch env (pattern, expr) =
-- CANONICALIZE BINOPS -- CANONICALIZE BINOPS
canonicalizeBinops :: A.Region -> Env.Env -> [(Src.Expr, A.Located Name.Name)] -> Src.Expr -> Result FreeLocals [W.Warning] Can.Expr canonicalizeBinops :: A.Region -> Env.Env -> [(Src.Expr, [Src.Comment], A.Located Name.Name)] -> Src.Expr -> Result FreeLocals [W.Warning] Can.Expr
canonicalizeBinops overallRegion env ops final = canonicalizeBinops overallRegion env ops final =
let canonicalizeHelp (expr, A.At region op) = let canonicalizeHelp (expr, _, A.At region op) =
(,) (,)
<$> canonicalize env expr <$> canonicalize env expr
<*> Env.findBinop region env op <*> Env.findBinop region env op

2
compiler/src/Canonicalize/Module.hs
View File

@ -35,7 +35,7 @@ type Result i w a =
-- MODULES -- MODULES
canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Result i [W.Warning] Can.Module 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 do
let values = fmap snd valuesWithSourceOrder let values = fmap snd valuesWithSourceOrder
let home = ModuleName.Canonical pkg (Src.getName modul) let home = ModuleName.Canonical pkg (Src.getName modul)

2
compiler/src/Gren/Compiler/Type.hs
View File

@ -87,7 +87,7 @@ encode tipe =
decoder :: D.Decoder () Type decoder :: D.Decoder () Type
decoder = decoder =
let parser = let parser =
P.specialize (\_ _ _ -> ()) (fromRawType . fst <$> Type.expression) P.specialize (\_ _ _ -> ()) (fromRawType . fst . fst <$> Type.expression)
in D.customString parser (\_ _ -> ()) in D.customString parser (\_ _ -> ())
fromRawType :: Src.Type -> Type fromRawType :: Src.Type -> Type

45
compiler/src/Gren/Format.hs
View File

@ -34,15 +34,15 @@ toByteStringBuilder module_ =
-- Data structure extras -- Data structure extras
-- --
repair :: [(a, b)] -> a -> (a, [(b, a)]) repair3 :: [(a, b, c)] -> a -> (a, [(b, c, a)])
repair [] single = (single, []) repair3 [] single = (single, [])
repair ((first, b) : rest) final = repair3 ((first, b, c) : rest) final =
(first, repairHelp b rest final) (first, repair3Help b c rest final)
repairHelp :: b -> [(a, b)] -> a -> [(b, a)] repair3Help :: b -> c -> [(a, b, c)] -> a -> [(b, c, a)]
repairHelp b [] a = [(b, a)] repair3Help b c [] a = [(b, c, a)]
repairHelp b1 ((a1, b2) : rest) a2 = repair3Help b1 c1 ((a1, b2, c2) : rest) a2 =
(b1, a1) : repairHelp b2 rest a2 (b1, c1, a1) : repair3Help b2 c2 rest a2
-- --
-- Helper functions -- Helper functions
@ -158,10 +158,15 @@ formatComment = \case
in Block.mustBreak $ Block.string7 open <> utf8 text in Block.mustBreak $ Block.string7 open <> utf8 text
formatCommentBlock :: [Src.Comment] -> Maybe Block formatCommentBlock :: [Src.Comment] -> Maybe Block
formatCommentBlock = fmap spaceOrStack . nonEmpty . fmap formatComment formatCommentBlock =
fmap formatCommentBlockNonEmpty . nonEmpty
formatCommentBlockNonEmpty :: NonEmpty Src.Comment -> Block
formatCommentBlockNonEmpty =
spaceOrStack . fmap formatComment
formatModule :: Src.Module -> Block formatModule :: Src.Module -> Block
formatModule (Src.Module moduleName exports docs imports values unions aliases binops comments effects) = formatModule (Src.Module moduleName exports docs imports values unions aliases binops topLevelComments comments effects) =
Block.stack $ Block.stack $
NonEmpty.fromList $ NonEmpty.fromList $
catMaybes catMaybes
@ -195,6 +200,7 @@ formatModule (Src.Module moduleName exports docs imports values unions aliases b
[ fmap (formatWithDocComment valueName formatValue . A.toValue) <$> values, [ fmap (formatWithDocComment valueName formatValue . A.toValue) <$> values,
fmap (formatWithDocComment unionName formatUnion . A.toValue) <$> unions, fmap (formatWithDocComment unionName formatUnion . A.toValue) <$> unions,
fmap (formatWithDocComment aliasName formatAlias . A.toValue) <$> aliases, fmap (formatWithDocComment aliasName formatAlias . A.toValue) <$> aliases,
fmap formatTopLevelCommentBlock <$> topLevelComments,
case effects of case effects of
Src.NoEffects -> [] Src.NoEffects -> []
Src.Ports ports _ -> fmap (formatWithDocComment portName formatPort) <$> ports Src.Ports ports _ -> fmap (formatWithDocComment portName formatPort) <$> ports
@ -242,6 +248,13 @@ formatModule (Src.Module moduleName exports docs imports values unions aliases b
Block.stack $ fmap (formatInfix . A.toValue) some Block.stack $ fmap (formatInfix . A.toValue) some
] ]
formatTopLevelCommentBlock :: NonEmpty Src.Comment -> Block
formatTopLevelCommentBlock comments =
Block.stack
[ Block.blankLine,
formatCommentBlockNonEmpty comments
]
formatEffectsModuleWhereClause :: Src.Effects -> Maybe Block formatEffectsModuleWhereClause :: Src.Effects -> Maybe Block
formatEffectsModuleWhereClause = \case formatEffectsModuleWhereClause = \case
Src.NoEffects -> Nothing Src.NoEffects -> Nothing
@ -493,7 +506,7 @@ formatExpr = \case
formatExpr $ formatExpr $
A.toValue expr A.toValue expr
Src.Binops postfixOps final -> Src.Binops postfixOps final ->
let (first, rest) = repair postfixOps final let (first, rest) = repair3 postfixOps final
in ExpressionContainsInfixOps $ in ExpressionContainsInfixOps $
spaceOrIndentForce forceMultiline $ spaceOrIndentForce forceMultiline $
exprParensProtectInfixOps (formatExpr $ A.toValue first) exprParensProtectInfixOps (formatExpr $ A.toValue first)
@ -501,8 +514,9 @@ formatExpr = \case
where where
-- for now we just use multiline formatting for specific operators, -- for now we just use multiline formatting for specific operators,
-- since we don't yet track where the linebreaks are in the source -- since we don't yet track where the linebreaks are in the source
forceMultiline = any (opForcesMultiline . A.toValue . snd) postfixOps forceMultiline = any (opForcesMultiline . opFromPair) postfixOps
formatPair (op, expr) = opFromPair (_, _, name) = A.toValue name
formatPair (commentsBeforeOp, op, expr) =
Block.prefix Block.prefix
4 4
(utf8 (A.toValue op) <> Block.space) (utf8 (A.toValue op) <> Block.space)
@ -526,7 +540,10 @@ formatExpr = \case
ExpressionContainsSpaces $ ExpressionContainsSpaces $
spaceOrIndent $ spaceOrIndent $
exprParensProtectInfixOps (formatExpr $ A.toValue fn) exprParensProtectInfixOps (formatExpr $ A.toValue fn)
:| fmap (exprParensProtectSpaces . formatExpr . A.toValue) args :| fmap formatArg args
where
formatArg (commentsBefore, arg) =
exprParensProtectSpaces (formatExpr $ A.toValue arg)
Src.If [] else_ -> Src.If [] else_ ->
formatExpr $ A.toValue else_ formatExpr $ A.toValue else_
Src.If (if_ : elseifs) else_ -> Src.If (if_ : elseifs) else_ ->

30
compiler/src/Parse/Declaration.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-- Temporary while implementing gren format -- Temporary while implementing gren format
{-# OPTIONS_GHC -Wno-error=unused-do-bind #-} {-# OPTIONS_GHC -Wno-error=unused-do-bind #-}
{-# OPTIONS_GHC -Wno-error=unused-matches #-}
module Parse.Declaration module Parse.Declaration
( Decl (..), ( Decl (..),
@ -11,6 +12,7 @@ where
import AST.Source qualified as Src import AST.Source qualified as Src
import AST.Utils.Binop qualified as Binop import AST.Utils.Binop qualified as Binop
import Data.List.NonEmpty (NonEmpty)
import Data.Name qualified as Name import Data.Name qualified as Name
import Parse.Expression qualified as Expr import Parse.Expression qualified as Expr
import Parse.Keyword qualified as Keyword import Parse.Keyword qualified as Keyword
@ -32,8 +34,9 @@ data Decl
| Union (Maybe Src.DocComment) (A.Located Src.Union) | Union (Maybe Src.DocComment) (A.Located Src.Union)
| Alias (Maybe Src.DocComment) (A.Located Src.Alias) | Alias (Maybe Src.DocComment) (A.Located Src.Alias)
| Port (Maybe Src.DocComment) Src.Port | Port (Maybe Src.DocComment) Src.Port
| TopLevelComments (NonEmpty Src.Comment)
declaration :: Space.Parser E.Decl Decl declaration :: Space.Parser E.Decl (Decl, [Src.Comment])
declaration = declaration =
do do
maybeDocs <- chompDocComment maybeDocs <- chompDocComment
@ -60,7 +63,7 @@ chompDocComment =
-- DEFINITION and ANNOTATION -- DEFINITION and ANNOTATION
valueDecl :: Maybe Src.DocComment -> A.Position -> Space.Parser E.Decl Decl valueDecl :: Maybe Src.DocComment -> A.Position -> Space.Parser E.Decl (Decl, [Src.Comment])
valueDecl maybeDocs start = valueDecl maybeDocs start =
do do
name <- Var.lower E.DeclStart name <- Var.lower E.DeclStart
@ -73,7 +76,7 @@ valueDecl maybeDocs start =
[ do [ do
word1 0x3A {-:-} E.DeclDefEquals word1 0x3A {-:-} E.DeclDefEquals
Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentType Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentType
(tipe, _) <- specialize E.DeclDefType Type.expression ((tipe, commentsAfterTipe), _) <- specialize E.DeclDefType Type.expression
Space.checkFreshLine E.DeclDefNameRepeat Space.checkFreshLine E.DeclDefNameRepeat
defName <- chompMatchingName name defName <- chompMatchingName name
Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals
@ -81,7 +84,7 @@ valueDecl maybeDocs start =
chompDefArgsAndBody maybeDocs start (A.at start end name) Nothing [] chompDefArgsAndBody maybeDocs start (A.at start end name) Nothing []
] ]
chompDefArgsAndBody :: Maybe Src.DocComment -> A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> Space.Parser E.DeclDef Decl chompDefArgsAndBody :: Maybe Src.DocComment -> A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> Space.Parser E.DeclDef (Decl, [Src.Comment])
chompDefArgsAndBody maybeDocs start name tipe revArgs = chompDefArgsAndBody maybeDocs start name tipe revArgs =
oneOf oneOf
E.DeclDefEquals E.DeclDefEquals
@ -92,10 +95,10 @@ chompDefArgsAndBody maybeDocs start name tipe revArgs =
do do
word1 0x3D {-=-} E.DeclDefEquals word1 0x3D {-=-} E.DeclDefEquals
Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentBody Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentBody
(body, end) <- specialize E.DeclDefBody Expr.expression ((body, commentsAfter), end) <- specialize E.DeclDefBody Expr.expression
let value = Src.Value name (reverse revArgs) body tipe let value = Src.Value name (reverse revArgs) body tipe
let avalue = A.at start end value let avalue = A.at start end value
return (Value maybeDocs avalue, end) return ((Value maybeDocs avalue, commentsAfter), end)
] ]
chompMatchingName :: Name.Name -> Parser E.DeclDef (A.Located Name.Name) chompMatchingName :: Name.Name -> Parser E.DeclDef (A.Located Name.Name)
@ -115,7 +118,7 @@ chompMatchingName expectedName =
-- TYPE DECLARATIONS -- TYPE DECLARATIONS
typeDecl :: Maybe Src.DocComment -> A.Position -> Space.Parser E.Decl Decl typeDecl :: Maybe Src.DocComment -> A.Position -> Space.Parser E.Decl (Decl, [Src.Comment])
typeDecl maybeDocs start = typeDecl maybeDocs start =
inContext E.DeclType (Keyword.type_ E.DeclStart) $ inContext E.DeclType (Keyword.type_ E.DeclStart) $
do do
@ -126,16 +129,17 @@ typeDecl maybeDocs start =
do do
Space.chompAndCheckIndent E.AliasSpace E.AliasIndentEquals Space.chompAndCheckIndent E.AliasSpace E.AliasIndentEquals
(name, args) <- chompAliasNameToEquals (name, args) <- chompAliasNameToEquals
(tipe, end) <- specialize E.AliasBody Type.expression ((tipe, commentsAfterTipe), end) <- specialize E.AliasBody Type.expression
let alias = A.at start end (Src.Alias name args tipe) let alias = A.at start end (Src.Alias name args tipe)
return (Alias maybeDocs alias, end), return ((Alias maybeDocs alias, commentsAfterTipe), end),
specialize E.DT_Union $ specialize E.DT_Union $
do do
(name, args) <- chompCustomNameToEquals (name, args) <- chompCustomNameToEquals
(firstVariant, firstEnd) <- Type.variant (firstVariant, firstEnd) <- Type.variant
(variants, end) <- chompVariants [firstVariant] firstEnd (variants, end) <- chompVariants [firstVariant] firstEnd
let union = A.at start end (Src.Union name args variants) let union = A.at start end (Src.Union name args variants)
return (Union maybeDocs union, end) let commentsAfter = [] -- TODO: implement this throughout chompVariants and Type.variant
return ((Union maybeDocs union, commentsAfter), end)
] ]
-- TYPE ALIASES -- TYPE ALIASES
@ -198,7 +202,7 @@ chompVariants variants end =
-- PORT -- PORT
portDecl :: Maybe Src.DocComment -> Space.Parser E.Decl Decl portDecl :: Maybe Src.DocComment -> Space.Parser E.Decl (Decl, [Src.Comment])
portDecl maybeDocs = portDecl maybeDocs =
inContext E.Port (Keyword.port_ E.DeclStart) $ inContext E.Port (Keyword.port_ E.DeclStart) $
do do
@ -207,9 +211,9 @@ portDecl maybeDocs =
Space.chompAndCheckIndent E.PortSpace E.PortIndentColon Space.chompAndCheckIndent E.PortSpace E.PortIndentColon
word1 0x3A {-:-} E.PortColon word1 0x3A {-:-} E.PortColon
Space.chompAndCheckIndent E.PortSpace E.PortIndentType Space.chompAndCheckIndent E.PortSpace E.PortIndentType
(tipe, end) <- specialize E.PortType Type.expression ((tipe, commentsAfterTipe), end) <- specialize E.PortType Type.expression
return return
( Port maybeDocs (Src.Port name tipe), ( (Port maybeDocs (Src.Port name tipe), commentsAfterTipe),
end end
) )

107
compiler/src/Parse/Expression.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-- Temporary while implementing gren format -- Temporary while implementing gren format
{-# OPTIONS_GHC -Wno-error=unused-do-bind #-} {-# OPTIONS_GHC -Wno-error=unused-do-bind #-}
{-# OPTIONS_GHC -Wno-error=unused-matches #-}
module Parse.Expression module Parse.Expression
( expression, ( expression,
@ -79,25 +80,25 @@ parenthesizedExpr start@(A.Position row col) =
word1 0x29 {-)-} E.ParenthesizedOperatorClose word1 0x29 {-)-} E.ParenthesizedOperatorClose
addEnd start (Src.Op op), addEnd start (Src.Op op),
do do
(comments2, (expr, end)) <- ((expr, commentsAfter), end) <-
specialize E.ParenthesizedExpr $ specialize E.ParenthesizedExpr $
do do
negatedExpr@(A.At (A.Region _ end) _) <- term negatedExpr@(A.At (A.Region _ end) _) <- term
comments2_ <- Space.chomp E.Space commentsAfterTerm <- Space.chomp E.Space
let exprStart = A.Position row (col + 2) let exprStart = A.Position row (col + 2)
let expr = A.at exprStart end (Src.Negate negatedExpr) let expr = A.at exprStart end (Src.Negate negatedExpr)
(,) comments2_ <$> chompExprEnd exprStart (State [] expr [] end) chompExprEnd exprStart (State [] expr [] end commentsAfterTerm)
Space.checkIndent end E.ParenthesizedIndentEnd Space.checkIndent end E.ParenthesizedIndentEnd
word1 0x29 {-)-} E.ParenthesizedOperatorClose word1 0x29 {-)-} E.ParenthesizedOperatorClose
addEnd start (Src.Parens comments1 expr comments2) addEnd start (Src.Parens comments1 expr commentsAfter)
] ]
else do else do
word1 0x29 {-)-} E.ParenthesizedOperatorClose word1 0x29 {-)-} E.ParenthesizedOperatorClose
addEnd start (Src.Op op), addEnd start (Src.Op op),
do do
(expr, _) <- specialize E.ParenthesizedExpr expression ((expr, commentsAfter), _) <- specialize E.ParenthesizedExpr expression
word1 0x29 {-)-} E.ParenthesizedEnd word1 0x29 {-)-} E.ParenthesizedEnd
addEnd start (Src.Parens comments1 expr []) addEnd start (Src.Parens comments1 expr commentsAfter)
] ]
accessor :: A.Position -> Parser E.Expr Src.Expr accessor :: A.Position -> Parser E.Expr Src.Expr
@ -145,7 +146,7 @@ array start =
oneOf oneOf
E.ArrayOpen E.ArrayOpen
[ do [ do
(entry, end) <- specialize E.ArrayExpr expression ((entry, commentsAfterEntry), end) <- specialize E.ArrayExpr expression
Space.checkIndent end E.ArrayIndentEnd Space.checkIndent end E.ArrayIndentEnd
chompArrayEnd start [entry], chompArrayEnd start [entry],
do do
@ -160,7 +161,7 @@ chompArrayEnd start entries =
[ do [ do
word1 0x2C {-,-} E.ArrayEnd word1 0x2C {-,-} E.ArrayEnd
Space.chompAndCheckIndent E.ArraySpace E.ArrayIndentExpr Space.chompAndCheckIndent E.ArraySpace E.ArrayIndentExpr
(entry, end) <- specialize E.ArrayExpr expression ((entry, commentsAfterEntry), end) <- specialize E.ArrayExpr expression
Space.checkIndent end E.ArrayIndentEnd Space.checkIndent end E.ArrayIndentEnd
chompArrayEnd start (entry : entries), chompArrayEnd start (entry : entries),
do do
@ -194,7 +195,7 @@ record start =
do do
word1 0x3D {-=-} E.RecordEquals word1 0x3D {-=-} E.RecordEquals
Space.chompAndCheckIndent E.RecordSpace E.RecordIndentExpr Space.chompAndCheckIndent E.RecordSpace E.RecordIndentExpr
(value, end) <- specialize E.RecordExpr expression ((value, commentsAfterValue), end) <- specialize E.RecordExpr expression
Space.checkIndent end E.RecordIndentEnd Space.checkIndent end E.RecordIndentEnd
case expr of case expr of
A.At exprRegion (Src.Var Src.LowVar name) -> do A.At exprRegion (Src.Var Src.LowVar name) -> do
@ -229,13 +230,13 @@ chompField =
Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals
word1 0x3D {-=-} E.RecordEquals word1 0x3D {-=-} E.RecordEquals
Space.chompAndCheckIndent E.RecordSpace E.RecordIndentExpr Space.chompAndCheckIndent E.RecordSpace E.RecordIndentExpr
(value, end) <- specialize E.RecordExpr expression ((value, commentsAfter), end) <- specialize E.RecordExpr expression
Space.checkIndent end E.RecordIndentEnd Space.checkIndent end E.RecordIndentEnd
return (key, value) return (key, value)
-- EXPRESSIONS -- EXPRESSIONS
expression :: Space.Parser E.Expr Src.Expr expression :: Space.Parser E.Expr (Src.Expr, [Src.Comment])
expression = expression =
do do
start <- getPosition start <- getPosition
@ -248,27 +249,28 @@ expression =
do do
expr <- possiblyNegativeTerm start expr <- possiblyNegativeTerm start
end <- getPosition end <- getPosition
Space.chomp E.Space commentsAfter <- Space.chomp E.Space
chompExprEnd start (State [] expr [] end) chompExprEnd start (State [] expr [] end commentsAfter)
] ]
data State = State data State = State
{ _ops :: ![(Src.Expr, A.Located Name.Name)], { _ops :: ![(Src.Expr, [Src.Comment], A.Located Name.Name)],
_expr :: !Src.Expr, _expr :: !Src.Expr,
_args :: ![Src.Expr], _args :: ![([Src.Comment], Src.Expr)],
_end :: !A.Position _end :: !A.Position,
_commentsAfter :: [Src.Comment]
} }
chompExprEnd :: A.Position -> State -> Space.Parser E.Expr Src.Expr chompExprEnd :: A.Position -> State -> Space.Parser E.Expr (Src.Expr, [Src.Comment])
chompExprEnd start (State ops expr args end) = chompExprEnd start (State ops expr args end commentsBefore) =
oneOfWithFallback oneOfWithFallback
[ -- argument [ -- argument
do do
Space.checkIndent end E.Start Space.checkIndent end E.Start
arg <- term arg <- term
newEnd <- getPosition newEnd <- getPosition
Space.chomp E.Space commentsAfter <- Space.chomp E.Space
chompExprEnd start (State ops expr (arg : args) newEnd), chompExprEnd start (State ops expr ((commentsBefore, arg) : args) newEnd commentsAfter),
-- operator -- operator
do do
Space.checkIndent end E.Start Space.checkIndent end E.Start
@ -280,9 +282,9 @@ chompExprEnd start (State ops expr args end) =
do do
negatedExpr <- term negatedExpr <- term
newEnd <- getPosition newEnd <- getPosition
Space.chomp E.Space commentsAfter <- Space.chomp E.Space
let arg = A.at opStart newEnd (Src.Negate negatedExpr) let arg = A.at opStart newEnd (Src.Negate negatedExpr)
chompExprEnd start (State ops expr (arg : args) newEnd) chompExprEnd start (State ops expr ((commentsBefore, arg) : args) newEnd commentsAfter)
else else
let err = E.OperatorRight opName let err = E.OperatorRight opName
in oneOf in oneOf
@ -291,12 +293,12 @@ chompExprEnd start (State ops expr args end) =
do do
newExpr <- possiblyNegativeTerm newStart newExpr <- possiblyNegativeTerm newStart
newEnd <- getPosition newEnd <- getPosition
Space.chomp E.Space commentsAfter <- Space.chomp E.Space
let newOps = (toCall expr args, op) : ops let newOps = (toCall expr args, commentsBefore, op) : ops
chompExprEnd start (State newOps newExpr [] newEnd), chompExprEnd start (State newOps newExpr [] newEnd commentsAfter),
-- final term -- final term
do do
(newLast, newEnd) <- ((newLast, commentsAfter), newEnd) <-
oneOf oneOf
err err
[ let_ newStart, [ let_ newStart,
@ -304,19 +306,21 @@ chompExprEnd start (State ops expr args end) =
if_ newStart, if_ newStart,
function newStart function newStart
] ]
let newOps = (toCall expr args, op) : ops let newOps = (toCall expr args, commentsBefore, op) : ops
let finalExpr = Src.Binops (reverse newOps) newLast let finalExpr = Src.Binops (reverse newOps) newLast
return (A.at start newEnd finalExpr, newEnd) return ((A.at start newEnd finalExpr, commentsAfter), newEnd)
] ]
] ]
-- done -- done
( case ops of ( case ops of
[] -> [] ->
( toCall expr args, ( (toCall expr args, commentsBefore),
end end
) )
_ -> _ ->
( A.at start end (Src.Binops (reverse ops) (toCall expr args)), ( ( A.at start end (Src.Binops (reverse ops) (toCall expr args)),
commentsBefore
),
end end
) )
) )
@ -332,30 +336,30 @@ possiblyNegativeTerm start =
term term
] ]
toCall :: Src.Expr -> [Src.Expr] -> Src.Expr toCall :: Src.Expr -> [([Src.Comment], Src.Expr)] -> Src.Expr
toCall func revArgs = toCall func revArgs =
case revArgs of case revArgs of
[] -> [] ->
func func
lastArg : _ -> (_, lastArg) : _ ->
A.merge func lastArg (Src.Call func (reverse revArgs)) A.merge func lastArg (Src.Call func (reverse revArgs))
-- IF EXPRESSION -- IF EXPRESSION
if_ :: A.Position -> Space.Parser E.Expr Src.Expr if_ :: A.Position -> Space.Parser E.Expr (Src.Expr, [Src.Comment])
if_ start = if_ start =
inContext E.If (Keyword.if_ E.Start) $ inContext E.If (Keyword.if_ E.Start) $
chompIfEnd start [] chompIfEnd start []
chompIfEnd :: A.Position -> [(Src.Expr, Src.Expr)] -> Space.Parser E.If Src.Expr chompIfEnd :: A.Position -> [(Src.Expr, Src.Expr)] -> Space.Parser E.If (Src.Expr, [Src.Comment])
chompIfEnd start branches = chompIfEnd start branches =
do do
Space.chompAndCheckIndent E.IfSpace E.IfIndentCondition Space.chompAndCheckIndent E.IfSpace E.IfIndentCondition
(condition, condEnd) <- specialize E.IfCondition expression ((condition, commentsAfterCondition), condEnd) <- specialize E.IfCondition expression
Space.checkIndent condEnd E.IfIndentThen Space.checkIndent condEnd E.IfIndentThen
Keyword.then_ E.IfThen Keyword.then_ E.IfThen
Space.chompAndCheckIndent E.IfSpace E.IfIndentThenBranch Space.chompAndCheckIndent E.IfSpace E.IfIndentThenBranch
(thenBranch, thenEnd) <- specialize E.IfThenBranch expression ((thenBranch, commentsAfterThen), thenEnd) <- specialize E.IfThenBranch expression
Space.checkIndent thenEnd E.IfIndentElse Space.checkIndent thenEnd E.IfIndentElse
Keyword.else_ E.IfElse Keyword.else_ E.IfElse
Space.chompAndCheckIndent E.IfSpace E.IfIndentElseBranch Space.chompAndCheckIndent E.IfSpace E.IfIndentElseBranch
@ -366,14 +370,14 @@ chompIfEnd start branches =
Keyword.if_ E.IfElseBranchStart Keyword.if_ E.IfElseBranchStart
chompIfEnd start newBranches, chompIfEnd start newBranches,
do do
(elseBranch, elseEnd) <- specialize E.IfElseBranch expression ((elseBranch, commentsAfterElse), elseEnd) <- specialize E.IfElseBranch expression
let ifExpr = Src.If (reverse newBranches) elseBranch let ifExpr = Src.If (reverse newBranches) elseBranch
return (A.at start elseEnd ifExpr, elseEnd) return ((A.at start elseEnd ifExpr, commentsAfterElse), elseEnd)
] ]
-- LAMBDA EXPRESSION -- LAMBDA EXPRESSION
function :: A.Position -> Space.Parser E.Expr Src.Expr function :: A.Position -> Space.Parser E.Expr (Src.Expr, [Src.Comment])
function start = function start =
inContext E.Func (word1 0x5C {-\-} E.Start) $ inContext E.Func (word1 0x5C {-\-} E.Start) $
do do
@ -382,9 +386,9 @@ function start =
Space.chompAndCheckIndent E.FuncSpace E.FuncIndentArrow Space.chompAndCheckIndent E.FuncSpace E.FuncIndentArrow
revArgs <- chompArgs [arg] revArgs <- chompArgs [arg]
Space.chompAndCheckIndent E.FuncSpace E.FuncIndentBody Space.chompAndCheckIndent E.FuncSpace E.FuncIndentBody
(body, end) <- specialize E.FuncBody expression ((body, commentsAfterBody), end) <- specialize E.FuncBody expression
let funcExpr = Src.Lambda (reverse revArgs) body let funcExpr = Src.Lambda (reverse revArgs) body
return (A.at start end funcExpr, end) return ((A.at start end funcExpr, commentsAfterBody), end)
chompArgs :: [Src.Pattern] -> Parser E.Func [Src.Pattern] chompArgs :: [Src.Pattern] -> Parser E.Func [Src.Pattern]
chompArgs revArgs = chompArgs revArgs =
@ -401,12 +405,12 @@ chompArgs revArgs =
-- CASE EXPRESSIONS -- CASE EXPRESSIONS
case_ :: A.Position -> Space.Parser E.Expr Src.Expr case_ :: A.Position -> Space.Parser E.Expr (Src.Expr, [Src.Comment])
case_ start = case_ start =
inContext E.Case (Keyword.case_ E.Start) $ inContext E.Case (Keyword.case_ E.Start) $
do do
Space.chompAndCheckIndent E.CaseSpace E.CaseIndentExpr Space.chompAndCheckIndent E.CaseSpace E.CaseIndentExpr
(expr, exprEnd) <- specialize E.CaseExpr expression ((expr, commentsAfterExpr), exprEnd) <- specialize E.CaseExpr expression
Space.checkIndent exprEnd E.CaseIndentOf Space.checkIndent exprEnd E.CaseIndentOf
Keyword.of_ E.CaseOf Keyword.of_ E.CaseOf
Space.chompAndCheckIndent E.CaseSpace E.CaseIndentPattern Space.chompAndCheckIndent E.CaseSpace E.CaseIndentPattern
@ -414,8 +418,9 @@ case_ start =
do do
(firstBranch, firstEnd) <- chompBranch (firstBranch, firstEnd) <- chompBranch
(branches, end) <- chompCaseEnd [firstBranch] firstEnd (branches, end) <- chompCaseEnd [firstBranch] firstEnd
let commentsAfter = [] -- TODO: once indentation sensitivity for expression and case branch comments is implemented, then there will be additional comments to capture here
return return
( A.at start end (Src.Case expr branches), ( (A.at start end (Src.Case expr branches), commentsAfter),
end end
) )
@ -426,7 +431,7 @@ chompBranch =
Space.checkIndent patternEnd E.CaseIndentArrow Space.checkIndent patternEnd E.CaseIndentArrow
word2 0x2D 0x3E {-->-} E.CaseArrow word2 0x2D 0x3E {-->-} E.CaseArrow
Space.chompAndCheckIndent E.CaseSpace E.CaseIndentBranch Space.chompAndCheckIndent E.CaseSpace E.CaseIndentBranch
(branchExpr, end) <- specialize E.CaseBranch expression ((branchExpr, commentsAfterBranch), end) <- specialize E.CaseBranch expression
return ((pattern, branchExpr), end) return ((pattern, branchExpr), end)
chompCaseEnd :: [(Src.Pattern, Src.Expr)] -> A.Position -> Space.Parser E.Case [(Src.Pattern, Src.Expr)] chompCaseEnd :: [(Src.Pattern, Src.Expr)] -> A.Position -> Space.Parser E.Case [(Src.Pattern, Src.Expr)]
@ -441,7 +446,7 @@ chompCaseEnd branches end =
-- LET EXPRESSION -- LET EXPRESSION
let_ :: A.Position -> Space.Parser E.Expr Src.Expr let_ :: A.Position -> Space.Parser E.Expr (Src.Expr, [Src.Comment])
let_ start = let_ start =
inContext E.Let (Keyword.let_ E.Start) $ inContext E.Let (Keyword.let_ E.Start) $
do do
@ -457,9 +462,9 @@ let_ start =
Space.checkIndent defsEnd E.LetIndentIn Space.checkIndent defsEnd E.LetIndentIn
Keyword.in_ E.LetIn Keyword.in_ E.LetIn
Space.chompAndCheckIndent E.LetSpace E.LetIndentBody Space.chompAndCheckIndent E.LetSpace E.LetIndentBody
(body, end) <- specialize E.LetBody expression ((body, commentsAfter), end) <- specialize E.LetBody expression
return return
( A.at start end (Src.Let defs body), ( (A.at start end (Src.Let defs body), commentsAfter),
end end
) )
@ -497,7 +502,7 @@ definition =
[ do [ do
word1 0x3A {-:-} E.DefEquals word1 0x3A {-:-} E.DefEquals
Space.chompAndCheckIndent E.DefSpace E.DefIndentType Space.chompAndCheckIndent E.DefSpace E.DefIndentType
(tipe, _) <- specialize E.DefType Type.expression ((tipe, commentsAfterTipe), _) <- specialize E.DefType Type.expression
Space.checkAligned E.DefAlignment Space.checkAligned E.DefAlignment
defName <- chompMatchingName name defName <- chompMatchingName name
Space.chompAndCheckIndent E.DefSpace E.DefIndentEquals Space.chompAndCheckIndent E.DefSpace E.DefIndentEquals
@ -516,7 +521,7 @@ chompDefArgsAndBody start name tipe revArgs =
do do
word1 0x3D {-=-} E.DefEquals word1 0x3D {-=-} E.DefEquals
Space.chompAndCheckIndent E.DefSpace E.DefIndentBody Space.chompAndCheckIndent E.DefSpace E.DefIndentBody
(body, end) <- specialize E.DefBody expression ((body, commentsAfterBody), end) <- specialize E.DefBody expression
return return
( A.at start end (Src.Define name (reverse revArgs) body tipe), ( A.at start end (Src.Define name (reverse revArgs) body tipe),
end end
@ -549,5 +554,5 @@ destructure =
Space.chompAndCheckIndent E.DestructSpace E.DestructIndentEquals Space.chompAndCheckIndent E.DestructSpace E.DestructIndentEquals
word1 0x3D {-=-} E.DestructEquals word1 0x3D {-=-} E.DestructEquals
Space.chompAndCheckIndent E.DestructSpace E.DestructIndentBody Space.chompAndCheckIndent E.DestructSpace E.DestructIndentBody
(expr, end) <- specialize E.DestructBody expression ((expr, commentsAfter), end) <- specialize E.DestructBody expression
return (A.at start end (Src.Destruct pattern expr), end) return (A.at start end (Src.Destruct pattern expr), end)

49
compiler/src/Parse/Module.hs
View File

@ -16,6 +16,7 @@ where
import AST.Source qualified as Src import AST.Source qualified as Src
import AST.SourceComments qualified as SC import AST.SourceComments qualified as SC
import Data.ByteString qualified as BS import Data.ByteString qualified as BS
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import Data.Name qualified as Name import Data.Name qualified as Name
import Gren.Compiler.Imports qualified as Imports import Gren.Compiler.Imports qualified as Imports
import Gren.Package qualified as Pkg import Gren.Package qualified as Pkg
@ -77,15 +78,15 @@ chompModule projectType =
checkModule :: ProjectType -> Module -> Either E.Error Src.Module checkModule :: ProjectType -> Module -> Either E.Error Src.Module
checkModule projectType (Module maybeHeader imports infixes decls) = checkModule projectType (Module maybeHeader imports infixes decls) =
let (values, unions, aliases, ports) = categorizeDecls [] [] [] [] 0 decls let (values, unions, aliases, ports, topLevelComments) = categorizeDecls [] [] [] [] [] 0 decls
in case maybeHeader of in case maybeHeader of
Just (Header name effects exports docs comments) -> Just (Header name effects exports docs comments) ->
Src.Module (Just name) exports (toDocs docs decls) imports values unions aliases infixes comments Src.Module (Just name) exports (toDocs docs decls) imports values unions aliases infixes topLevelComments comments
<$> checkEffects projectType ports effects <$> checkEffects projectType ports effects
Nothing -> Nothing ->
let comments = SC.HeaderComments [] [] [] [] [] [] let comments = SC.HeaderComments [] [] [] [] [] []
in Right $ in Right $
Src.Module Nothing (A.At A.one Src.Open) (Src.NoDocs A.one) imports values unions aliases infixes comments $ Src.Module Nothing (A.At A.one Src.Open) (Src.NoDocs A.one) imports values unions aliases infixes topLevelComments comments $
case ports of case ports of
[] -> Src.NoEffects [] -> Src.NoEffects
_ : _ -> Src.Ports ports (SC.PortsComments []) _ : _ -> Src.Ports ports (SC.PortsComments [])
@ -121,23 +122,26 @@ categorizeDecls ::
[(Src.SourceOrder, A.Located Src.Union)] -> [(Src.SourceOrder, A.Located Src.Union)] ->
[(Src.SourceOrder, A.Located Src.Alias)] -> [(Src.SourceOrder, A.Located Src.Alias)] ->
[(Src.SourceOrder, Src.Port)] -> [(Src.SourceOrder, Src.Port)] ->
[(Src.SourceOrder, NonEmpty Src.Comment)] ->
Src.SourceOrder -> Src.SourceOrder ->
[Decl.Decl] -> [Decl.Decl] ->
( [(Src.SourceOrder, A.Located Src.Value)], ( [(Src.SourceOrder, A.Located Src.Value)],
[(Src.SourceOrder, A.Located Src.Union)], [(Src.SourceOrder, A.Located Src.Union)],
[(Src.SourceOrder, A.Located Src.Alias)], [(Src.SourceOrder, A.Located Src.Alias)],
[(Src.SourceOrder, Src.Port)] [(Src.SourceOrder, Src.Port)],
[(Src.SourceOrder, NonEmpty Src.Comment)]
) )
categorizeDecls values unions aliases ports index decls = categorizeDecls values unions aliases ports topLevelComments index decls =
case decls of case decls of
[] -> [] ->
(values, unions, aliases, ports) (values, unions, aliases, ports, topLevelComments)
decl : otherDecls -> decl : otherDecls ->
case decl of case decl of
Decl.Value _ value -> categorizeDecls ((index, value) : values) unions aliases ports (index + 1) otherDecls Decl.Value _ value -> categorizeDecls ((index, value) : values) unions aliases ports topLevelComments (index + 1) otherDecls
Decl.Union _ union -> categorizeDecls values ((index, union) : unions) aliases ports (index + 1) otherDecls Decl.Union _ union -> categorizeDecls values ((index, union) : unions) aliases ports topLevelComments (index + 1) otherDecls
Decl.Alias _ alias -> categorizeDecls values unions ((index, alias) : aliases) ports (index + 1) otherDecls Decl.Alias _ alias -> categorizeDecls values unions ((index, alias) : aliases) ports topLevelComments (index + 1) otherDecls
Decl.Port _ port_ -> categorizeDecls values unions aliases ((index, port_) : ports) (index + 1) otherDecls Decl.Port _ port_ -> categorizeDecls values unions aliases ((index, port_) : ports) topLevelComments (index + 1) otherDecls
Decl.TopLevelComments comments -> categorizeDecls values unions aliases ports ((index, comments) : topLevelComments) (index + 1) otherDecls
-- TO DOCS -- TO DOCS
@ -145,21 +149,22 @@ toDocs :: Either A.Region Src.DocComment -> [Decl.Decl] -> Src.Docs
toDocs comment decls = toDocs comment decls =
case comment of case comment of
Right overview -> Right overview ->
Src.YesDocs overview (getComments decls []) Src.YesDocs overview (getDocComments decls [])
Left region -> Left region ->
Src.NoDocs region Src.NoDocs region
getComments :: [Decl.Decl] -> [(Name.Name, Src.DocComment)] -> [(Name.Name, Src.DocComment)] getDocComments :: [Decl.Decl] -> [(Name.Name, Src.DocComment)] -> [(Name.Name, Src.DocComment)]
getComments decls comments = getDocComments decls comments =
case decls of case decls of
[] -> [] ->
comments comments
decl : otherDecls -> decl : otherDecls ->
case decl of case decl of
Decl.Value c (A.At _ (Src.Value n _ _ _)) -> getComments otherDecls (addComment c n comments) Decl.Value c (A.At _ (Src.Value n _ _ _)) -> getDocComments otherDecls (addComment c n comments)
Decl.Union c (A.At _ (Src.Union n _ _)) -> getComments otherDecls (addComment c n comments) Decl.Union c (A.At _ (Src.Union n _ _)) -> getDocComments otherDecls (addComment c n comments)
Decl.Alias c (A.At _ (Src.Alias n _ _)) -> getComments otherDecls (addComment c n comments) Decl.Alias c (A.At _ (Src.Alias n _ _)) -> getDocComments otherDecls (addComment c n comments)
Decl.Port c (Src.Port n _) -> getComments otherDecls (addComment c n comments) Decl.Port c (Src.Port n _) -> getDocComments otherDecls (addComment c n comments)
Decl.TopLevelComments _ -> getDocComments otherDecls comments
addComment :: Maybe Src.DocComment -> A.Located Name.Name -> [(Name.Name, Src.DocComment)] -> [(Name.Name, Src.DocComment)] addComment :: Maybe Src.DocComment -> A.Located Name.Name -> [(Name.Name, Src.DocComment)] -> [(Name.Name, Src.DocComment)]
addComment maybeComment (A.At _ name) comments = addComment maybeComment (A.At _ name) comments =
@ -181,13 +186,17 @@ freshLine toFreshLineError =
chompDecls :: [Decl.Decl] -> Parser E.Decl [Decl.Decl] chompDecls :: [Decl.Decl] -> Parser E.Decl [Decl.Decl]
chompDecls decls = chompDecls decls =
do do
(decl, _) <- Decl.declaration ((decl, commentsAfterDecl), _) <- Decl.declaration
let newDecls =
case nonEmpty commentsAfterDecl of
Nothing -> decl : decls
Just comments -> Decl.TopLevelComments comments : decl : decls
oneOfWithFallback oneOfWithFallback
[ do [ do
Space.checkFreshLine E.DeclStart Space.checkFreshLine E.DeclStart
chompDecls (decl : decls) chompDecls newDecls
] ]
(reverse (decl : decls)) (reverse newDecls)
chompInfixes :: [A.Located Src.Infix] -> Parser E.Module [A.Located Src.Infix] chompInfixes :: [A.Located Src.Infix] -> Parser E.Module [A.Located Src.Infix]
chompInfixes infixes = chompInfixes infixes =

29
compiler/src/Parse/Type.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-- Temporary while implementing gren format -- Temporary while implementing gren format
{-# OPTIONS_GHC -Wno-error=unused-do-bind #-} {-# OPTIONS_GHC -Wno-error=unused-do-bind #-}
{-# OPTIONS_GHC -Wno-error=unused-matches #-}
module Parse.Type module Parse.Type
( expression, ( expression,
@ -43,8 +44,8 @@ term =
-- parenthesis -- parenthesis
inContext E.TParenthesis (word1 0x28 {-(-} E.TStart) $ inContext E.TParenthesis (word1 0x28 {-(-} E.TStart) $
do do
Space.chompAndCheckIndent E.TParenthesisSpace E.TParenthesisIndentOpen commentsBeforeOpeningParen <- Space.chompAndCheckIndent E.TParenthesisSpace E.TParenthesisIndentOpen
(tipe, end) <- specialize E.TParenthesisType expression ((tipe, commentsBeforeClosingParen), end) <- specialize E.TParenthesisType expression
Space.checkIndent end E.TParenthesisIndentEnd Space.checkIndent end E.TParenthesisIndentEnd
word1 0x29 {-)-} E.TParenthesisEnd word1 0x29 {-)-} E.TParenthesisEnd
return tipe, return tipe,
@ -71,7 +72,7 @@ term =
do do
word1 0x3A {-:-} E.TRecordColon word1 0x3A {-:-} E.TRecordColon
Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentType Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentType
(tipe, end) <- specialize E.TRecordType expression ((tipe, commentsAfterTipe), end) <- specialize E.TRecordType expression
Space.checkIndent end E.TRecordIndentEnd Space.checkIndent end E.TRecordIndentEnd
fields <- chompRecordEnd [(name, tipe)] fields <- chompRecordEnd [(name, tipe)]
addEnd start (Src.TRecord fields Nothing) addEnd start (Src.TRecord fields Nothing)
@ -81,39 +82,39 @@ term =
-- TYPE EXPRESSIONS -- TYPE EXPRESSIONS
expression :: Space.Parser E.Type Src.Type expression :: Space.Parser E.Type (Src.Type, [Src.Comment])
expression = expression =
do do
start <- getPosition start <- getPosition
term1@(tipe1, end1) <- term1@((tipe1, commentsBeforeArrow), end1) <-
oneOf oneOf
E.TStart E.TStart
[ app start, [ app start,
do do
eterm <- term eterm <- term
end <- getPosition end <- getPosition
Space.chomp E.TSpace commentsAfter <- Space.chomp E.TSpace
return (eterm, end) return ((eterm, commentsAfter), end)
] ]
oneOfWithFallback oneOfWithFallback
[ do [ do
Space.checkIndent end1 E.TIndentStart -- should never trigger Space.checkIndent end1 E.TIndentStart -- should never trigger
word2 0x2D 0x3E {-->-} E.TStart -- could just be another type instead word2 0x2D 0x3E {-->-} E.TStart -- could just be another type instead
Space.chompAndCheckIndent E.TSpace E.TIndentStart commentsAfterArrow <- Space.chompAndCheckIndent E.TSpace E.TIndentStart
(tipe2, end2) <- expression ((tipe2, commentsAfter), end2) <- expression
let tipe = A.at start end2 (Src.TLambda tipe1 tipe2) let tipe = A.at start end2 (Src.TLambda tipe1 tipe2)
return (tipe, end2) return ((tipe, commentsAfter), end2)
] ]
term1 term1
-- TYPE CONSTRUCTORS -- TYPE CONSTRUCTORS
app :: A.Position -> Space.Parser E.Type Src.Type app :: A.Position -> Space.Parser E.Type (Src.Type, [Src.Comment])
app start = app start =
do do
upper <- Var.foreignUpper E.TStart upper <- Var.foreignUpper E.TStart
upperEnd <- getPosition upperEnd <- getPosition
Space.chomp E.TSpace commentsAfter <- Space.chomp E.TSpace
(args, end) <- chompArgs [] upperEnd (args, end) <- chompArgs [] upperEnd
let region = A.Region start upperEnd let region = A.Region start upperEnd
@ -124,7 +125,7 @@ app start =
Var.Qualified home name -> Var.Qualified home name ->
Src.TTypeQual region home name args Src.TTypeQual region home name args
return (A.at start end tipe, end) return ((A.at start end tipe, commentsAfter), end)
chompArgs :: [Src.Type] -> A.Position -> Space.Parser E.Type [Src.Type] chompArgs :: [Src.Type] -> A.Position -> Space.Parser E.Type [Src.Type]
chompArgs args end = chompArgs args end =
@ -163,7 +164,7 @@ chompField =
Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentColon Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentColon
word1 0x3A {-:-} E.TRecordColon word1 0x3A {-:-} E.TRecordColon
Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentType Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentType
(tipe, end) <- specialize E.TRecordType expression ((tipe, commentsAfterTipe), end) <- specialize E.TRecordType expression
Space.checkIndent end E.TRecordIndentEnd Space.checkIndent end E.TRecordIndentEnd
return (name, tipe) return (name, tipe)

2
compiler/src/Reporting/Render/Type/Localizer.hs
View File

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

3
terminal/src/Repl.hs
View File

@ -280,12 +280,13 @@ attemptDeclOrExpr lines =
exprParser = P.specialize (toExprPosition src) PE.expression exprParser = P.specialize (toExprPosition src) PE.expression
declParser = P.specialize (toDeclPosition src) PD.declaration declParser = P.specialize (toDeclPosition src) PD.declaration
in case P.fromByteString declParser (,) src of in case P.fromByteString declParser (,) src of
Right (decl, _) -> Right ((decl, _), _) ->
case decl of case decl of
PD.Value _ (A.At _ (Src.Value (A.At _ name) _ _ _)) -> ifDone lines (Decl name src) PD.Value _ (A.At _ (Src.Value (A.At _ name) _ _ _)) -> ifDone lines (Decl name src)
PD.Union _ (A.At _ (Src.Union (A.At _ name) _ _)) -> ifDone lines (Type name src) PD.Union _ (A.At _ (Src.Union (A.At _ name) _ _)) -> ifDone lines (Type name src)
PD.Alias _ (A.At _ (Src.Alias (A.At _ name) _ _)) -> ifDone lines (Type name src) PD.Alias _ (A.At _ (Src.Alias (A.At _ name) _ _)) -> ifDone lines (Type name src)
PD.Port _ _ -> Done Port PD.Port _ _ -> Done Port
PD.TopLevelComments _ -> Done Skip
Left declPosition Left declPosition
| startsWithKeyword "type" lines -> | startsWithKeyword "type" lines ->
ifFail lines (Type "ERR" src) ifFail lines (Type "ERR" src)

4
tests/Helpers/Parse.hs
View File

@ -13,7 +13,7 @@ import Parse.Space qualified as Space
import Reporting.Annotation qualified as A import Reporting.Annotation qualified as A
import Test.Hspec qualified as Hspec import Test.Hspec qualified as Hspec
checkParse :: (Show error, Show target) => Space.Parser error (A.Located target) -> (P.Row -> P.Col -> error) -> (Either error (A.Located target, A.Position) -> Bool) -> BS.ByteString -> IO () checkParse :: (Show error, Show target) => Space.Parser error target -> (P.Row -> P.Col -> error) -> (Either error (target, A.Position) -> Bool) -> BS.ByteString -> IO ()
checkParse parser toBadEnd checkResult str = checkParse parser toBadEnd checkResult str =
Hspec.shouldSatisfy Hspec.shouldSatisfy
(P.fromByteString parser toBadEnd str) (P.fromByteString parser toBadEnd str)
@ -29,7 +29,7 @@ checkSuccessfulParse parser toBadEnd checkTarget =
False False
in checkParse parser toBadEnd checkResult in checkParse parser toBadEnd checkResult
checkParseError :: (Show error, Show target) => Space.Parser error (A.Located target) -> (P.Row -> P.Col -> error) -> (error -> Bool) -> BS.ByteString -> IO () checkParseError :: (Show error, Show target) => Space.Parser error target -> (P.Row -> P.Col -> error) -> (error -> Bool) -> BS.ByteString -> IO ()
checkParseError parser toBadEnd checkError = checkParseError parser toBadEnd checkError =
let checkResult result = let checkResult result =
case result of case result of

34
tests/Integration/FormatSpec.hs
View File

@ -133,6 +133,40 @@ spec = do
`shouldFormatModuleBodyAs` [ "f =", `shouldFormatModuleBodyAs` [ "f =",
" {}" " {}"
] ]
it "formats comments between top-level definitions" $
[ "module Main exposing (..)",
"import Html",
"f = {}",
"-- B",
"g = {}",
"-- C",
"h = {}"
]
`shouldFormatAs` [ "module Main exposing (..)",
"",
"import Html",
"",
"",
"f =",
" {}",
"",
"",
"",
"-- B",
"",
"",
"g =",
" {}",
"",
"",
"",
"-- C",
"",
"",
"h =",
" {}"
]
describe "expressions" $ do describe "expressions" $ do
describe "record" $ do describe "record" $ do
describe "empty" $ do describe "empty" $ do

8
tests/Parse/RecordUpdateSpec.hs
View File

@ -53,10 +53,10 @@ parse str =
) )
`shouldSatisfy` isUpdateExpr `shouldSatisfy` isUpdateExpr
isUpdateExpr :: Either x (Src.Expr, A.Position) -> Bool isUpdateExpr :: Either x ((Src.Expr, [Src.Comment]), A.Position) -> Bool
isUpdateExpr result = isUpdateExpr result =
case result of case result of
Right (A.At _ (Src.Update _ _), _) -> True Right ((A.At _ (Src.Update _ _), _), _) -> True
_ -> False _ -> False
-- --
@ -70,8 +70,8 @@ parseRecordLiteral str =
) )
`shouldSatisfy` isRecordLiteral `shouldSatisfy` isRecordLiteral
isRecordLiteral :: Either x (Src.Expr, A.Position) -> Bool isRecordLiteral :: Either x ((Src.Expr, [Src.Comment]), A.Position) -> Bool
isRecordLiteral result = isRecordLiteral result =
case result of case result of
Right (A.At _ (Src.Record _), _) -> True Right ((A.At _ (Src.Record _), _), _) -> True
_ -> False _ -> False