mirror of
https://github.com/gren-lang/compiler.git
synced 2024-10-26 09:50:44 +03:00
Merge pull request #132 from avh4/retain-comments
Formatting retains comments (module header and paren expressions)
This commit is contained in:
commit
5bda3496e2
@ -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
|
||||
|
@ -486,7 +486,7 @@ crawlFile foreignDeps mvar pkg src docsStatus expectedName path =
|
||||
do
|
||||
bytes <- File.readUtf8 path
|
||||
case Parse.fromByteString (Parse.Package pkg) bytes of
|
||||
Right modul@(Src.Module (Just (A.At _ actualName)) _ _ imports _ _ _ _ _) | expectedName == actualName ->
|
||||
Right modul@(Src.Module (Just (A.At _ actualName)) _ _ imports _ _ _ _ _ _) | expectedName == actualName ->
|
||||
do
|
||||
deps <- crawlImports foreignDeps mvar pkg src imports
|
||||
return (Just (SLocal docsStatus deps modul))
|
||||
|
@ -34,24 +34,16 @@ module AST.Source
|
||||
)
|
||||
where
|
||||
|
||||
import AST.SourceComments (Comment, GREN_COMMENT)
|
||||
import AST.SourceComments qualified as SC
|
||||
import AST.Utils.Binop qualified as Binop
|
||||
import Data.Name (Name)
|
||||
import Data.Name qualified as Name
|
||||
import Data.Utf8 qualified as Utf8
|
||||
import Gren.Float qualified as EF
|
||||
import Gren.String qualified as ES
|
||||
import Parse.Primitives qualified as P
|
||||
import Reporting.Annotation qualified as A
|
||||
|
||||
-- COMMENTS
|
||||
|
||||
data Comment
|
||||
= BlockComment (Utf8.Utf8 GREN_COMMENT)
|
||||
| LineComment (Utf8.Utf8 GREN_COMMENT)
|
||||
deriving (Show)
|
||||
|
||||
data GREN_COMMENT
|
||||
|
||||
-- EXPRESSIONS
|
||||
|
||||
type Expr = A.Located Expr_
|
||||
@ -76,6 +68,7 @@ data Expr_
|
||||
| Access Expr (A.Located Name)
|
||||
| Update Expr [(A.Located Name, Expr)]
|
||||
| Record [(A.Located Name, Expr)]
|
||||
| Parens [Comment] Expr [Comment]
|
||||
deriving (Show)
|
||||
|
||||
data VarType = LowVar | CapVar
|
||||
@ -136,12 +129,13 @@ data Module = Module
|
||||
_unions :: [(SourceOrder, A.Located Union)],
|
||||
_aliases :: [(SourceOrder, A.Located Alias)],
|
||||
_binops :: [A.Located Infix],
|
||||
_headerComments :: SC.HeaderComments,
|
||||
_effects :: Effects
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
getName :: Module -> Name
|
||||
getName (Module maybeName _ _ _ _ _ _ _ _) =
|
||||
getName (Module maybeName _ _ _ _ _ _ _ _ _) =
|
||||
case maybeName of
|
||||
Just (A.At _ name) ->
|
||||
name
|
||||
@ -176,14 +170,14 @@ data Port = Port (A.Located Name) Type
|
||||
|
||||
data Effects
|
||||
= NoEffects
|
||||
| Ports [(SourceOrder, Port)]
|
||||
| Manager A.Region Manager
|
||||
| Ports [(SourceOrder, Port)] SC.PortsComments
|
||||
| Manager A.Region Manager SC.ManagerComments
|
||||
deriving (Show)
|
||||
|
||||
data Manager
|
||||
= Cmd (A.Located Name)
|
||||
| Sub (A.Located Name)
|
||||
| Fx (A.Located Name) (A.Located Name)
|
||||
= Cmd (A.Located Name) SC.CmdComments
|
||||
| Sub (A.Located Name) SC.SubComments
|
||||
| Fx (A.Located Name) (A.Located Name) SC.FxComments
|
||||
deriving (Show)
|
||||
|
||||
data Docs
|
||||
|
56
compiler/src/AST/SourceComments.hs
Normal file
56
compiler/src/AST/SourceComments.hs
Normal file
@ -0,0 +1,56 @@
|
||||
module AST.SourceComments where
|
||||
|
||||
import Data.Utf8 qualified as Utf8
|
||||
|
||||
data GREN_COMMENT
|
||||
|
||||
data Comment
|
||||
= BlockComment (Utf8.Utf8 GREN_COMMENT)
|
||||
| LineComment (Utf8.Utf8 GREN_COMMENT)
|
||||
deriving (Show)
|
||||
|
||||
-- Module
|
||||
|
||||
data HeaderComments = HeaderComments
|
||||
{ _beforeModuleLine :: [Comment],
|
||||
_afterModuleKeyword :: [Comment],
|
||||
_afterModuleName :: [Comment],
|
||||
_afterExposingKeyword :: [Comment],
|
||||
_afterModuleLine :: [Comment],
|
||||
_afterModuleDocComment :: [Comment]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
-- Effects
|
||||
|
||||
data PortsComments = PortsComments
|
||||
{ _afterPortKeyword :: [Comment]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data ManagerComments = ManagerComments
|
||||
{ _afterEffectKeyword :: [Comment],
|
||||
_afterWhereKeyword :: [Comment],
|
||||
_afterManager :: [Comment]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
-- Manager
|
||||
|
||||
data CmdComments = CmdComments
|
||||
{ _beforeCommandKeyword :: [Comment],
|
||||
_afterCommand :: [Comment]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data SubComments = SubComments
|
||||
{ _beforeSubscriptionsKeyword :: [Comment],
|
||||
_afterSubscriptions :: [Comment]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data FxComments = FxComments
|
||||
{ _cmdComments :: CmdComments,
|
||||
_subComments :: SubComments
|
||||
}
|
||||
deriving (Show)
|
@ -37,26 +37,26 @@ canonicalize env values unions effects =
|
||||
case effects of
|
||||
Src.NoEffects ->
|
||||
Result.ok Can.NoEffects
|
||||
Src.Ports ports ->
|
||||
Src.Ports ports _ ->
|
||||
do
|
||||
pairs <- traverse (canonicalizePort env) (fmap snd ports)
|
||||
return $ Can.Ports (Map.fromList pairs)
|
||||
Src.Manager region manager ->
|
||||
Src.Manager region manager _ ->
|
||||
let dict = Map.fromList (map toNameRegion values)
|
||||
in Can.Manager
|
||||
<$> verifyManager region dict "init"
|
||||
<*> verifyManager region dict "onEffects"
|
||||
<*> verifyManager region dict "onSelfMsg"
|
||||
<*> case manager of
|
||||
Src.Cmd cmdType ->
|
||||
Src.Cmd cmdType _ ->
|
||||
Can.Cmd
|
||||
<$> verifyEffectType cmdType unions
|
||||
<* verifyManager region dict "cmdMap"
|
||||
Src.Sub subType ->
|
||||
Src.Sub subType _ ->
|
||||
Can.Sub
|
||||
<$> verifyEffectType subType unions
|
||||
<* verifyManager region dict "subMap"
|
||||
Src.Fx cmdType subType ->
|
||||
Src.Fx cmdType subType _ ->
|
||||
Can.Fx
|
||||
<$> verifyEffectType cmdType unions
|
||||
<*> verifyEffectType subType unions
|
||||
|
@ -46,7 +46,7 @@ addVars module_ (Env.Env home vs ts cs bs qvs qts qcs) =
|
||||
Result.ok $ Env.Env home vs2 ts cs bs qvs qts qcs
|
||||
|
||||
collectVars :: Src.Module -> Result i w (Map.Map Name.Name Env.Var)
|
||||
collectVars (Src.Module _ _ _ _ values _ _ _ effects) =
|
||||
collectVars (Src.Module _ _ _ _ values _ _ _ _ effects) =
|
||||
let addDecl dict (A.At _ (Src.Value (A.At region name) _ _ _)) =
|
||||
Dups.insert name region (Env.TopLevel region) dict
|
||||
in Dups.detect Error.DuplicateDecl $
|
||||
@ -57,17 +57,17 @@ toEffectDups effects =
|
||||
case effects of
|
||||
Src.NoEffects ->
|
||||
Dups.none
|
||||
Src.Ports ports ->
|
||||
Src.Ports ports _ ->
|
||||
let addPort dict (Src.Port (A.At region name) _) =
|
||||
Dups.insert name region (Env.TopLevel region) dict
|
||||
in List.foldl' addPort Dups.none (fmap snd ports)
|
||||
Src.Manager _ manager ->
|
||||
Src.Manager _ manager _ ->
|
||||
case manager of
|
||||
Src.Cmd (A.At region _) ->
|
||||
Src.Cmd (A.At region _) _ ->
|
||||
Dups.one "command" region (Env.TopLevel region)
|
||||
Src.Sub (A.At region _) ->
|
||||
Src.Sub (A.At region _) _ ->
|
||||
Dups.one "subscription" region (Env.TopLevel region)
|
||||
Src.Fx (A.At regionCmd _) (A.At regionSub _) ->
|
||||
Src.Fx (A.At regionCmd _) (A.At regionSub _) _ ->
|
||||
Dups.union
|
||||
(Dups.one "command" regionCmd (Env.TopLevel regionCmd))
|
||||
(Dups.one "subscription" regionSub (Env.TopLevel regionSub))
|
||||
@ -75,7 +75,7 @@ toEffectDups effects =
|
||||
-- ADD TYPES
|
||||
|
||||
addTypes :: Src.Module -> Env.Env -> Result i w Env.Env
|
||||
addTypes (Src.Module _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs qts qcs) =
|
||||
addTypes (Src.Module _ _ _ _ _ unions aliases _ _ _) (Env.Env home vs ts cs bs qvs qts qcs) =
|
||||
let addAliasDups dups (A.At _ (Src.Alias (A.At region name) _ _)) = Dups.insert name region () dups
|
||||
addUnionDups dups (A.At _ (Src.Union (A.At region name) _ _)) = Dups.insert name region () dups
|
||||
typeNameDups =
|
||||
@ -199,7 +199,7 @@ addFreeVars freeVars (A.At region tipe) =
|
||||
-- ADD CTORS
|
||||
|
||||
addCtors :: Src.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)
|
||||
addCtors (Src.Module _ _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs qvs qts qcs) =
|
||||
addCtors (Src.Module _ _ _ _ _ unions aliases _ _ _) env@(Env.Env home vs ts cs bs qvs qts qcs) =
|
||||
do
|
||||
unionInfo <- traverse (canonicalizeUnion env) (fmap snd unions)
|
||||
aliasInfo <- traverse (canonicalizeAlias env) (fmap snd aliases)
|
||||
|
@ -120,6 +120,8 @@ canonicalize env (A.At region expression) =
|
||||
do
|
||||
fieldDict <- Dups.checkFields fields
|
||||
Can.Record <$> traverse (canonicalize env) fieldDict
|
||||
Src.Parens _ expr _ ->
|
||||
A.toValue <$> (canonicalize env expr)
|
||||
|
||||
-- CANONICALIZE IF BRANCH
|
||||
|
||||
|
@ -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)
|
||||
|
@ -1,11 +1,13 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -Werror=incomplete-patterns #-}
|
||||
{-# OPTIONS_GHC -Wno-error=unused-matches #-}
|
||||
|
||||
module Gren.Format (toByteStringBuilder) where
|
||||
|
||||
import AST.Source qualified as Src
|
||||
import AST.SourceComments qualified as SC
|
||||
import AST.Utils.Binop qualified as Binop
|
||||
import Control.Monad (join)
|
||||
import Data.Bifunctor (second)
|
||||
@ -126,23 +128,47 @@ extendedGroup open baseSep sep fieldSep close base fields =
|
||||
value
|
||||
]
|
||||
|
||||
withCommentsBefore :: [Src.Comment] -> Block -> Block
|
||||
withCommentsBefore [] block = block
|
||||
withCommentsBefore (first : rest) block =
|
||||
spaceOrStack
|
||||
[ spaceOrStack $ fmap formatComment (first :| rest),
|
||||
block
|
||||
]
|
||||
|
||||
--
|
||||
-- AST -> Block
|
||||
--
|
||||
|
||||
formatComment :: Src.Comment -> Block
|
||||
formatComment = \case
|
||||
Src.BlockComment text ->
|
||||
let open = if Utf8.startsWithChar (== ' ') text then "{-" else "{- "
|
||||
close = if Utf8.endsWithWord8 0x20 {- space -} text then "-}" else " -}"
|
||||
in Block.line $ Block.string7 open <> utf8 text <> Block.string7 close
|
||||
Src.LineComment text ->
|
||||
let open = if Utf8.startsWithChar (== ' ') text then "--" else "-- "
|
||||
in Block.mustBreak $ Block.string7 open <> utf8 text
|
||||
|
||||
formatCommentBlock :: [Src.Comment] -> Maybe Block
|
||||
formatCommentBlock = fmap spaceOrStack . nonEmpty . fmap formatComment
|
||||
|
||||
formatModule :: Src.Module -> Block
|
||||
formatModule (Src.Module moduleName exports docs imports values unions aliases binops effects) =
|
||||
-- TODO: implement actual formating
|
||||
formatModule (Src.Module moduleName exports docs imports values unions aliases binops comments effects) =
|
||||
Block.stack $
|
||||
NonEmpty.fromList $
|
||||
catMaybes
|
||||
[ Just $
|
||||
[ formatCommentBlock commentsBeforeLine,
|
||||
Just $
|
||||
spaceOrIndent $
|
||||
NonEmpty.fromList $
|
||||
catMaybes
|
||||
[ Just $ Block.line $ Block.string7 moduleKeyword,
|
||||
formatCommentBlock commentsAfterKeyword,
|
||||
Just $ Block.line $ maybe (Block.string7 "Main") (utf8 . A.toValue) moduleName,
|
||||
formatCommentBlock commentsAfterName,
|
||||
formatEffectsModuleWhereClause effects,
|
||||
formatExposing $ A.toValue exports
|
||||
formatExposing commentsAfterExposingKeyword (A.toValue exports)
|
||||
],
|
||||
case docs of
|
||||
Src.NoDocs _ -> Nothing
|
||||
@ -152,6 +178,7 @@ formatModule (Src.Module moduleName exports docs imports values unions aliases b
|
||||
[ Block.blankLine,
|
||||
formatDocComment moduleDocs
|
||||
],
|
||||
formatCommentBlock (commentsAfterLine <> commentsAfterDocComment),
|
||||
Just $ Block.stack $ Block.blankLine :| fmap formatImport imports,
|
||||
infixDefs,
|
||||
let defs =
|
||||
@ -163,17 +190,19 @@ formatModule (Src.Module moduleName exports docs imports values unions aliases b
|
||||
fmap (formatWithDocComment aliasName formatAlias . A.toValue) <$> aliases,
|
||||
case effects of
|
||||
Src.NoEffects -> []
|
||||
Src.Ports ports -> fmap (formatWithDocComment portName formatPort) <$> ports
|
||||
Src.Manager _ _ -> []
|
||||
Src.Ports ports _ -> fmap (formatWithDocComment portName formatPort) <$> ports
|
||||
Src.Manager _ _ _ -> []
|
||||
]
|
||||
in fmap Block.stack $ nonEmpty $ fmap (addBlankLines 2) defs
|
||||
]
|
||||
where
|
||||
(SC.HeaderComments commentsBeforeLine commentsAfterKeyword commentsAfterName commentsAfterExposingKeyword commentsAfterLine commentsAfterDocComment) = comments
|
||||
|
||||
moduleKeyword =
|
||||
case effects of
|
||||
Src.NoEffects -> "module"
|
||||
Src.Ports _ -> "port module"
|
||||
Src.Manager _ _ -> "effect module"
|
||||
Src.Ports _ (SC.PortsComments afterPortKeyword) -> "port module"
|
||||
Src.Manager _ _ (SC.ManagerComments afterEffectKeyword _ _) -> "effect module"
|
||||
|
||||
defDocs :: Map Name Src.DocComment
|
||||
defDocs =
|
||||
@ -209,8 +238,9 @@ formatModule (Src.Module moduleName exports docs imports values unions aliases b
|
||||
formatEffectsModuleWhereClause :: Src.Effects -> Maybe Block
|
||||
formatEffectsModuleWhereClause = \case
|
||||
Src.NoEffects -> Nothing
|
||||
Src.Ports _ -> Nothing
|
||||
Src.Manager _ manager -> Just $ formatManager manager
|
||||
Src.Ports _ _ -> Nothing
|
||||
Src.Manager _ manager (SC.ManagerComments _ afterWhereKeyword afterManager) ->
|
||||
Just $ formatManager manager
|
||||
|
||||
formatManager :: Src.Manager -> Block
|
||||
formatManager manager =
|
||||
@ -219,33 +249,48 @@ formatManager manager =
|
||||
group '{' ',' '}' False $
|
||||
fmap (formatPair . second A.toValue) $
|
||||
case manager of
|
||||
Src.Cmd cmd ->
|
||||
[("command", cmd)]
|
||||
Src.Sub sub ->
|
||||
[("subscription", sub)]
|
||||
Src.Fx cmd sub ->
|
||||
[ ("command", cmd),
|
||||
("subscription", sub)
|
||||
Src.Cmd cmd (SC.CmdComments comments1 comments2) ->
|
||||
[(comments1 ++ comments2, "command", cmd)]
|
||||
Src.Sub sub (SC.SubComments comments1 comments2) ->
|
||||
[(comments1 ++ comments2, "subscription", sub)]
|
||||
Src.Fx cmd sub (SC.FxComments (SC.CmdComments commentsCmd1 commentsCmd2) (SC.SubComments commentsSub1 commentsSub2)) ->
|
||||
[ (commentsCmd1 ++ commentsCmd2, "command", cmd),
|
||||
(commentsSub1 ++ commentsSub2, "subscription", sub)
|
||||
]
|
||||
]
|
||||
where
|
||||
formatPair (key, name) =
|
||||
Block.line $
|
||||
sconcat
|
||||
[ Block.string7 key,
|
||||
Block.string7 " = ",
|
||||
utf8 name
|
||||
]
|
||||
formatPair (comments, key, name) =
|
||||
spaceOrStack $
|
||||
NonEmpty.prependList
|
||||
(fmap formatComment comments)
|
||||
( NonEmpty.singleton $
|
||||
Block.line $
|
||||
sconcat
|
||||
[ Block.string7 key,
|
||||
Block.string7 " = ",
|
||||
utf8 name
|
||||
]
|
||||
)
|
||||
|
||||
formatExposing :: Src.Exposing -> Maybe Block
|
||||
formatExposing = \case
|
||||
Src.Open -> Just $ Block.line $ Block.string7 "exposing (..)"
|
||||
Src.Explicit [] -> Nothing
|
||||
formatExposing :: [Src.Comment] -> Src.Exposing -> Maybe Block
|
||||
formatExposing commentsAfterKeyword = \case
|
||||
Src.Open ->
|
||||
Just $
|
||||
spaceOrIndent
|
||||
[ Block.line $ Block.string7 "exposing",
|
||||
withCommentsBefore commentsAfterKeyword $
|
||||
Block.line $
|
||||
Block.string7 "(..)"
|
||||
]
|
||||
Src.Explicit [] ->
|
||||
formatCommentBlock commentsAfterKeyword
|
||||
Src.Explicit exposed ->
|
||||
Just $
|
||||
spaceOrIndent
|
||||
[ Block.line $ Block.string7 "exposing",
|
||||
group '(' ',' ')' False $ fmap formatExposed exposed
|
||||
withCommentsBefore commentsAfterKeyword $
|
||||
group '(' ',' ')' False $
|
||||
fmap formatExposed exposed
|
||||
]
|
||||
|
||||
formatExposed :: Src.Exposed -> Block
|
||||
@ -262,7 +307,7 @@ formatImport (Src.Import name alias exposing) =
|
||||
[ Just $ Block.line $ Block.string7 "import",
|
||||
Just $ Block.line $ utf8 $ A.toValue name,
|
||||
fmap formatImportAlias alias,
|
||||
formatExposing exposing
|
||||
formatExposing [] exposing
|
||||
]
|
||||
|
||||
formatImportAlias :: Name -> Block
|
||||
@ -558,6 +603,18 @@ formatExpr = \case
|
||||
[ Block.line $ utf8 (A.toValue name) <> Block.space <> Block.char7 '=',
|
||||
exprParensNone $ formatExpr (A.toValue expr)
|
||||
]
|
||||
Src.Parens [] expr [] ->
|
||||
formatExpr $ A.toValue expr
|
||||
Src.Parens commentsBefore expr commentsAfter ->
|
||||
NoExpressionParens $
|
||||
parens $
|
||||
spaceOrStack $
|
||||
NonEmpty.fromList $
|
||||
catMaybes
|
||||
[ formatCommentBlock commentsBefore,
|
||||
Just $ exprParensNone $ formatExpr (A.toValue expr),
|
||||
formatCommentBlock commentsAfter
|
||||
]
|
||||
|
||||
opForcesMultiline :: Name -> Bool
|
||||
opForcesMultiline op =
|
||||
|
@ -66,7 +66,7 @@ parenthesizedExpr :: A.Position -> Parser E.Expr Src.Expr
|
||||
parenthesizedExpr start@(A.Position row col) =
|
||||
inContext E.Parenthesized (word1 0x28 {-(-} E.Start) $
|
||||
do
|
||||
Space.chompAndCheckIndent E.ParenthesizedSpace E.ParenthesizedIndentOpen
|
||||
comments1 <- Space.chompAndCheckIndent E.ParenthesizedSpace E.ParenthesizedIndentOpen
|
||||
oneOf
|
||||
E.ParenthesizedOpen
|
||||
[ do
|
||||
@ -79,17 +79,17 @@ parenthesizedExpr start@(A.Position row col) =
|
||||
word1 0x29 {-)-} E.ParenthesizedOperatorClose
|
||||
addEnd start (Src.Op op),
|
||||
do
|
||||
(expr, end) <-
|
||||
(comments2, (expr, end)) <-
|
||||
specialize E.ParenthesizedExpr $
|
||||
do
|
||||
negatedExpr@(A.At (A.Region _ end) _) <- term
|
||||
Space.chomp E.Space
|
||||
comments2_ <- Space.chomp E.Space
|
||||
let exprStart = A.Position row (col + 2)
|
||||
let expr = A.at exprStart end (Src.Negate negatedExpr)
|
||||
chompExprEnd exprStart (State [] expr [] end)
|
||||
(,) comments2_ <$> chompExprEnd exprStart (State [] expr [] end)
|
||||
Space.checkIndent end E.ParenthesizedIndentEnd
|
||||
word1 0x29 {-)-} E.ParenthesizedOperatorClose
|
||||
return expr
|
||||
addEnd start (Src.Parens comments1 expr comments2)
|
||||
]
|
||||
else do
|
||||
word1 0x29 {-)-} E.ParenthesizedOperatorClose
|
||||
@ -97,7 +97,7 @@ parenthesizedExpr start@(A.Position row col) =
|
||||
do
|
||||
(expr, _) <- specialize E.ParenthesizedExpr expression
|
||||
word1 0x29 {-)-} E.ParenthesizedEnd
|
||||
return expr
|
||||
addEnd start (Src.Parens comments1 expr [])
|
||||
]
|
||||
|
||||
accessor :: A.Position -> Parser E.Expr Src.Expr
|
||||
|
@ -14,6 +14,7 @@ module Parse.Module
|
||||
where
|
||||
|
||||
import AST.Source qualified as Src
|
||||
import AST.SourceComments qualified as SC
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.Name qualified as Name
|
||||
import Gren.Compiler.Imports qualified as Imports
|
||||
@ -78,15 +79,16 @@ checkModule :: ProjectType -> Module -> Either E.Error Src.Module
|
||||
checkModule projectType (Module maybeHeader imports infixes decls) =
|
||||
let (values, unions, aliases, ports) = categorizeDecls [] [] [] [] 0 decls
|
||||
in case maybeHeader of
|
||||
Just (Header name effects exports docs) ->
|
||||
Src.Module (Just name) exports (toDocs docs decls) imports values unions aliases infixes
|
||||
Just (Header name effects exports docs comments) ->
|
||||
Src.Module (Just name) exports (toDocs docs decls) imports values unions aliases infixes comments
|
||||
<$> checkEffects projectType ports effects
|
||||
Nothing ->
|
||||
Right $
|
||||
Src.Module Nothing (A.At A.one Src.Open) (Src.NoDocs A.one) imports values unions aliases infixes $
|
||||
case ports of
|
||||
[] -> Src.NoEffects
|
||||
_ : _ -> Src.Ports ports
|
||||
let comments = SC.HeaderComments [] [] [] [] [] []
|
||||
in Right $
|
||||
Src.Module Nothing (A.At A.one Src.Open) (Src.NoDocs A.one) imports values unions aliases infixes comments $
|
||||
case ports of
|
||||
[] -> Src.NoEffects
|
||||
_ : _ -> Src.Ports ports (SC.PortsComments [])
|
||||
|
||||
checkEffects :: ProjectType -> [(Src.SourceOrder, Src.Port)] -> Effects -> Either E.Error Src.Effects
|
||||
checkEffects projectType ports effects =
|
||||
@ -99,18 +101,18 @@ checkEffects projectType ports effects =
|
||||
case projectType of
|
||||
Package _ -> Left (E.NoPortsInPackage name)
|
||||
Application -> Left (E.UnexpectedPort region)
|
||||
Ports region ->
|
||||
Ports region comments ->
|
||||
case projectType of
|
||||
Package _ ->
|
||||
Left (E.NoPortModulesInPackage region)
|
||||
Application ->
|
||||
case ports of
|
||||
[] -> Left (E.NoPorts region)
|
||||
_ : _ -> Right (Src.Ports ports)
|
||||
Manager region manager ->
|
||||
_ : _ -> Right (Src.Ports ports comments)
|
||||
Manager region manager comments ->
|
||||
if isKernel projectType
|
||||
then case ports of
|
||||
[] -> Right (Src.Manager region manager)
|
||||
[] -> Right (Src.Manager region manager comments)
|
||||
_ : _ -> Left (E.UnexpectedPort region)
|
||||
else Left (E.NoEffectsOutsideKernel region)
|
||||
|
||||
@ -198,131 +200,149 @@ chompInfixes infixes =
|
||||
|
||||
-- MODULE DOC COMMENT
|
||||
|
||||
chompModuleDocCommentSpace :: Parser E.Module (Either A.Region Src.DocComment)
|
||||
chompModuleDocCommentSpace :: Parser E.Module ([Src.Comment], (Either A.Region Src.DocComment), [Src.Comment])
|
||||
chompModuleDocCommentSpace =
|
||||
do
|
||||
(A.At region comments) <- addLocation (freshLine E.FreshLine)
|
||||
(A.At region preComments) <- addLocation (freshLine E.FreshLine)
|
||||
oneOfWithFallback
|
||||
[ do
|
||||
docComment <- Space.docComment E.ImportStart E.ModuleSpace
|
||||
Space.chomp E.ModuleSpace
|
||||
postComments <- Space.chomp E.ModuleSpace
|
||||
Space.checkFreshLine E.FreshLine
|
||||
return (Right docComment)
|
||||
return (preComments, (Right docComment), postComments)
|
||||
]
|
||||
(Left region)
|
||||
(preComments, (Left region), [])
|
||||
|
||||
-- HEADER
|
||||
|
||||
data Header
|
||||
= Header (A.Located Name.Name) Effects (A.Located Src.Exposing) (Either A.Region Src.DocComment)
|
||||
= Header
|
||||
(A.Located Name.Name)
|
||||
Effects
|
||||
(A.Located Src.Exposing)
|
||||
(Either A.Region Src.DocComment)
|
||||
SC.HeaderComments
|
||||
|
||||
data Effects
|
||||
= NoEffects A.Region
|
||||
| Ports A.Region
|
||||
| Manager A.Region Src.Manager
|
||||
| Ports A.Region SC.PortsComments
|
||||
| Manager A.Region Src.Manager SC.ManagerComments
|
||||
|
||||
chompHeader :: Parser E.Module (Maybe Header)
|
||||
chompHeader =
|
||||
do
|
||||
freshLine E.FreshLine
|
||||
commentsBeforeModuleLine <- freshLine E.FreshLine
|
||||
start <- getPosition
|
||||
oneOfWithFallback
|
||||
[ -- module MyThing exposing (..)
|
||||
do
|
||||
Keyword.module_ E.ModuleProblem
|
||||
effectEnd <- getPosition
|
||||
Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem
|
||||
commentsAfterModuleKeyword <- Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem
|
||||
name <- addLocation (Var.moduleName E.ModuleName)
|
||||
Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem
|
||||
commentsAfterModuleName <- Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem
|
||||
Keyword.exposing_ E.ModuleProblem
|
||||
Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem
|
||||
commentsAfterExposingKeyword <- Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem
|
||||
exports <- addLocation (specialize E.ModuleExposing exposing)
|
||||
comment <- chompModuleDocCommentSpace
|
||||
(commentsBeforeDocComment, docComment, commentsAfterDocComment) <- chompModuleDocCommentSpace
|
||||
let comments = SC.HeaderComments commentsBeforeModuleLine commentsAfterModuleKeyword commentsAfterModuleName commentsAfterExposingKeyword commentsBeforeDocComment commentsAfterDocComment
|
||||
return $
|
||||
Just $
|
||||
Header name (NoEffects (A.Region start effectEnd)) exports comment,
|
||||
Header name (NoEffects (A.Region start effectEnd)) exports docComment comments,
|
||||
-- port module MyThing exposing (..)
|
||||
do
|
||||
Keyword.port_ E.PortModuleProblem
|
||||
Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
|
||||
commentsAfterPortKeyword <- Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
|
||||
Keyword.module_ E.PortModuleProblem
|
||||
effectEnd <- getPosition
|
||||
Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
|
||||
commentsAfterModuleKeyword <- Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
|
||||
name <- addLocation (Var.moduleName E.PortModuleName)
|
||||
Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
|
||||
commentsAfterModuleName <- Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
|
||||
Keyword.exposing_ E.PortModuleProblem
|
||||
Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
|
||||
commentsAfterExposingKeyword <- Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
|
||||
exports <- addLocation (specialize E.PortModuleExposing exposing)
|
||||
comment <- chompModuleDocCommentSpace
|
||||
(commentsBeforeDocComment, docComment, commentsAfterDocComment) <- chompModuleDocCommentSpace
|
||||
let comments = SC.HeaderComments commentsBeforeModuleLine commentsAfterModuleKeyword commentsAfterModuleName commentsAfterExposingKeyword commentsBeforeDocComment commentsAfterDocComment
|
||||
let portsComments = SC.PortsComments commentsAfterPortKeyword
|
||||
return $
|
||||
Just $
|
||||
Header name (Ports (A.Region start effectEnd)) exports comment,
|
||||
Header name (Ports (A.Region start effectEnd) portsComments) exports docComment comments,
|
||||
-- effect module MyThing where { command = MyCmd } exposing (..)
|
||||
do
|
||||
Keyword.effect_ E.Effect
|
||||
Space.chompAndCheckIndent E.ModuleSpace E.Effect
|
||||
commentsAfterEffectKeyword <- Space.chompAndCheckIndent E.ModuleSpace E.Effect
|
||||
Keyword.module_ E.Effect
|
||||
effectEnd <- getPosition
|
||||
Space.chompAndCheckIndent E.ModuleSpace E.Effect
|
||||
commentsAfterModuleKeyword <- Space.chompAndCheckIndent E.ModuleSpace E.Effect
|
||||
name <- addLocation (Var.moduleName E.ModuleName)
|
||||
Space.chompAndCheckIndent E.ModuleSpace E.Effect
|
||||
commentsAfterModuleName <- Space.chompAndCheckIndent E.ModuleSpace E.Effect
|
||||
Keyword.where_ E.Effect
|
||||
Space.chompAndCheckIndent E.ModuleSpace E.Effect
|
||||
manager <- chompManager
|
||||
Space.chompAndCheckIndent E.ModuleSpace E.Effect
|
||||
commentsAfterWhereKeyword <- Space.chompAndCheckIndent E.ModuleSpace E.Effect
|
||||
(manager, commentsAfterManager1) <- chompManager
|
||||
commentsAfterManager2 <- Space.chompAndCheckIndent E.ModuleSpace E.Effect
|
||||
Keyword.exposing_ E.Effect
|
||||
Space.chompAndCheckIndent E.ModuleSpace E.Effect
|
||||
commentsAfterExposingKeyword <- Space.chompAndCheckIndent E.ModuleSpace E.Effect
|
||||
exports <- addLocation (specialize (const E.Effect) exposing)
|
||||
comment <- chompModuleDocCommentSpace
|
||||
(commentsBeforeDocComment, docComment, commentsAfterDocComment) <- chompModuleDocCommentSpace
|
||||
let comments = SC.HeaderComments commentsBeforeModuleLine commentsAfterModuleKeyword commentsAfterModuleName commentsAfterExposingKeyword commentsBeforeDocComment commentsAfterDocComment
|
||||
let managerComments = SC.ManagerComments commentsAfterEffectKeyword commentsAfterWhereKeyword (commentsAfterManager1 <> commentsAfterManager2)
|
||||
return $
|
||||
Just $
|
||||
Header name (Manager (A.Region start effectEnd) manager) exports comment
|
||||
Header name (Manager (A.Region start effectEnd) manager managerComments) exports docComment comments
|
||||
]
|
||||
-- default header
|
||||
Nothing
|
||||
|
||||
chompManager :: Parser E.Module Src.Manager
|
||||
chompManager :: Parser E.Module (Src.Manager, [Src.Comment])
|
||||
chompManager =
|
||||
do
|
||||
word1 0x7B {- { -} E.Effect
|
||||
spaces_em
|
||||
commentsAfterOpenBrace <- spaces_em
|
||||
oneOf
|
||||
E.Effect
|
||||
[ do
|
||||
cmd <- chompCommand
|
||||
spaces_em
|
||||
commentsAfterCmd <- spaces_em
|
||||
oneOf
|
||||
E.Effect
|
||||
[ do
|
||||
word1 0x7D {-}-} E.Effect
|
||||
spaces_em
|
||||
return (Src.Cmd cmd),
|
||||
commentsAfterCloseBrace <- spaces_em
|
||||
let comments = SC.CmdComments commentsAfterOpenBrace commentsAfterCmd
|
||||
return (Src.Cmd cmd comments, commentsAfterCloseBrace),
|
||||
do
|
||||
word1 0x2C {-,-} E.Effect
|
||||
spaces_em
|
||||
commentsAfterComma <- spaces_em
|
||||
sub <- chompSubscription
|
||||
spaces_em
|
||||
commentsAfterSub <- spaces_em
|
||||
word1 0x7D {-}-} E.Effect
|
||||
spaces_em
|
||||
return (Src.Fx cmd sub)
|
||||
commentsAfterCloseBrace <- spaces_em
|
||||
let cmdComments = SC.CmdComments commentsAfterOpenBrace commentsAfterCmd
|
||||
let subComments = SC.SubComments commentsAfterComma commentsAfterSub
|
||||
let comments = SC.FxComments cmdComments subComments
|
||||
return (Src.Fx cmd sub comments, commentsAfterCloseBrace)
|
||||
],
|
||||
do
|
||||
sub <- chompSubscription
|
||||
spaces_em
|
||||
commentsAfterSub <- spaces_em
|
||||
oneOf
|
||||
E.Effect
|
||||
[ do
|
||||
word1 0x7D {-}-} E.Effect
|
||||
spaces_em
|
||||
return (Src.Sub sub),
|
||||
commentsAfterCloseBrace <- spaces_em
|
||||
let comments = SC.SubComments commentsAfterOpenBrace commentsAfterSub
|
||||
return (Src.Sub sub comments, commentsAfterCloseBrace),
|
||||
do
|
||||
word1 0x2C {-,-} E.Effect
|
||||
spaces_em
|
||||
commentsAfterComma <- spaces_em
|
||||
cmd <- chompCommand
|
||||
spaces_em
|
||||
commentsAfterCmd <- spaces_em
|
||||
word1 0x7D {-}-} E.Effect
|
||||
spaces_em
|
||||
return (Src.Fx cmd sub)
|
||||
commentsAfterCloseBrace <- spaces_em
|
||||
let subComments = SC.SubComments commentsAfterOpenBrace commentsAfterSub
|
||||
let cmdComments = SC.CmdComments commentsAfterComma commentsAfterCmd
|
||||
let comments = SC.FxComments cmdComments subComments
|
||||
return (Src.Fx cmd sub comments, commentsAfterCloseBrace)
|
||||
]
|
||||
]
|
||||
|
||||
|
@ -70,6 +70,7 @@ data Error
|
||||
| NoPortModulesInPackage A.Region
|
||||
| NoEffectsOutsideKernel A.Region
|
||||
| ParseError Module
|
||||
deriving (Show)
|
||||
|
||||
-- MODULE
|
||||
|
||||
@ -104,6 +105,7 @@ data Module
|
||||
Infix Row Col
|
||||
| --
|
||||
Declarations Decl Row Col
|
||||
deriving (Show)
|
||||
|
||||
data Exposing
|
||||
= ExposingSpace Space Row Col
|
||||
@ -117,6 +119,7 @@ data Exposing
|
||||
| --
|
||||
ExposingIndentEnd Row Col
|
||||
| ExposingIndentValue Row Col
|
||||
deriving (Show)
|
||||
|
||||
-- DECLARATIONS
|
||||
|
||||
@ -129,6 +132,7 @@ data Decl
|
||||
| DeclDef Name.Name DeclDef Row Col
|
||||
| --
|
||||
DeclFreshLineAfterDocComment Row Col
|
||||
deriving (Show)
|
||||
|
||||
data DeclDef
|
||||
= DeclDefSpace Space Row Col
|
||||
@ -142,6 +146,7 @@ data DeclDef
|
||||
DeclDefIndentType Row Col
|
||||
| DeclDefIndentEquals Row Col
|
||||
| DeclDefIndentBody Row Col
|
||||
deriving (Show)
|
||||
|
||||
data Port
|
||||
= PortSpace Space Row Col
|
||||
@ -151,6 +156,7 @@ data Port
|
||||
| PortIndentName Row Col
|
||||
| PortIndentColon Row Col
|
||||
| PortIndentType Row Col
|
||||
deriving (Show)
|
||||
|
||||
-- TYPE DECLARATIONS
|
||||
|
||||
@ -161,6 +167,7 @@ data DeclType
|
||||
| DT_Union CustomType Row Col
|
||||
| --
|
||||
DT_IndentName Row Col
|
||||
deriving (Show)
|
||||
|
||||
data TypeAlias
|
||||
= AliasSpace Space Row Col
|
||||
@ -170,6 +177,7 @@ data TypeAlias
|
||||
| --
|
||||
AliasIndentEquals Row Col
|
||||
| AliasIndentBody Row Col
|
||||
deriving (Show)
|
||||
|
||||
data CustomType
|
||||
= CT_Space Space Row Col
|
||||
@ -183,6 +191,7 @@ data CustomType
|
||||
| CT_IndentBar Row Col
|
||||
| CT_IndentAfterBar Row Col
|
||||
| CT_IndentAfterEquals Row Col
|
||||
deriving (Show)
|
||||
|
||||
-- EXPRESSIONS
|
||||
|
||||
|
@ -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
|
||||
|
@ -128,6 +128,7 @@ Common gren-common
|
||||
AST.Canonical
|
||||
AST.Optimized
|
||||
AST.Source
|
||||
AST.SourceComments
|
||||
AST.Utils.Binop
|
||||
AST.Utils.Type
|
||||
Canonicalize.Effects
|
||||
@ -249,8 +250,9 @@ Test-Suite gren-tests
|
||||
Helpers.Parse
|
||||
|
||||
-- tests
|
||||
Parse.SpaceSpec
|
||||
Integration.FormatSpec
|
||||
Parse.RecordUpdateSpec
|
||||
Parse.SpaceSpec
|
||||
Parse.UnderscorePatternSpec
|
||||
|
||||
Build-Depends:
|
||||
|
@ -3,6 +3,7 @@
|
||||
module Format
|
||||
( Flags (..),
|
||||
run,
|
||||
formatByteString,
|
||||
)
|
||||
where
|
||||
|
||||
|
145
tests/Integration/FormatSpec.hs
Normal file
145
tests/Integration/FormatSpec.hs
Normal file
@ -0,0 +1,145 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- | Integration tests for formatting that cover both the parsing and formatting
|
||||
-- (tests go from text to text).
|
||||
module Integration.FormatSpec where
|
||||
|
||||
import Data.ByteString.Builder qualified as Builder
|
||||
import Data.Text (Text)
|
||||
import Data.Text qualified as Text
|
||||
import Data.Text.Encoding qualified as TE
|
||||
import Data.Text.Lazy qualified as LazyText
|
||||
import Data.Text.Lazy.Encoding qualified as LTE
|
||||
import Format qualified
|
||||
import Test.Hspec
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "module header" $ do
|
||||
let formattedModuleBody = "\n\n\nf =\n {}"
|
||||
describe "normal module" $
|
||||
do
|
||||
it "formats already formatted" $
|
||||
assertFormatted
|
||||
[ "module Normal exposing (..)",
|
||||
formattedModuleBody
|
||||
]
|
||||
it "formats" $
|
||||
[ "module ",
|
||||
" Normal ",
|
||||
" exposing ",
|
||||
" ( ",
|
||||
" .. ",
|
||||
" ) ",
|
||||
" ",
|
||||
"",
|
||||
formattedModuleBody
|
||||
]
|
||||
`shouldFormatAs` [ "module Normal exposing (..)",
|
||||
formattedModuleBody
|
||||
]
|
||||
it "formats with comments" $
|
||||
[ "{-A-}",
|
||||
"module{-B-}Normal{-C-}exposing{-D-}({-E-}..{-F-}){-G-}",
|
||||
"{-H-}",
|
||||
formattedModuleBody
|
||||
]
|
||||
`shouldFormatAs` [ "{- A -}",
|
||||
"module {- B -} Normal {- C -} exposing {- D -} (..)",
|
||||
"{- G -} {- H -}",
|
||||
formattedModuleBody
|
||||
]
|
||||
|
||||
describe "top-level definition" $ do
|
||||
it "formats already formatted" $
|
||||
assertFormattedModuleBody
|
||||
[ "f x =",
|
||||
" {}"
|
||||
]
|
||||
it "formats" $
|
||||
["f = {}"]
|
||||
`shouldFormatModuleBodyAs` [ "f =",
|
||||
" {}"
|
||||
]
|
||||
describe "expressions" $ do
|
||||
describe "record" $ do
|
||||
describe "empty" $ do
|
||||
it "formats already formatted" $
|
||||
assertFormattedExpression
|
||||
["{}"]
|
||||
it "formats" $
|
||||
[ "{",
|
||||
" }"
|
||||
]
|
||||
`shouldFormatExpressionAs` ["{}"]
|
||||
it "formats with fields" $
|
||||
["{a=1, b = 2}"]
|
||||
`shouldFormatExpressionAs` [ "{ a = 1",
|
||||
", b = 2",
|
||||
"}"
|
||||
]
|
||||
describe "parentheses" $ do
|
||||
it "removes unnecessary parentheses" $
|
||||
["(a)"]
|
||||
`shouldFormatExpressionAs` ["a"]
|
||||
describe "retains necessary parentheses" $ do
|
||||
it "protects nested function application" $
|
||||
assertFormattedExpression
|
||||
["f (g x)"]
|
||||
it "retains parentheses used to group comments" $
|
||||
assertFormattedExpression
|
||||
["({- A -} x)"]
|
||||
|
||||
assertFormatted :: [Text] -> IO ()
|
||||
assertFormatted lines_ =
|
||||
lines_ `shouldFormatAs` lines_
|
||||
|
||||
shouldFormatAs :: [Text] -> [Text] -> IO ()
|
||||
shouldFormatAs inputLines expectedOutputLines =
|
||||
let input = TE.encodeUtf8 $ Text.unlines inputLines
|
||||
expectedOutput = LazyText.unlines $ fmap LazyText.fromStrict expectedOutputLines
|
||||
actualOutput = LTE.decodeUtf8 . Builder.toLazyByteString <$> Format.formatByteString input
|
||||
in case actualOutput of
|
||||
Nothing ->
|
||||
expectationFailure "shouldFormatAs: failed to format"
|
||||
Just actualModuleBody ->
|
||||
actualModuleBody `shouldBe` expectedOutput
|
||||
|
||||
assertFormattedModuleBody :: [Text] -> IO ()
|
||||
assertFormattedModuleBody lines_ =
|
||||
lines_ `shouldFormatModuleBodyAs` lines_
|
||||
|
||||
shouldFormatModuleBodyAs :: [Text] -> [Text] -> IO ()
|
||||
shouldFormatModuleBodyAs inputLines expectedOutputLines =
|
||||
let input = TE.encodeUtf8 $ Text.unlines inputLines
|
||||
expectedOutput = LazyText.unlines $ fmap LazyText.fromStrict expectedOutputLines
|
||||
actualOutput = LTE.decodeUtf8 . Builder.toLazyByteString <$> Format.formatByteString input
|
||||
in case LazyText.stripPrefix "module Main exposing (..)\n\n\n\n" <$> actualOutput of
|
||||
Nothing ->
|
||||
expectationFailure "shouldFormatModuleBodyAs: failed to format"
|
||||
Just Nothing ->
|
||||
expectationFailure "shouldFormatModuleBodyAs: internal error: could not strip module header"
|
||||
Just (Just actualModuleBody) ->
|
||||
actualModuleBody `shouldBe` expectedOutput
|
||||
|
||||
assertFormattedExpression :: [Text] -> IO ()
|
||||
assertFormattedExpression lines_ =
|
||||
lines_ `shouldFormatExpressionAs` lines_
|
||||
|
||||
shouldFormatExpressionAs :: [Text] -> [Text] -> IO ()
|
||||
shouldFormatExpressionAs inputLines expectedOutputLines =
|
||||
let input = TE.encodeUtf8 $ "expr =\n" <> Text.unlines (fmap (" " <>) inputLines)
|
||||
expectedOutput = LazyText.unlines $ fmap LazyText.fromStrict expectedOutputLines
|
||||
actualOutput = LTE.decodeUtf8 . Builder.toLazyByteString <$> Format.formatByteString input
|
||||
cleanOutput i =
|
||||
LazyText.stripPrefix "module Main exposing (..)\n\n\n\nexpr =\n" i
|
||||
>>= (return . LazyText.lines)
|
||||
>>= traverse (LazyText.stripPrefix " ")
|
||||
>>= (return . LazyText.unlines)
|
||||
in case fmap cleanOutput actualOutput of
|
||||
Nothing ->
|
||||
expectationFailure "shouldFormatExpressionAs: failed to format"
|
||||
Just Nothing ->
|
||||
expectationFailure "shouldFormatExpressionAs: internal error: could clean output"
|
||||
Just (Just actualExpression) ->
|
||||
actualExpression `shouldBe` expectedOutput
|
Loading…
Reference in New Issue
Block a user