Merge pull request #161 from avh4/retain-comments/7-expressions

format: retain comments in remaining expressions
This commit is contained in:
Robin Heggelund Hansen 2022-11-30 08:37:06 +01:00 committed by GitHub
commit 3182e17a00
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
8 changed files with 155 additions and 55 deletions

View File

@ -9,6 +9,7 @@ module AST.Source
Expr_ (..),
VarType (..),
ArrayEntry,
BinopsSegment,
IfBranch,
CaseBranch,
RecordField,
@ -66,7 +67,7 @@ data Expr_
| Array [ArrayEntry]
| Op Name
| Negate Expr
| Binops [(Expr, [Comment], A.Located Name)] Expr
| Binops [BinopsSegment] Expr
| Lambda [([Comment], Pattern)] Expr SC.LambdaComments
| Call Expr [([Comment], Expr)]
| If [IfBranch] Expr SC.IfComments
@ -85,6 +86,9 @@ data VarType = LowVar | CapVar
type ArrayEntry =
(Expr, SC.ArrayEntryComments)
type BinopsSegment =
(Expr, A.Located Name, SC.BinopsSegmentComments)
type IfBranch =
(Expr, Expr, SC.IfBranchComments)
@ -97,8 +101,8 @@ type RecordField =
-- DEFINITIONS
data Def
= Define (A.Located Name) [([Comment], Pattern)] Expr (Maybe Type) SC.ValueComments
| Destruct Pattern Expr
= Define (A.Located Name) [([Comment], Pattern)] Expr (Maybe (Type, SC.ValueTypeComments)) SC.ValueComments
| Destruct Pattern Expr SC.ValueComments
deriving (Show)
-- PATTERN
@ -180,7 +184,7 @@ data Import = Import
}
deriving (Show)
data Value = Value (A.Located Name) [([Comment], Pattern)] Expr (Maybe Type) SC.ValueComments
data Value = Value (A.Located Name) [([Comment], Pattern)] Expr (Maybe (Type, SC.ValueTypeComments)) SC.ValueComments
deriving (Show)
data Union = Union (A.Located Name) [A.Located Name] [(A.Located Name, [([Comment], Type)])]

View File

@ -87,8 +87,21 @@ data ValueComments = ValueComments
}
deriving (Show)
data ValueTypeComments = ValueTypeComments
{ _beforeTypeColon :: [Comment],
_afterTypeColon :: [Comment],
_afterValueType :: [Comment]
}
deriving (Show)
-- Expressions
data BinopsSegmentComments = BinopsSegmentComments
{ _beforeOperator :: [Comment],
_afterOperator :: [Comment]
}
deriving (Show)
data ArrayEntryComments = ArrayEntryComments
{ _beforeArrayEntry :: [Comment],
_afterArrayEntry :: [Comment]

View File

@ -149,9 +149,9 @@ canonicalizeCaseBranch env (pattern, expr, _) =
-- CANONICALIZE BINOPS
canonicalizeBinops :: A.Region -> Env.Env -> [(Src.Expr, [Src.Comment], A.Located Name.Name)] -> Src.Expr -> Result FreeLocals [W.Warning] Can.Expr
canonicalizeBinops :: A.Region -> Env.Env -> [Src.BinopsSegment] -> 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
@ -233,7 +233,7 @@ addBindings bindings (A.At _ def) =
case def of
Src.Define (A.At region name) _ _ _ _ ->
Dups.insert name region region bindings
Src.Destruct pattern _ ->
Src.Destruct pattern _ _ ->
addBindingsHelp bindings pattern
addBindingsHelp :: Dups.Dict A.Region -> Src.Pattern -> Dups.Dict A.Region
@ -291,7 +291,7 @@ addDefNodes env nodes (A.At _ def) =
let cdef = Can.Def aname args cbody
let node = (Define cdef, name, Map.keys freeLocals)
logLetLocals args freeLocals (node : nodes)
Just tipe ->
Just (tipe, _) ->
do
(Can.Forall freeVars ctipe) <- Type.toAnnotation env tipe
((args, resultType), argBindings) <-
@ -307,7 +307,7 @@ addDefNodes env nodes (A.At _ def) =
let cdef = Can.TypedDef aname freeVars args cbody resultType
let node = (Define cdef, name, Map.keys freeLocals)
logLetLocals args freeLocals (node : nodes)
Src.Destruct pattern body ->
Src.Destruct pattern body _ ->
do
(cpattern, _bindings) <-
Pattern.verify Error.DPDestruct $

View File

@ -141,7 +141,7 @@ toNodeOne env (A.At _ (Src.Value aname@(A.At _ name) srcArgs body maybeType _))
name,
Map.keys freeLocals
)
Just srcType ->
Just (srcType, _) ->
do
(Can.Forall freeVars tipe) <- Type.toAnnotation env srcType

View File

@ -405,9 +405,9 @@ formatAssociativity = \case
formatValue :: Src.Value -> Block
formatValue (Src.Value name args body type_ comments) =
formatBasicDef (A.toValue name) args (A.toValue body) (fmap A.toValue type_) comments
formatBasicDef (A.toValue name) args (A.toValue body) type_ comments
formatBasicDef :: Name -> [([Src.Comment], Src.Pattern)] -> Src.Expr_ -> Maybe Src.Type_ -> SC.ValueComments -> Block
formatBasicDef :: Name -> [([Src.Comment], Src.Pattern)] -> Src.Expr_ -> Maybe (Src.Type, SC.ValueTypeComments) -> SC.ValueComments -> Block
formatBasicDef name args body type_ (SC.ValueComments commentsBeforeEquals commentsBeforeBody commentsAfterBody) =
Block.stack $
NonEmpty.fromList $
@ -432,11 +432,19 @@ formatBasicDef name args body type_ (SC.ValueComments commentsBeforeEquals comme
patternParensProtectSpaces $
formatPattern (A.toValue pat)
formatTypeAnnotation :: Maybe String -> Name -> Src.Type_ -> Block
formatTypeAnnotation prefix name t =
spaceOrIndent
[ Block.line $ withPrefix $ utf8 name <> Block.space <> Block.char7 ':',
typeParensNone $ formatType t
formatTypeAnnotation :: Maybe String -> Name -> (Src.Type, SC.ValueTypeComments) -> Block
formatTypeAnnotation prefix name (t, SC.ValueTypeComments commentsBeforeColon commentsAfterColon commentsAfterType) =
spaceOrIndent $
[ spaceOrStack $
NonEmpty.fromList $
catMaybes
[ Just $ Block.line $ withPrefix $ utf8 name,
formatCommentBlock commentsBeforeColon,
Just $ Block.line $ Block.char7 ':'
],
withCommentsAround commentsAfterColon commentsAfterType $
typeParensNone $
formatType (A.toValue t)
]
where
withPrefix a =
@ -486,7 +494,7 @@ formatAlias (Src.Alias name args type_) =
formatPort :: Src.Port -> Block
formatPort = \case
Src.Port name type_ ->
formatTypeAnnotation (Just "port") (A.toValue name) (A.toValue type_)
formatTypeAnnotation (Just "port") (A.toValue name) (type_, SC.ValueTypeComments [] [] [])
data ExpressionBlock
= NoExpressionParens Block
@ -566,17 +574,21 @@ formatExpr = \case
in ExpressionContainsInfixOps $
spaceOrIndentForce forceMultiline $
exprParensProtectInfixOps (formatExpr $ A.toValue first)
:| fmap formatPair rest
:| fmap formatSegment rest
where
-- for now we just use multiline formatting for specific operators,
-- since we don't yet track where the linebreaks are in the source
forceMultiline = any (opForcesMultiline . opFromPair) postfixOps
opFromPair (_, _, name) = A.toValue name
formatPair (commentsBeforeOp, op, expr) =
Block.prefix
4
(utf8 (A.toValue op) <> Block.space)
(exprParensProtectInfixOps $ formatExpr $ A.toValue expr)
forceMultiline = any (opForcesMultiline . opFromSegment) postfixOps
opFromSegment (_, name, _) = A.toValue name
formatSegment (op, SC.BinopsSegmentComments commentsBeforeOp commentsAfterOp, expr) =
withCommentsBefore commentsBeforeOp $
Block.prefix
4
(utf8 (A.toValue op) <> Block.space)
( withCommentsBefore commentsAfterOp $
exprParensProtectInfixOps $
formatExpr (A.toValue expr)
)
Src.Lambda [] body _ ->
formatExpr $ A.toValue body
Src.Lambda (arg1 : args) body (SC.LambdaComments commentsBeforeArrow commentsAfterArrow) ->
@ -609,7 +621,8 @@ formatExpr = \case
:| fmap formatArg args
where
formatArg (commentsBefore, arg) =
exprParensProtectSpaces (formatExpr $ A.toValue arg)
withCommentsBefore commentsBefore $
exprParensProtectSpaces (formatExpr $ A.toValue arg)
Src.If [] else_ _ ->
formatExpr $ A.toValue else_
Src.If (if_ : elseifs) else_ (SC.IfComments commentsBeforeElseBody commentsAfterElseBody) ->
@ -765,14 +778,19 @@ formatDef (commentsBefore, def) =
withCommentsStackBefore commentsBefore $
case A.toValue def of
Src.Define name args body ann comments ->
formatBasicDef (A.toValue name) args (A.toValue body) (fmap A.toValue ann) comments
Src.Destruct pat body ->
formatBasicDef (A.toValue name) args (A.toValue body) ann comments
Src.Destruct pat body (SC.ValueComments commentsBeforeEquals commentsBeforeBody commentsAfterBody) ->
Block.stack
[ spaceOrIndent
[ patternParensProtectSpaces $ formatPattern $ A.toValue pat,
[ withCommentsAround [] commentsBeforeEquals $
patternParensProtectSpaces $
formatPattern (A.toValue pat),
Block.line $ Block.char7 '='
],
Block.indent $ exprParensNone $ formatExpr $ A.toValue body
Block.indent $
withCommentsStackAround commentsBeforeBody commentsAfterBody $
exprParensNone $
formatExpr (A.toValue body)
]
data TypeBlock

View File

@ -79,16 +79,17 @@ valueDecl maybeDocs start =
[ do
word1 0x3A {-:-} E.DeclDefEquals
let commentsBeforeColon = commentsAfterName
Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentType
commentsAfterColon <- Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentType
((tipe, commentsAfterTipe), _) <- specialize E.DeclDefType Type.expression
Space.checkFreshLine E.DeclDefNameRepeat
defName <- chompMatchingName name
commentsAfterMatchingName <- Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals
chompDefArgsAndBody maybeDocs start defName (Just tipe) [] commentsAfterMatchingName,
let tipeComments = SC.ValueTypeComments commentsBeforeColon commentsAfterColon commentsAfterTipe
chompDefArgsAndBody maybeDocs start defName (Just (tipe, tipeComments)) [] commentsAfterMatchingName,
chompDefArgsAndBody maybeDocs start (A.at start end name) Nothing [] commentsAfterName
]
chompDefArgsAndBody :: Maybe Src.DocComment -> A.Position -> A.Located Name.Name -> Maybe Src.Type -> [([Src.Comment], Src.Pattern)] -> [Src.Comment] -> Space.Parser E.DeclDef (Decl, [Src.Comment])
chompDefArgsAndBody :: Maybe Src.DocComment -> A.Position -> A.Located Name.Name -> Maybe (Src.Type, SC.ValueTypeComments) -> [([Src.Comment], Src.Pattern)] -> [Src.Comment] -> Space.Parser E.DeclDef (Decl, [Src.Comment])
chompDefArgsAndBody maybeDocs start name tipe revArgs commentsBefore =
oneOf
E.DeclDefEquals

View File

@ -1,8 +1,4 @@
{-# LANGUAGE OverloadedStrings #-}
-- Temporary while implementing gren format
{-# OPTIONS_GHC -Wno-error=unused-do-bind #-}
{-# OPTIONS_GHC -Wno-error=unused-local-binds #-}
{-# OPTIONS_GHC -Wno-error=unused-matches #-}
module Parse.Expression
( expression,
@ -265,7 +261,7 @@ expression =
]
data State = State
{ _ops :: ![(Src.Expr, [Src.Comment], A.Located Name.Name)],
{ _ops :: ![Src.BinopsSegment],
_expr :: !Src.Expr,
_args :: ![([Src.Comment], Src.Expr)],
_end :: !A.Position,
@ -286,7 +282,7 @@ chompExprEnd start (State ops expr args end commentsBefore) =
do
Space.checkIndent end E.Start
op@(A.At (A.Region opStart opEnd) opName) <- addLocation (Symbol.operator E.Start E.OperatorReserved)
Space.chompAndCheckIndent E.Space (E.IndentOperatorRight opName)
commentsAfterOp <- Space.chompAndCheckIndent E.Space (E.IndentOperatorRight opName)
newStart <- getPosition
if "-" == opName && end /= opStart && opEnd == newStart
then -- negative terms
@ -298,6 +294,7 @@ chompExprEnd start (State ops expr args end commentsBefore) =
chompExprEnd start (State ops expr ((commentsBefore, arg) : args) newEnd commentsAfter)
else
let err = E.OperatorRight opName
opComments = SC.BinopsSegmentComments commentsBefore commentsAfterOp
in oneOf
err
[ -- term
@ -305,7 +302,7 @@ chompExprEnd start (State ops expr args end commentsBefore) =
newExpr <- possiblyNegativeTerm newStart
newEnd <- getPosition
commentsAfter <- Space.chomp E.Space
let newOps = (toCall expr args, commentsBefore, op) : ops
let newOps = (toCall expr args, op, opComments) : ops
chompExprEnd start (State newOps newExpr [] newEnd commentsAfter),
-- final term
do
@ -317,7 +314,7 @@ chompExprEnd start (State ops expr args end commentsBefore) =
if_ newStart,
function newStart
]
let newOps = (toCall expr args, commentsBefore, op) : ops
let newOps = (toCall expr args, op, opComments) : ops
let finalExpr = Src.Binops (reverse newOps) newLast
return ((A.at start newEnd finalExpr, commentsAfter), newEnd)
]
@ -521,17 +518,17 @@ definition =
E.DefEquals
[ do
word1 0x3A {-:-} E.DefEquals
let commentsBeforeColon = commentsAfterName
Space.chompAndCheckIndent E.DefSpace E.DefIndentType
commentsAfterColon <- Space.chompAndCheckIndent E.DefSpace E.DefIndentType
((tipe, commentsAfterTipe), _) <- specialize E.DefType Type.expression
Space.checkAligned E.DefAlignment
defName <- chompMatchingName name
commentsAfterMatchingName <- Space.chompAndCheckIndent E.DefSpace E.DefIndentEquals
chompDefArgsAndBody start defName (Just tipe) [] commentsAfterMatchingName,
let tipeComments = SC.ValueTypeComments commentsAfterName commentsAfterColon commentsAfterTipe
chompDefArgsAndBody start defName (Just (tipe, tipeComments)) [] commentsAfterMatchingName,
chompDefArgsAndBody start aname Nothing [] commentsAfterName
]
chompDefArgsAndBody :: A.Position -> A.Located Name.Name -> Maybe Src.Type -> [([Src.Comment], Src.Pattern)] -> [Src.Comment] -> Space.Parser E.Def (A.Located Src.Def, [Src.Comment])
chompDefArgsAndBody :: A.Position -> A.Located Name.Name -> Maybe (Src.Type, SC.ValueTypeComments) -> [([Src.Comment], Src.Pattern)] -> [Src.Comment] -> Space.Parser E.Def (A.Located Src.Def, [Src.Comment])
chompDefArgsAndBody start@(A.Position _ startCol) name tipe revArgs commentsBefore =
oneOf
E.DefEquals
@ -572,10 +569,12 @@ destructure :: Space.Parser E.Let (A.Located Src.Def, [Src.Comment])
destructure =
specialize E.LetDestruct $
do
start <- getPosition
start@(A.Position _ startCol) <- getPosition
pattern <- specialize E.DestructPattern Pattern.term
Space.chompAndCheckIndent E.DestructSpace E.DestructIndentEquals
commentsAfterPattern <- Space.chompAndCheckIndent E.DestructSpace E.DestructIndentEquals
word1 0x3D {-=-} E.DestructEquals
Space.chompAndCheckIndent E.DestructSpace E.DestructIndentBody
commentsAfterEquals <- Space.chompAndCheckIndent E.DestructSpace E.DestructIndentBody
((expr, commentsAfter), end) <- specialize E.DestructBody expression
return ((A.at start end (Src.Destruct pattern expr), commentsAfter), end)
let (commentsAfterBody, commentsAfterDef) = List.span (A.isIndentedMoreThan startCol) commentsAfter
let comments = SC.ValueComments commentsAfterPattern commentsAfterEquals commentsAfterBody
return ((A.at start end (Src.Destruct pattern expr comments), commentsAfterDef), end)

View File

@ -126,7 +126,7 @@ spec = do
formattedModuleBody
]
describe "top-level definition" $ do
describe "top-level definitions" $ do
it "formats already formatted" $
assertFormattedModuleBody
[ "f x =",
@ -281,14 +281,23 @@ spec = do
" {- D -}",
" []"
]
it "formats indented comments after the body" $ do
it "formats indented comments after the body" $
[ "f = []",
" {-B-}"
]
]
`shouldFormatModuleBodyAs` [ "f =",
" []",
" {- B -}"
]
it "formats comments in type annotations" $
[ "f{-A-}:{-B-}Int{-C-}",
"f =",
" 0"
]
`shouldFormatModuleBodyAs` [ "f {- A -} : {- B -} Int {- C -}",
"f =",
" 0"
]
describe "expressions" $ do
describe "array literals" $ do
@ -316,11 +325,38 @@ spec = do
"]"
]
describe "unary operators (negation)" $ do
it "formats" $
["-x"]
`shouldFormatExpressionAs` ["-x"]
it "formats multiline value" $
[ "-(x --A",
")"
]
`shouldFormatExpressionAs` [ "-(x",
" -- A",
" )"
]
describe "binary operators" $ do
it "formats" $
["1+2*3"]
`shouldFormatExpressionAs` ["1 + 2 * 3"]
it "formats comments" $
["1{-A-}+{-B-}2{-C-}*{-D-}3"]
`shouldFormatExpressionAs` ["1 {- A -} + {- B -} 2 {- C -} * {- D -} 3"]
describe "lambda" $ do
it "formats comments" $
["\\{-A-}x{-B-}y{-C-}->{-D-}[]"]
`shouldFormatExpressionAs` ["\\{- A -} x {- B -} y {- C -} -> {- D -} []"]
describe "function call" $ do
it "formats comments" $
["f{-A-}x{-B-}y{-C-}z"]
`shouldFormatExpressionAs` ["f {- A -} x {- B -} y {- C -} z"]
describe "if" $ do
it "formats comments" $
["if{-A-}x{-B-}then{-C-}1{-D-}else{-E-}if{-F-}y{-G-}then{-H-}2{-I-}else{-J-}3"]
@ -361,6 +397,28 @@ spec = do
"{- C -}",
"x"
]
it "formats comments in type annotations" $
[ "let f{-A-}:{-B-}Int{-C-}",
" f =",
" 0",
"in x"
]
`shouldFormatExpressionAs` [ "let",
" f {- A -} : {- B -} Int {- C -}",
" f =",
" 0",
"in",
"x"
]
it "formats comments in destructure declarations" $
["let{ x, y }{-A-}={-B-}r in x"]
`shouldFormatExpressionAs` [ "let",
" { x, y } {- A -} =",
" {- B -}",
" r",
"in",
"x"
]
it "formats comments between and after declarations" $
[ "let",
" x = 1",
@ -387,12 +445,18 @@ spec = do
[ "let",
" x = 1",
" {-A-}",
" {y,z} = r",
" {-B-}",
"in x"
]
`shouldFormatExpressionAs` [ "let",
" x =",
" 1",
" {- A -}",
"",
" { y, z } =",
" r",
" {- B -}",
"in",
"x"
]
@ -469,6 +533,7 @@ spec = do
" b {- F -} = {- G -} 2 {- H -}",
"}"
]
describe "record update" $ do
it "formats" $
["{base|a=1,b=2}"]
@ -583,8 +648,8 @@ shouldFormatModuleBodyAs inputLines expectedOutputLines =
expectedOutput = LazyText.unlines $ fmap LazyText.fromStrict expectedOutputLines
actualOutput = LTE.decodeUtf8 . Builder.toLazyByteString <$> Format.formatByteString Parse.Application input
in case LazyText.stripPrefix "module Main exposing (..)\n\n\n\n" <$> actualOutput of
Left _ ->
expectationFailure "shouldFormatModuleBodyAs: failed to format"
Left err ->
expectationFailure ("shouldFormatModuleBodyAs: failed to format" <> show err)
Right Nothing ->
expectationFailure "shouldFormatModuleBodyAs: internal error: could not strip module header"
Right (Just actualModuleBody) ->