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

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

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

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

@ -37,6 +37,7 @@ where
import AST.SourceComments (Comment, GREN_COMMENT)
import AST.SourceComments qualified as SC
import AST.Utils.Binop qualified as Binop
import Data.List.NonEmpty (NonEmpty)
import Data.Name (Name)
import Data.Name qualified as Name
import Gren.Float qualified as EF
@ -58,9 +59,9 @@ data Expr_
| Array [Expr]
| Op Name
| Negate Expr
| Binops [(Expr, A.Located Name)] Expr
| Binops [(Expr, [Comment], A.Located Name)] Expr
| Lambda [Pattern] Expr
| Call Expr [Expr]
| Call Expr [([Comment], Expr)]
| If [(Expr, Expr)] Expr
| Let [A.Located Def] Expr
| Case Expr [(Pattern, Expr)]
@ -129,13 +130,14 @@ data Module = Module
_unions :: [(SourceOrder, A.Located Union)],
_aliases :: [(SourceOrder, A.Located Alias)],
_binops :: [A.Located Infix],
_topLevelComments :: [(SourceOrder, NonEmpty Comment)],
_headerComments :: SC.HeaderComments,
_effects :: Effects
}
deriving (Show)
getName :: Module -> Name
getName (Module maybeName _ _ _ _ _ _ _ _ _) =
getName (Module maybeName _ _ _ _ _ _ _ _ _ _) =
case maybeName of
Just (A.At _ 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
collectVars :: Src.Module -> Result i w (Map.Map Name.Name Env.Var)
collectVars (Src.Module _ _ _ _ values _ _ _ _ effects) =
collectVars (Src.Module _ _ _ _ values _ _ _ _ _ effects) =
let addDecl dict (A.At _ (Src.Value (A.At region name) _ _ _)) =
Dups.insert name region (Env.TopLevel region) dict
in Dups.detect Error.DuplicateDecl $
@ -75,7 +75,7 @@ toEffectDups effects =
-- ADD TYPES
addTypes :: Src.Module -> Env.Env -> Result i w Env.Env
addTypes (Src.Module _ _ _ _ _ unions aliases _ _ _) (Env.Env home vs ts cs bs qvs qts qcs) =
addTypes (Src.Module _ _ _ _ _ unions aliases _ _ _ _) (Env.Env home vs ts cs bs qvs qts qcs) =
let addAliasDups dups (A.At _ (Src.Alias (A.At region name) _ _)) = Dups.insert name region () dups
addUnionDups dups (A.At _ (Src.Union (A.At region name) _ _)) = Dups.insert name region () dups
typeNameDups =
@ -199,7 +199,7 @@ addFreeVars freeVars (A.At region tipe) =
-- ADD CTORS
addCtors :: Src.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)
addCtors (Src.Module _ _ _ _ _ unions aliases _ _ _) env@(Env.Env home vs ts cs bs qvs qts qcs) =
addCtors (Src.Module _ _ _ _ _ unions aliases _ _ _ _) env@(Env.Env home vs ts cs bs qvs qts qcs) =
do
unionInfo <- traverse (canonicalizeUnion env) (fmap snd unions)
aliasInfo <- traverse (canonicalizeAlias env) (fmap snd aliases)

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

@ -93,7 +93,7 @@ canonicalize env (A.At region expression) =
Src.Call func args ->
Can.Call
<$> canonicalize env func
<*> traverse (canonicalize env) args
<*> traverse (canonicalize env) (fmap snd args)
Src.If branches finally ->
Can.If
<$> traverse (canonicalizeIfBranch env) branches
@ -149,9 +149,9 @@ canonicalizeCaseBranch env (pattern, expr) =
-- 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 =
let canonicalizeHelp (expr, A.At region op) =
let canonicalizeHelp (expr, _, A.At region op) =
(,)
<$> canonicalize env expr
<*> Env.findBinop region env op

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

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

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

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

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

@ -34,15 +34,15 @@ toByteStringBuilder module_ =
-- Data structure extras
--
repair :: [(a, b)] -> a -> (a, [(b, a)])
repair [] single = (single, [])
repair ((first, b) : rest) final =
(first, repairHelp b rest final)
repair3 :: [(a, b, c)] -> a -> (a, [(b, c, a)])
repair3 [] single = (single, [])
repair3 ((first, b, c) : rest) final =
(first, repair3Help b c 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
repair3Help :: b -> c -> [(a, b, c)] -> a -> [(b, c, a)]
repair3Help b c [] a = [(b, c, a)]
repair3Help b1 c1 ((a1, b2, c2) : rest) a2 =
(b1, c1, a1) : repair3Help b2 c2 rest a2
--
-- Helper functions
@ -158,10 +158,15 @@ formatComment = \case
in Block.mustBreak $ Block.string7 open <> utf8 text
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 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 $
NonEmpty.fromList $
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 unionName formatUnion . A.toValue) <$> unions,
fmap (formatWithDocComment aliasName formatAlias . A.toValue) <$> aliases,
fmap formatTopLevelCommentBlock <$> topLevelComments,
case effects of
Src.NoEffects -> []
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
]
formatTopLevelCommentBlock :: NonEmpty Src.Comment -> Block
formatTopLevelCommentBlock comments =
Block.stack
[ Block.blankLine,
formatCommentBlockNonEmpty comments
]
formatEffectsModuleWhereClause :: Src.Effects -> Maybe Block
formatEffectsModuleWhereClause = \case
Src.NoEffects -> Nothing
@ -493,7 +506,7 @@ formatExpr = \case
formatExpr $
A.toValue expr
Src.Binops postfixOps final ->
let (first, rest) = repair postfixOps final
let (first, rest) = repair3 postfixOps final
in ExpressionContainsInfixOps $
spaceOrIndentForce forceMultiline $
exprParensProtectInfixOps (formatExpr $ A.toValue first)
@ -501,8 +514,9 @@ formatExpr = \case
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) =
forceMultiline = any (opForcesMultiline . opFromPair) postfixOps
opFromPair (_, _, name) = A.toValue name
formatPair (commentsBeforeOp, op, expr) =
Block.prefix
4
(utf8 (A.toValue op) <> Block.space)
@ -526,7 +540,10 @@ formatExpr = \case
ExpressionContainsSpaces $
spaceOrIndent $
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_ ->
formatExpr $ A.toValue else_
Src.If (if_ : elseifs) else_ ->

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

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

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

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

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

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

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

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

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

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

3
terminal/src/Repl.hs
View File

@ -280,12 +280,13 @@ attemptDeclOrExpr lines =
exprParser = P.specialize (toExprPosition src) PE.expression
declParser = P.specialize (toDeclPosition src) PD.declaration
in case P.fromByteString declParser (,) src of
Right (decl, _) ->
Right ((decl, _), _) ->
case decl of
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.Alias _ (A.At _ (Src.Alias (A.At _ name) _ _)) -> ifDone lines (Type name src)
PD.Port _ _ -> Done Port
PD.TopLevelComments _ -> Done Skip
Left declPosition
| startsWithKeyword "type" lines ->
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 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 =
Hspec.shouldSatisfy
(P.fromByteString parser toBadEnd str)
@ -29,7 +29,7 @@ checkSuccessfulParse parser toBadEnd checkTarget =
False
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 =
let checkResult result =
case result of

34
tests/Integration/FormatSpec.hs
View File

@ -133,6 +133,40 @@ spec = do
`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 "record" $ do
describe "empty" $ do

8
tests/Parse/RecordUpdateSpec.hs
View File

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