diff --git a/compiler/src/AST/Source.hs b/compiler/src/AST/Source.hs index 82803eead..d1909db2b 100644 --- a/compiler/src/AST/Source.hs +++ b/compiler/src/AST/Source.hs @@ -8,6 +8,8 @@ module AST.Source Expr, Expr_ (..), VarType (..), + IfBranch, + CaseBranch, Def (..), Pattern, Pattern_ (..), @@ -63,9 +65,9 @@ data Expr_ | Binops [(Expr, [Comment], A.Located Name)] Expr | Lambda [([Comment], Pattern)] Expr SC.LambdaComments | Call Expr [([Comment], Expr)] - | If [(Expr, Expr)] Expr + | If [IfBranch] Expr SC.IfComments | Let [([Comment], A.Located Def)] Expr SC.LetComments - | Case Expr [([Comment], Pattern, Expr)] + | Case Expr [CaseBranch] SC.CaseComments | Accessor Name | Access Expr (A.Located Name) | Update Expr [(A.Located Name, Expr)] @@ -76,6 +78,12 @@ data Expr_ data VarType = LowVar | CapVar deriving (Show) +type IfBranch = + (Expr, Expr, SC.IfBranchComments) + +type CaseBranch = + (Pattern, Expr, SC.CaseBranchComments) + -- DEFINITIONS data Def @@ -92,8 +100,8 @@ data Pattern_ | PVar Name | PRecord [RecordFieldPattern] | PAlias Pattern (A.Located Name) - | PCtor A.Region Name [Pattern] - | PCtorQual A.Region Name Name [Pattern] + | PCtor A.Region Name [([Comment], Pattern)] + | PCtorQual A.Region Name Name [([Comment], Pattern)] | PArray [Pattern] | PChr ES.String | PStr ES.String diff --git a/compiler/src/AST/SourceComments.hs b/compiler/src/AST/SourceComments.hs index 1b1a67727..fb5aa52d8 100644 --- a/compiler/src/AST/SourceComments.hs +++ b/compiler/src/AST/SourceComments.hs @@ -95,8 +95,36 @@ data LambdaComments = LambdaComments } deriving (Show) +data IfComments = IfComments + { _beforeElseBody :: [Comment], + _afterElseBody :: [Comment] + } + deriving (Show) + +data IfBranchComments = IfBranchComments + { _afterIfKeyword :: [Comment], + _beforeThenKeyword :: [Comment], + _beforeThenBody :: [Comment], + _afterThenBody :: [Comment] + } + deriving (Show) + data LetComments = LetComments { _afterLetDecls :: [Comment], _afterIn :: [Comment] } deriving (Show) + +data CaseComments = CaseComments + { _afterCaseKeyword :: [Comment], + _beforeOfKeyword :: [Comment] + } + deriving (Show) + +data CaseBranchComments = CaseBranchComments + { _beforeBranch :: [Comment], + _beforeBranchArrow :: [Comment], + _beforeBranchBody :: [Comment], + _afterBranchBody :: [Comment] + } + deriving (Show) diff --git a/compiler/src/Canonicalize/Expression.hs b/compiler/src/Canonicalize/Expression.hs index 15d4f1119..bd8b811e3 100644 --- a/compiler/src/Canonicalize/Expression.hs +++ b/compiler/src/Canonicalize/Expression.hs @@ -94,13 +94,13 @@ canonicalize env (A.At region expression) = Can.Call <$> canonicalize env func <*> traverse (canonicalize env) (fmap snd args) - Src.If branches finally -> + Src.If branches finally _ -> Can.If <$> traverse (canonicalizeIfBranch env) branches <*> canonicalize env finally Src.Let defs expr _ -> A.toValue <$> canonicalizeLet region env (fmap snd defs) expr - Src.Case expr branches -> + Src.Case expr branches _ -> Can.Case <$> canonicalize env expr <*> traverse (canonicalizeCaseBranch env) branches @@ -125,16 +125,16 @@ canonicalize env (A.At region expression) = -- CANONICALIZE IF BRANCH -canonicalizeIfBranch :: Env.Env -> (Src.Expr, Src.Expr) -> Result FreeLocals [W.Warning] (Can.Expr, Can.Expr) -canonicalizeIfBranch env (condition, branch) = +canonicalizeIfBranch :: Env.Env -> Src.IfBranch -> Result FreeLocals [W.Warning] (Can.Expr, Can.Expr) +canonicalizeIfBranch env (condition, branch, _) = (,) <$> canonicalize env condition <*> canonicalize env branch -- CANONICALIZE CASE BRANCH -canonicalizeCaseBranch :: Env.Env -> ([Src.Comment], Src.Pattern, Src.Expr) -> Result FreeLocals [W.Warning] Can.CaseBranch -canonicalizeCaseBranch env (_, pattern, expr) = +canonicalizeCaseBranch :: Env.Env -> Src.CaseBranch -> Result FreeLocals [W.Warning] Can.CaseBranch +canonicalizeCaseBranch env (pattern, expr, _) = directUsage $ do (cpattern, bindings) <- @@ -246,9 +246,9 @@ addBindingsHelp bindings (A.At region pattern) = Src.PRecord fields -> List.foldl' addBindingsHelp bindings (map extractRecordFieldPattern fields) Src.PCtor _ _ patterns -> - List.foldl' addBindingsHelp bindings patterns + List.foldl' addBindingsHelp bindings (fmap snd patterns) Src.PCtorQual _ _ _ patterns -> - List.foldl' addBindingsHelp bindings patterns + List.foldl' addBindingsHelp bindings (fmap snd patterns) Src.PArray patterns -> List.foldl' addBindingsHelp bindings patterns Src.PAlias aliasPattern (A.At nameRegion name) -> @@ -356,8 +356,8 @@ getPatternNames names (A.At region pattern) = Src.PRecord fields -> List.foldl' (\n f -> getPatternNames n (extractRecordFieldPattern f)) names fields Src.PAlias ptrn name -> getPatternNames (name : names) ptrn - Src.PCtor _ _ args -> List.foldl' getPatternNames names args - Src.PCtorQual _ _ _ args -> List.foldl' getPatternNames names args + Src.PCtor _ _ args -> List.foldl' getPatternNames names (fmap snd args) + Src.PCtorQual _ _ _ args -> List.foldl' getPatternNames names (fmap snd args) Src.PArray patterns -> List.foldl' getPatternNames names patterns Src.PChr _ -> names Src.PStr _ -> names diff --git a/compiler/src/Canonicalize/Pattern.hs b/compiler/src/Canonicalize/Pattern.hs index 22f0934ff..23a8f3f05 100644 --- a/compiler/src/Canonicalize/Pattern.hs +++ b/compiler/src/Canonicalize/Pattern.hs @@ -65,9 +65,9 @@ canonicalize env (A.At region pattern) = Src.PRecord fields -> Can.PRecord <$> canonicalizeRecordFields env fields Src.PCtor nameRegion name patterns -> - canonicalizeCtor env region name patterns =<< Env.findCtor nameRegion env name + canonicalizeCtor env region name (fmap snd patterns) =<< Env.findCtor nameRegion env name Src.PCtorQual nameRegion home name patterns -> - canonicalizeCtor env region name patterns =<< Env.findCtorQual nameRegion env home name + canonicalizeCtor env region name (fmap snd patterns) =<< Env.findCtorQual nameRegion env home name Src.PArray patterns -> Can.PArray <$> canonicalizeList env patterns Src.PAlias ptrn (A.At reg name) -> diff --git a/compiler/src/Gren/Format.hs b/compiler/src/Gren/Format.hs index ff3123016..42b0169cb 100644 --- a/compiler/src/Gren/Format.hs +++ b/compiler/src/Gren/Format.hs @@ -579,33 +579,44 @@ formatExpr = \case where formatArg (commentsBefore, arg) = exprParensProtectSpaces (formatExpr $ A.toValue arg) - Src.If [] else_ -> + Src.If [] else_ _ -> formatExpr $ A.toValue else_ - Src.If (if_ : elseifs) else_ -> + Src.If (if_ : elseifs) else_ (SC.IfComments commentsBeforeElseBody commentsAfterElseBody) -> ExpressionHasAmbiguousEnd $ Block.stack $ NonEmpty.fromList $ mconcat - [ List.singleton $ formatIfClause "if" if_, - fmap (formatIfClause "else if") elseifs, + [ List.singleton $ formatIfBranch "if" if_, + fmap (formatIfBranch "else if") elseifs, List.singleton $ Block.stack [ Block.line $ Block.string7 "else", - Block.indent $ exprParensNone $ formatExpr $ A.toValue else_ + Block.indent $ + withCommentsStackAround commentsBeforeElseBody commentsAfterElseBody $ + exprParensNone $ + formatExpr $ + A.toValue else_ ] ] where - formatIfClause :: String -> (Src.Expr, Src.Expr) -> Block - formatIfClause keyword (predicate, body) = + formatIfBranch :: String -> Src.IfBranch -> Block + formatIfBranch keyword (predicate, body, SC.IfBranchComments commentsAfterIf commentsBeforeThen commentsBeforeBody commentsAfterBody) = Block.stack [ spaceOrStack [ spaceOrIndent [ Block.line $ Block.string7 keyword, - exprParensNone $ formatExpr $ A.toValue predicate + withCommentsAround commentsAfterIf commentsBeforeThen $ + exprParensNone $ + formatExpr $ + A.toValue predicate ], Block.line $ Block.string7 "then" ], - Block.indent $ exprParensNone $ formatExpr $ A.toValue body + Block.indent $ + withCommentsStackAround commentsBeforeBody commentsAfterBody $ + exprParensNone $ + formatExpr $ + A.toValue body ] Src.Let [] body _ -> formatExpr $ A.toValue body @@ -624,26 +635,35 @@ formatExpr = \case ], withCommentsStackBefore commentsAfterIn $ exprParensNone $ formatExpr (A.toValue body) ] - Src.Case subject branches -> + Src.Case subject branches (SC.CaseComments commentsAfterCaseKeyword commentsBeforeOfKeyword) -> ExpressionHasAmbiguousEnd $ Block.stack $ spaceOrStack [ spaceOrIndent [ Block.line (Block.string7 "case"), - exprParensNone $ formatExpr (A.toValue subject) + withCommentsAround commentsAfterCaseKeyword commentsBeforeOfKeyword $ + exprParensNone $ + formatExpr (A.toValue subject) ], Block.line (Block.string7 "of") ] :| List.intersperse Block.blankLine (fmap (Block.indent . formatCaseBranch) branches) where - formatCaseBranch (commentsBefore, pat, expr) = - Block.stack - [ spaceOrStack - [ patternParensNone $ formatPattern (A.toValue pat), - Block.line $ Block.string7 "->" - ], - Block.indent $ exprParensNone $ formatExpr $ A.toValue expr - ] + formatCaseBranch (pat, expr, SC.CaseBranchComments commentsBefore commentsAfterPattern commentsBeforeBody commentsAfterBody) = + withCommentsStackBefore commentsBefore $ + Block.stack + [ spaceOrStack + [ withCommentsAround [] commentsAfterPattern $ + patternParensNone $ + formatPattern (A.toValue pat), + Block.line $ Block.string7 "->" + ], + Block.indent $ + withCommentsStackAround commentsBeforeBody commentsAfterBody $ + exprParensNone $ + formatExpr $ + A.toValue expr + ] Src.Accessor field -> NoExpressionParens $ Block.line $ @@ -857,7 +877,7 @@ formatPattern = \case PatternContainsSpaces $ spaceOrIndent $ Block.line (utf8 name) - :| fmap (patternParensProtectSpaces . formatPattern . A.toValue) args + :| fmap (patternParensProtectSpaces . formatPatternConstructorArg) args Src.PCtorQual _ ns name [] -> NoPatternParens $ Block.line (utf8 ns <> Block.char7 '.' <> utf8 name) @@ -865,7 +885,7 @@ formatPattern = \case PatternContainsSpaces $ spaceOrIndent $ Block.line (utf8 ns <> Block.char7 '.' <> utf8 name) - :| fmap (patternParensProtectSpaces . formatPattern . A.toValue) args + :| fmap (patternParensProtectSpaces . formatPatternConstructorArg) args Src.PArray items -> NoPatternParens $ group '[' ',' ']' False $ @@ -881,6 +901,10 @@ formatPattern = \case Block.line $ Block.string7 (show int) +formatPatternConstructorArg :: ([Src.Comment], Src.Pattern) -> PatternBlock +formatPatternConstructorArg (commentsBefore, pat) = + formatPattern (A.toValue pat) + data StringStyle = StringStyleChar | StringStyleSingleQuoted diff --git a/compiler/src/Parse/Declaration.hs b/compiler/src/Parse/Declaration.hs index 7ac92523c..befd96803 100644 --- a/compiler/src/Parse/Declaration.hs +++ b/compiler/src/Parse/Declaration.hs @@ -100,7 +100,7 @@ chompDefArgsAndBody maybeDocs start name tipe revArgs commentsBefore = word1 0x3D {-=-} E.DeclDefEquals commentsAfterEquals <- Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentBody ((body, commentsAfter), end) <- specialize E.DeclDefBody Expr.expression - let (commentsAfterBody, commentsAfterDef) = List.span (A.isIndentedAtLeast 2) commentsAfter + let (commentsAfterBody, commentsAfterDef) = List.span (A.isIndentedMoreThan 1) commentsAfter let comments = SC.ValueComments commentsBefore commentsAfterEquals commentsAfterBody let value = Src.Value name (reverse revArgs) body tipe comments let avalue = A.at start end value diff --git a/compiler/src/Parse/Expression.hs b/compiler/src/Parse/Expression.hs index 7f8ce8f3c..781329104 100644 --- a/compiler/src/Parse/Expression.hs +++ b/compiler/src/Parse/Expression.hs @@ -352,30 +352,33 @@ toCall func revArgs = if_ :: A.Position -> Space.Parser E.Expr (Src.Expr, [Src.Comment]) if_ start = inContext E.If (Keyword.if_ E.Start) $ - chompIfEnd start [] + chompIfEnd start [] [] -chompIfEnd :: A.Position -> [(Src.Expr, Src.Expr)] -> Space.Parser E.If (Src.Expr, [Src.Comment]) -chompIfEnd start branches = +chompIfEnd :: A.Position -> [Src.IfBranch] -> [Src.Comment] -> Space.Parser E.If (Src.Expr, [Src.Comment]) +chompIfEnd start@(A.Position _ indent) branches commentsBefore = do - Space.chompAndCheckIndent E.IfSpace E.IfIndentCondition + commentsBeforeCondition <- Space.chompAndCheckIndent E.IfSpace E.IfIndentCondition ((condition, commentsAfterCondition), condEnd) <- specialize E.IfCondition expression Space.checkIndent condEnd E.IfIndentThen Keyword.then_ E.IfThen - Space.chompAndCheckIndent E.IfSpace E.IfIndentThenBranch - ((thenBranch, commentsAfterThen), thenEnd) <- specialize E.IfThenBranch expression + commentsAfterThenKeyword <- Space.chompAndCheckIndent E.IfSpace E.IfIndentThenBranch + ((thenBranch, commentsAfterThenBody), thenEnd) <- specialize E.IfThenBranch expression Space.checkIndent thenEnd E.IfIndentElse Keyword.else_ E.IfElse - Space.chompAndCheckIndent E.IfSpace E.IfIndentElseBranch - let newBranches = (condition, thenBranch) : branches + commentsAfterElseKeyword <- Space.chompAndCheckIndent E.IfSpace E.IfIndentElseBranch + let branchComments = SC.IfBranchComments (commentsBefore ++ commentsBeforeCondition) commentsAfterCondition commentsAfterThenKeyword commentsAfterThenBody + let newBranches = (condition, thenBranch, branchComments) : branches oneOf E.IfElseBranchStart [ do Keyword.if_ E.IfElseBranchStart - chompIfEnd start newBranches, + chompIfEnd start newBranches commentsAfterElseKeyword, do - ((elseBranch, commentsAfterElse), elseEnd) <- specialize E.IfElseBranch expression - let ifExpr = Src.If (reverse newBranches) elseBranch - return ((A.at start elseEnd ifExpr, commentsAfterElse), elseEnd) + ((elseBranch, commentsAfterExpr), elseEnd) <- specialize E.IfElseBranch expression + let (commentsAfterElseBody, commentsAfter) = List.span (A.isIndentedMoreThan indent) commentsAfterExpr + let ifComments = SC.IfComments commentsAfterElseKeyword commentsAfterElseBody + let ifExpr = Src.If (reverse newBranches) elseBranch ifComments + return ((A.at start elseEnd ifExpr, commentsAfter), elseEnd) ] -- LAMBDA EXPRESSION @@ -413,38 +416,41 @@ 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 + commentsBeforeExpr <- Space.chompAndCheckIndent E.CaseSpace E.CaseIndentExpr ((expr, commentsAfterExpr), exprEnd) <- specialize E.CaseExpr expression Space.checkIndent exprEnd E.CaseIndentOf Keyword.of_ E.CaseOf commentsAfterOf <- Space.chompAndCheckIndent E.CaseSpace E.CaseIndentPattern withIndent $ do - ((branchPat, branchExpr, commentsAfterFirstBranch), firstEnd) <- chompBranch - let firstBranch = (commentsAfterOf, branchPat, branchExpr) + ((firstBranch, commentsAfterFirstBranch), firstEnd) <- chompBranch commentsAfterOf ((branches, commentsAfterLastBranch), end) <- chompCaseEnd [firstBranch] commentsAfterFirstBranch firstEnd + let caseComments = SC.CaseComments commentsBeforeExpr commentsAfterExpr return - ( (A.at start end (Src.Case expr branches), commentsAfterLastBranch), + ( (A.at start end (Src.Case expr branches caseComments), commentsAfterLastBranch), end ) -chompBranch :: Space.Parser E.Case (Src.Pattern, Src.Expr, [Src.Comment]) -chompBranch = +chompBranch :: [Src.Comment] -> Space.Parser E.Case (Src.CaseBranch, [Src.Comment]) +chompBranch commentsBeforeBranch = do - (pattern, patternEnd) <- specialize E.CasePattern Pattern.expression + indent <- getCol + ((pattern, commentsAfterPattern), patternEnd) <- specialize E.CasePattern Pattern.expression Space.checkIndent patternEnd E.CaseIndentArrow word2 0x2D 0x3E {-->-} E.CaseArrow - Space.chompAndCheckIndent E.CaseSpace E.CaseIndentBranch - ((branchExpr, commentsAfterBranch), end) <- specialize E.CaseBranch expression - return ((pattern, branchExpr, commentsAfterBranch), end) - -chompCaseEnd :: [([Src.Comment], Src.Pattern, Src.Expr)] -> [Src.Comment] -> A.Position -> Space.Parser E.Case ([([Src.Comment], Src.Pattern, Src.Expr)], [Src.Comment]) + commentsAfterArrow <- Space.chompAndCheckIndent E.CaseSpace E.CaseIndentBranch + ((branchExpr, commentsAfterBranchExpr), end) <- specialize E.CaseBranch expression + let (commentsAfterBranchBody, commentsAfterBranch) = List.span (A.isIndentedMoreThan indent) commentsAfterBranchExpr + let branchComments = SC.CaseBranchComments commentsBeforeBranch commentsAfterPattern commentsAfterArrow commentsAfterBranchBody + let branch = (pattern, branchExpr, branchComments) + return ((branch, commentsAfterBranch), end) + +chompCaseEnd :: [Src.CaseBranch] -> [Src.Comment] -> A.Position -> Space.Parser E.Case ([Src.CaseBranch], [Src.Comment]) chompCaseEnd branches commentsBetween end = oneOfWithFallback [ do Space.checkAligned E.CasePatternAlignment - ((pat, expr, commentsAfter), newEnd) <- chompBranch - let branch = (commentsBetween, pat, expr) + ((branch, commentsAfter), newEnd) <- chompBranch commentsBetween chompCaseEnd (branch : branches) commentsAfter newEnd ] ((reverse branches, commentsBetween), end) @@ -529,7 +535,7 @@ chompDefArgsAndBody start@(A.Position _ startCol) name tipe revArgs commentsBefo word1 0x3D {-=-} E.DefEquals commentsAfterEquals <- Space.chompAndCheckIndent E.DefSpace E.DefIndentBody ((body, commentsAfter), end) <- specialize E.DefBody expression - let (commentsAfterBody, commentsAfterDef) = List.span (A.isIndentedAtLeast (startCol + 1)) commentsAfter + let (commentsAfterBody, commentsAfterDef) = List.span (A.isIndentedMoreThan startCol) commentsAfter let comments = SC.ValueComments commentsBefore commentsAfterEquals commentsAfterBody return ( (A.at start end (Src.Define name (reverse revArgs) body tipe comments), commentsAfterDef), diff --git a/compiler/src/Parse/Module.hs b/compiler/src/Parse/Module.hs index 4ae6cd94a..66b470e6f 100644 --- a/compiler/src/Parse/Module.hs +++ b/compiler/src/Parse/Module.hs @@ -399,7 +399,7 @@ chompImport = Keyword.import_ E.ImportStart commentsAfterImportKeyword <- Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentName name@(A.At (A.Region _ end) _) <- addLocation (Var.moduleName E.ImportName) - commentsAfterName <- Space.chompIndentedAtLeast 2 E.ModuleSpace + commentsAfterName <- Space.chompIndentedMoreThan 1 E.ModuleSpace outdentedComments <- Space.chomp E.ModuleSpace oneOf E.ImportEnd @@ -424,7 +424,7 @@ chompAs name comments = commentsAfterAs <- Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentAlias alias <- Var.moduleName E.ImportAlias end <- getPosition - commentsAfterAliasName <- Space.chompIndentedAtLeast 2 E.ModuleSpace + commentsAfterAliasName <- Space.chompIndentedMoreThan 1 E.ModuleSpace outdentedComments <- Space.chomp E.ModuleSpace oneOf E.ImportEnd @@ -444,7 +444,7 @@ chompExposing name maybeAlias comments = Keyword.exposing_ E.ImportExposing commentsAfterExposing <- Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentExposingArray exposed <- specialize E.ImportExposingArray exposing - commentsAfterListing <- Space.chompIndentedAtLeast 2 E.ModuleSpace + commentsAfterListing <- Space.chompIndentedMoreThan 1 E.ModuleSpace outdentedComments <- freshLine E.ImportEnd let exposingComments = SC.ImportExposingComments commentsAfterExposing commentsAfterListing return (Src.Import name maybeAlias exposed (Just exposingComments) comments, outdentedComments) diff --git a/compiler/src/Parse/Pattern.hs b/compiler/src/Parse/Pattern.hs index e00c715d7..0dce9bc41 100644 --- a/compiler/src/Parse/Pattern.hs +++ b/compiler/src/Parse/Pattern.hs @@ -3,6 +3,8 @@ {-# LANGUAGE UnboxedTuples #-} -- 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.Pattern ( term, @@ -106,8 +108,8 @@ parenthesized :: Parser E.Pattern Src.Pattern parenthesized = inContext E.PParenthesized (word1 0x28 {-(-} E.PStart) $ do - Space.chompAndCheckIndent E.PParenthesizedSpace E.PParenthesizedIndentPattern - (pattern, end) <- P.specialize E.PParenthesizedPattern expression + commentsAfterOpenBrace <- Space.chompAndCheckIndent E.PParenthesizedSpace E.PParenthesizedIndentPattern + ((pattern, commentsAfterPattern), end) <- P.specialize E.PParenthesizedPattern expression Space.checkIndent end E.PParenthesizedIndentEnd word1 0x29 {-)-} E.PParenthesizedEnd return pattern @@ -138,8 +140,8 @@ recordPatternHelp start revPatterns = E.PRecordEnd [ do word1 0x3D {-=-} E.PRecordEquals - Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentField - (pattern, fieldEnd) <- P.specialize E.PRecordExpr expression + commentsAfterEquals <- Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentField + ((pattern, commentsAfterPattern), fieldEnd) <- P.specialize E.PRecordExpr expression Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentEnd let namedPattern = A.at fieldStart fieldEnd $ @@ -173,11 +175,11 @@ array :: A.Position -> Parser E.Pattern Src.Pattern array start = inContext E.PArray (word1 0x5B {-[-} E.PStart) $ do - Space.chompAndCheckIndent E.PArraySpace E.PArrayIndentOpen + commentsAfterOpenBracket <- Space.chompAndCheckIndent E.PArraySpace E.PArrayIndentOpen oneOf E.PArrayOpen [ do - (pattern, end) <- P.specialize E.PArrayExpr expression + ((pattern, commentsAfterPattern), end) <- P.specialize E.PArrayExpr expression Space.checkIndent end E.PArrayIndentEnd arrayHelp start [pattern], do @@ -192,7 +194,7 @@ arrayHelp start patterns = [ do word1 0x2C {-,-} E.PArrayEnd Space.chompAndCheckIndent E.PArraySpace E.PArrayIndentExpr - (pattern, end) <- P.specialize E.PArrayExpr expression + ((pattern, commentsAfter), end) <- P.specialize E.PArrayExpr expression Space.checkIndent end E.PArrayIndentEnd arrayHelp start (pattern : patterns), do @@ -202,34 +204,35 @@ arrayHelp start patterns = -- EXPRESSION -expression :: Space.Parser E.Pattern Src.Pattern +expression :: Space.Parser E.Pattern (Src.Pattern, [Src.Comment]) expression = do start <- getPosition ePart <- exprPart exprHelp start ePart -exprHelp :: A.Position -> (Src.Pattern, A.Position) -> Space.Parser E.Pattern Src.Pattern -exprHelp start (pattern, end) = +exprHelp :: A.Position -> ((Src.Pattern, [Src.Comment]), A.Position) -> Space.Parser E.Pattern (Src.Pattern, [Src.Comment]) +exprHelp start ((pattern, commentsAfterPattern), end) = oneOfWithFallback [ do Space.checkIndent end E.PIndentStart + let commentsBeforeAs = commentsAfterPattern Keyword.as_ E.PStart - Space.chompAndCheckIndent E.PSpace E.PIndentAlias + commentsAfterAs <- Space.chompAndCheckIndent E.PSpace E.PIndentAlias nameStart <- getPosition name <- Var.lower E.PAlias newEnd <- getPosition - Space.chomp E.PSpace + commentsAfterAlias <- Space.chomp E.PSpace let alias = A.at nameStart newEnd name return - ( A.at start newEnd (Src.PAlias pattern alias), + ( (A.at start newEnd (Src.PAlias pattern alias), commentsAfterAlias), newEnd ) ] - ( pattern, + ( (pattern, commentsAfterPattern), end ) -exprPart :: Space.Parser E.Pattern Src.Pattern +exprPart :: Space.Parser E.Pattern (Src.Pattern, [Src.Comment]) exprPart = oneOf E.PStart @@ -240,26 +243,28 @@ exprPart = exprTermHelp (A.Region start end) upper start [], do eterm@(A.At (A.Region _ end) _) <- term - Space.chomp E.PSpace - return (eterm, end) + commentsAfter <- Space.chomp E.PSpace + return ((eterm, commentsAfter), end) ] -exprTermHelp :: A.Region -> Var.Upper -> A.Position -> [Src.Pattern] -> Space.Parser E.Pattern Src.Pattern +exprTermHelp :: A.Region -> Var.Upper -> A.Position -> [([Src.Comment], Src.Pattern)] -> Space.Parser E.Pattern (Src.Pattern, [Src.Comment]) exprTermHelp region upper start revArgs = do end <- getPosition - Space.chomp E.PSpace + commentsAfter <- Space.chomp E.PSpace oneOfWithFallback [ do Space.checkIndent end E.PIndentStart arg <- term - exprTermHelp region upper start (arg : revArgs) + exprTermHelp region upper start ((commentsAfter, arg) : revArgs) ] - ( A.at start end $ - case upper of - Var.Unqualified name -> - Src.PCtor region name (reverse revArgs) - Var.Qualified home name -> - Src.PCtorQual region home name (reverse revArgs), + ( ( A.at start end $ + case upper of + Var.Unqualified name -> + Src.PCtor region name (reverse revArgs) + Var.Qualified home name -> + Src.PCtorQual region home name (reverse revArgs), + commentsAfter + ), end ) diff --git a/compiler/src/Parse/Space.hs b/compiler/src/Parse/Space.hs index c25f9c91f..035da58d9 100644 --- a/compiler/src/Parse/Space.hs +++ b/compiler/src/Parse/Space.hs @@ -6,7 +6,7 @@ module Parse.Space ( Parser, -- chomp, - chompIndentedAtLeast, + chompIndentedMoreThan, chompAndCheckIndent, -- checkIndent, @@ -36,12 +36,12 @@ type Parser x a = chomp :: (E.Space -> Row -> Col -> x) -> P.Parser x [Src.Comment] chomp = - chompIndentedAtLeast 1 + chompIndentedMoreThan 0 -chompIndentedAtLeast :: Col -> (E.Space -> Row -> Col -> x) -> P.Parser x [Src.Comment] -chompIndentedAtLeast requiredIndent toError = +chompIndentedMoreThan :: Col -> (E.Space -> Row -> Col -> x) -> P.Parser x [Src.Comment] +chompIndentedMoreThan requiredIndent toError = P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ -> - let (# status, newPos, newRow, newCol #) = eatSpacesIndentedAtLeast requiredIndent pos end row col [] + let (# status, newPos, newRow, newCol #) = eatSpacesIndentedMoreThan requiredIndent pos end row col [] in case status of Good comments -> let !newState = P.State src newPos end indent newRow newCol @@ -77,7 +77,7 @@ checkFreshLine toError = chompAndCheckIndent :: (E.Space -> Row -> Col -> x) -> (Row -> Col -> x) -> P.Parser x [Src.Comment] chompAndCheckIndent toSpaceError toIndentError = P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ -> - let (# status, newPos, newRow, newCol #) = eatSpacesIndentedAtLeast 0 pos end row col [] + let (# status, newPos, newRow, newCol #) = eatSpacesIndentedMoreThan 0 pos end row col [] in case status of Good comments -> if newCol > indent && newCol > 1 @@ -95,28 +95,28 @@ data Status | HasTab | EndlessMultiComment -eatSpacesIndentedAtLeast :: Col -> Ptr Word8 -> Ptr Word8 -> Row -> Col -> [Src.Comment] -> (# Status, Ptr Word8, Row, Col #) -eatSpacesIndentedAtLeast indent pos end row col comments = +eatSpacesIndentedMoreThan :: Col -> Ptr Word8 -> Ptr Word8 -> Row -> Col -> [Src.Comment] -> (# Status, Ptr Word8, Row, Col #) +eatSpacesIndentedMoreThan indent pos end row col comments = if pos >= end then (# Good (reverse comments), pos, row, col #) else case P.unsafeIndex pos of 0x20 {- -} -> - eatSpacesIndentedAtLeast indent (plusPtr pos 1) end row (col + 1) comments + eatSpacesIndentedMoreThan indent (plusPtr pos 1) end row (col + 1) comments 0x0A {- \n -} -> - eatSpacesIndentedAtLeast indent (plusPtr pos 1) end (row + 1) 1 comments + eatSpacesIndentedMoreThan indent (plusPtr pos 1) end (row + 1) 1 comments 0x7B {- { -} -> - if col >= indent + if col > indent then eatMultiComment indent pos end row col comments else (# Good (reverse comments), pos, row, col #) 0x2D {- - -} -> let !pos1 = plusPtr pos 1 - in if pos1 < end && col >= indent && P.unsafeIndex pos1 == 0x2D {- - -} + in if pos1 < end && col > indent && P.unsafeIndex pos1 == 0x2D {- - -} then let !start = plusPtr pos 2 in eatLineComment indent start start end row col (col + 2) comments else (# Good (reverse comments), pos, row, col #) 0x0D {- \r -} -> - eatSpacesIndentedAtLeast indent (plusPtr pos 1) end row col comments + eatSpacesIndentedMoreThan indent (plusPtr pos 1) end row col comments 0x09 {- \t -} -> (# HasTab, pos, row, col #) _ -> @@ -141,7 +141,7 @@ eatLineComment indent start pos end row startCol col comments = !comment_ = Src.LineComment commentText !comment = A.At (A.Region (A.Position row startCol) (A.Position row col)) comment_ !newComments = comment : comments - in eatSpacesIndentedAtLeast indent (plusPtr pos 1) end (row + 1) 1 newComments + in eatSpacesIndentedMoreThan indent (plusPtr pos 1) end (row + 1) 1 newComments else let !newPos = plusPtr pos (P.getCharWidth word) in eatLineComment indent start newPos end row startCol (col + 1) comments @@ -167,7 +167,7 @@ eatMultiComment indent pos end row col comments = let !comment_ = Src.BlockComment commentText !comment = A.At (A.Region (A.Position row col) (A.Position newRow newCol)) comment_ !newComments = comment : comments - in eatSpacesIndentedAtLeast indent newPos end newRow newCol newComments + in eatSpacesIndentedMoreThan indent newPos end newRow newCol newComments MultiTab -> (# HasTab, newPos, newRow, newCol #) MultiEndless -> (# EndlessMultiComment, pos, row, col #) else (# Good (reverse comments), pos, row, col #) diff --git a/compiler/src/Reporting/Annotation.hs b/compiler/src/Reporting/Annotation.hs index 57fcd5887..92c247aeb 100644 --- a/compiler/src/Reporting/Annotation.hs +++ b/compiler/src/Reporting/Annotation.hs @@ -8,7 +8,7 @@ module Reporting.Annotation toValue, merge, at, - isIndentedAtLeast, + isIndentedMoreThan, toRegion, mergeRegions, zero, @@ -43,9 +43,9 @@ merge :: Located a -> Located b -> value -> Located value merge (At r1 _) (At r2 _) value = At (mergeRegions r1 r2) value -isIndentedAtLeast :: Word16 -> Located a -> Bool -isIndentedAtLeast indent (At (Region (Position _ col) _) _) = - col >= indent +isIndentedMoreThan :: Word16 -> Located a -> Bool +isIndentedMoreThan indent (At (Region (Position _ col) _) _) = + col > indent -- POSITION diff --git a/tests/Integration/FormatSpec.hs b/tests/Integration/FormatSpec.hs index 5603fb7a4..029125e06 100644 --- a/tests/Integration/FormatSpec.hs +++ b/tests/Integration/FormatSpec.hs @@ -296,6 +296,33 @@ spec = do ["\\{-A-}x{-B-}y{-C-}->{-D-}[]"] `shouldFormatExpressionAs` ["\\{- A -} x {- B -} y {- C -} -> {- D -} []"] + 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"] + `shouldFormatExpressionAs` [ "if {- A -} x {- B -} then", + " {- C -}", + " 1", + " {- D -}", + "else if {- E -} {- F -} y {- G -} then", + " {- H -}", + " 2", + " {- I -}", + "else", + " {- J -}", + " 3" + ] + it "formats indented comments after else body" $ + [ "if x then 1", + "else 2{-A-}", + " {-B-}" + ] + `shouldFormatExpressionAs` [ "if x then", + " 1", + "else", + " 2", + " {- A -} {- B -}" + ] + describe "let" $ do it "formats comments" $ ["let{-A-}x{-D-}={-E-}1{-B-}in{-C-}x"] @@ -345,6 +372,44 @@ spec = do "x" ] + describe "case" $ do + it "formats comments" $ + [ "case{-A-}x{-B-}of{-C-}", + " {-D1-}", + "{-D2-}", + " Nothing{-E-}->{-F-}y", + " {-H1-}", + "{-H2-}", + " _{-J-}->{-K-}z" + ] + `shouldFormatExpressionAs` [ "case {- A -} x {- B -} of", + " {- C -} {- D1 -} {- D2 -}", + " Nothing {- E -} ->", + " {- F -}", + " y", + "", + " {- H1 -} {- H2 -}", + " _ {- J -} ->", + " {- K -}", + " z" + ] + it "formats indented comments after branches" $ + [ "case x of", + " Nothing -> y{-A-}", + " {-B-}", + " _ -> z{-C-}", + " {-D-}" + ] + `shouldFormatExpressionAs` [ "case x of", + " Nothing ->", + " y", + " {- A -} {- B -}", + "", + " _ ->", + " z", + " {- C -} {- D -}" + ] + describe "record" $ do describe "empty" $ do it "formats already formatted" $ diff --git a/tests/Parse/MultilineStringSpec.hs b/tests/Parse/MultilineStringSpec.hs index dfb8f8883..f1b30ba10 100644 --- a/tests/Parse/MultilineStringSpec.hs +++ b/tests/Parse/MultilineStringSpec.hs @@ -48,4 +48,4 @@ parse expectedStr = expectedStr == Utf8.toChars str _ -> False - in Helpers.checkSuccessfulParse Pattern.expression Error.Syntax.PStart isExpectedString + in Helpers.checkSuccessfulParse (fmap (\((pat, _), loc) -> (pat, loc)) Pattern.expression) Error.Syntax.PStart isExpectedString diff --git a/tests/Parse/UnderscorePatternSpec.hs b/tests/Parse/UnderscorePatternSpec.hs index 74de76b89..90c4eb516 100644 --- a/tests/Parse/UnderscorePatternSpec.hs +++ b/tests/Parse/UnderscorePatternSpec.hs @@ -48,7 +48,7 @@ parse expectedName = expectedName == (Name.toChars name) _ -> False - in Helpers.checkSuccessfulParse Pattern.expression Error.Syntax.PStart isWildCardPattern + in Helpers.checkSuccessfulParse (fmap (\((pat, _), loc) -> (pat, loc)) Pattern.expression) Error.Syntax.PStart isWildCardPattern failToParse :: BS.ByteString -> IO () failToParse =