packages feed

purescript-cst (empty) → 0.1.0.0

raw patch · 44 files changed

+5405/−0 lines, 44 filesdep +arraydep +basedep +base-compatsetup-changed

Dependencies added: array, base, base-compat, bytestring, containers, dlist, filepath, purescript-ast, purescript-cst, scientific, semigroups, tasty, tasty-golden, tasty-quickcheck, text

Files

+ LICENSE view
@@ -0,0 +1,13 @@+Copyright (c) 2013-17 Phil Freeman, (c) 2014-2017 Gary Burgess, and other+contributors+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,11 @@+# purescript-cst++Defines the surface syntax of the PureScript Programming Language.++## Compiler compatibility++We provide a table to make it a bit easier to map between versions of `purescript` and `purescript-cst`.++| `purescript` | `purescript-cst` |+| --- | --- |+| `0.13.6` | `0.1.0.0` |
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ purescript-cst.cabal view
@@ -0,0 +1,119 @@+cabal-version:      1.12+name:               purescript-cst+version:            0.1.0.0+license:            BSD3+license-file:       LICENSE+copyright:+    (c) 2013-17 Phil Freeman, (c) 2014-19 Gary Burgess, (c) other contributors (see CONTRIBUTORS.md)++maintainer:+    Gary Burgess <gary.burgess@gmail.com>, Hardy Jones <jones3.hardy@gmail.com>, Harry Garrood <harry@garrood.me>, Christoph Hegemann <christoph.hegemann1337@gmail.com>, Liam Goodacre <goodacre.liam@gmail.com>, Nathan Faubion <nathan@n-son.com>++author:             Phil Freeman <paf31@cantab.net>+stability:          experimental+homepage:           http://www.purescript.org/+bug-reports:        https://github.com/purescript/purescript/issues+synopsis:           PureScript Programming Language Concrete Syntax Tree+description:        The surface syntax of the PureScript Programming Language.+category:           Language+build-type:         Simple+extra-source-files:+    tests/purs/layout/AdoIn.out+    tests/purs/layout/CaseGuards.out+    tests/purs/layout/CaseWhere.out+    tests/purs/layout/ClassHead.out+    tests/purs/layout/Commas.out+    tests/purs/layout/Delimiter.out+    tests/purs/layout/DoLet.out+    tests/purs/layout/DoOperator.out+    tests/purs/layout/DoWhere.out+    tests/purs/layout/IfThenElseDo.out+    tests/purs/layout/InstanceChainElse.out+    tests/purs/layout/LetGuards.out+    tests/purs/layout/AdoIn.purs+    tests/purs/layout/CaseGuards.purs+    tests/purs/layout/CaseWhere.purs+    tests/purs/layout/ClassHead.purs+    tests/purs/layout/Commas.purs+    tests/purs/layout/Delimiter.purs+    tests/purs/layout/DoLet.purs+    tests/purs/layout/DoOperator.purs+    tests/purs/layout/DoWhere.purs+    tests/purs/layout/IfThenElseDo.purs+    tests/purs/layout/InstanceChainElse.purs+    tests/purs/layout/LetGuards.purs+    README.md++source-repository head+    type:     git+    location: https://github.com/purescript/purescript++library+    exposed-modules:+        Language.PureScript.CST.Convert+        Language.PureScript.CST.Errors+        Language.PureScript.CST.Flatten+        Language.PureScript.CST.Layout+        Language.PureScript.CST.Lexer+        Language.PureScript.CST.Monad+        Language.PureScript.CST.Parser+        Language.PureScript.CST.Positions+        Language.PureScript.CST.Print+        Language.PureScript.CST.Traversals+        Language.PureScript.CST.Traversals.Type+        Language.PureScript.CST.Types+        Language.PureScript.CST.Utils++    build-tools:        happy ==1.19.9+    hs-source-dirs:     src+    other-modules:      Data.Text.PureScript+    default-language:   Haskell2010+    default-extensions:+        BangPatterns ConstraintKinds DataKinds DefaultSignatures+        DeriveFunctor DeriveFoldable DeriveTraversable DeriveGeneric+        DerivingStrategies EmptyDataDecls FlexibleContexts+        FlexibleInstances GeneralizedNewtypeDeriving KindSignatures+        LambdaCase MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude+        PatternGuards PatternSynonyms RankNTypes RecordWildCards+        OverloadedStrings ScopedTypeVariables TupleSections TypeFamilies+        ViewPatterns++    ghc-options:        -Wall -O2+    build-depends:+        array <0.6,+        base >=4.11 && <4.13,+        containers <0.7,+        dlist <0.9,+        purescript-ast <0.2,+        scientific >=0.3.4.9 && <0.4,+        semigroups >=0.16.2 && <0.19,+        text <1.3++test-suite tests+    type:               exitcode-stdio-1.0+    main-is:            Main.hs+    build-tools:        happy ==1.19.9+    hs-source-dirs:     tests+    other-modules:+        TestCst+        Paths_purescript_cst++    default-language:   Haskell2010+    default-extensions: NoImplicitPrelude LambdaCase OverloadedStrings+    ghc-options:        -Wall+    build-depends:+        array <0.6,+        base >=4.11 && <4.13,+        base-compat >=0.6.0 && <0.11,+        bytestring <0.11,+        containers <0.7,+        dlist <0.9,+        filepath <1.5,+        purescript-ast <0.2,+        purescript-cst -any,+        scientific >=0.3.4.9 && <0.4,+        semigroups >=0.16.2 && <0.19,+        tasty <1.3,+        tasty-golden <2.4,+        tasty-quickcheck <0.11,+        text <1.3
+ src/Data/Text/PureScript.hs view
@@ -0,0 +1,23 @@+-- |+-- This module contains internal extensions to Data.Text.+--+module Data.Text.PureScript (spanUpTo) where++import Prelude++import Data.Text.Internal (Text(..), text)+import Data.Text.Unsafe (Iter(..), iter)++-- | /O(n)/ 'spanUpTo', applied to a number @n@, predicate @p@, and text @t@,+-- returns a pair whose first element is the longest prefix (possibly empty) of+-- @t@ of length less than or equal to @n@ of elements that satisfy @p@, and+-- whose second is the remainder of the text.+{-# INLINE spanUpTo #-}+spanUpTo :: Int -> (Char -> Bool) -> Text -> (Text, Text)+spanUpTo n p t@(Text arr off len) = (hd, tl)+  where hd = text arr off k+        tl = text arr (off + k) (len - k)+        !k = loop n 0+        loop !n' !i | n' > 0 && i < len && p c = loop (n' - 1) (i + d)+                    | otherwise                = i+            where Iter c d = iter t i
+ src/Language/PureScript/CST/Convert.hs view
@@ -0,0 +1,636 @@+-- | This module contains functions for converting the CST into the core AST. It+-- is mostly boilerplate, and does the job of resolving ranges for all the nodes+-- and attaching comments.++module Language.PureScript.CST.Convert+  ( convertType+  , convertExpr+  , convertBinder+  , convertDeclaration+  , convertImportDecl+  , convertModule+  , sourcePos+  , sourceSpan+  , comment+  , comments+  ) where++import Prelude++import Data.Bifunctor (bimap, first)+import Data.Foldable (foldl', toList)+import Data.Functor (($>))+import qualified Data.List.NonEmpty as NE+import Data.Maybe (isJust, fromJust, mapMaybe)+import qualified Data.Text as Text+import qualified Language.PureScript.AST as AST+import qualified Language.PureScript.AST.SourcePos as Pos+import qualified Language.PureScript.Comments as C+import Language.PureScript.Crash (internalError)+import qualified Language.PureScript.Environment as Env+import qualified Language.PureScript.Label as L+import qualified Language.PureScript.Names as N+import Language.PureScript.PSString (mkString)+import qualified Language.PureScript.Types as T+import Language.PureScript.CST.Positions+import Language.PureScript.CST.Print (printToken)+import Language.PureScript.CST.Types++comment :: Comment a -> Maybe C.Comment+comment = \case+  Comment t+    | Text.isPrefixOf "{-" t -> Just $ C.BlockComment $ Text.drop 2 $ Text.dropEnd 2 t+    | Text.isPrefixOf "--" t -> Just $ C.LineComment $ Text.drop 2 t+  _ -> Nothing++comments :: [Comment a] -> [C.Comment]+comments = mapMaybe comment++sourcePos :: SourcePos -> Pos.SourcePos+sourcePos (SourcePos line col) = Pos.SourcePos line col++sourceSpan :: String -> SourceRange -> Pos.SourceSpan+sourceSpan name (SourceRange start end) = Pos.SourceSpan name (sourcePos start) (sourcePos end)++widenLeft :: TokenAnn -> Pos.SourceAnn -> Pos.SourceAnn+widenLeft ann (sp, _) =+  ( Pos.widenSourceSpan (sourceSpan (Pos.spanName sp) $ tokRange ann) sp+  , comments $ tokLeadingComments ann+  )++sourceAnnCommented :: String -> SourceToken -> SourceToken -> Pos.SourceAnn+sourceAnnCommented fileName (SourceToken ann1 _) (SourceToken ann2 _) =+  ( Pos.SourceSpan fileName (sourcePos $ srcStart $ tokRange ann1) (sourcePos $ srcEnd $ tokRange ann2)+  , comments $ tokLeadingComments ann1+  )++sourceAnn :: String -> SourceToken -> SourceToken -> Pos.SourceAnn+sourceAnn fileName (SourceToken ann1 _) (SourceToken ann2 _) =+  ( Pos.SourceSpan fileName (sourcePos $ srcStart $ tokRange ann1) (sourcePos $ srcEnd $ tokRange ann2)+  , []+  )++sourceName :: String -> Name a -> Pos.SourceAnn+sourceName fileName a = sourceAnnCommented fileName (nameTok a) (nameTok a)++sourceQualName :: String -> QualifiedName a -> Pos.SourceAnn+sourceQualName fileName a = sourceAnnCommented fileName (qualTok a) (qualTok a)++moduleName :: Token -> Maybe N.ModuleName+moduleName = \case+  TokLowerName as _ -> go as+  TokUpperName as _ -> go as+  TokSymbolName as _ -> go as+  TokOperator as _ -> go as+  _ -> Nothing+  where+  go [] = Nothing+  go ns = Just $ N.ModuleName $ Text.intercalate "." ns++qualified :: QualifiedName a -> N.Qualified a+qualified q = N.Qualified (qualModule q) (qualName q)++ident :: Ident -> N.Ident+ident = N.Ident . getIdent++convertType :: String -> Type a -> T.SourceType+convertType fileName = go+  where+  goRow (Row labels tl) b = do+    let+      rowTail = case tl of+        Just (_, ty) -> go ty+        Nothing -> T.REmpty $ sourceAnnCommented fileName b b+      rowCons (Labeled a _ ty) c = do+        let ann = sourceAnnCommented fileName (lblTok a) (snd $ typeRange ty)+        T.RCons ann (L.Label $ lblName a) (go ty) c+    case labels of+      Just (Separated h t) ->+        rowCons h $ foldr (rowCons . snd) rowTail t+      Nothing ->+        rowTail++  go = \case+    TypeVar _ a ->+      T.TypeVar (sourceName fileName a) . getIdent $ nameValue a+    TypeConstructor _ a ->+      T.TypeConstructor (sourceQualName fileName a) $ qualified a+    TypeWildcard _ a ->+      T.TypeWildcard (sourceAnnCommented fileName a a) Nothing+    TypeHole _ a ->+      T.TypeWildcard (sourceName fileName a) . Just . getIdent $ nameValue a+    TypeString _ a b ->+      T.TypeLevelString (sourceAnnCommented fileName a a) $ b+    TypeRow _ (Wrapped _ row b) ->+      goRow row b+    TypeRecord _ (Wrapped a row b) -> do+      let+        ann = sourceAnnCommented fileName a b+        annRec = sourceAnn fileName a a+      T.TypeApp ann (Env.tyRecord $> annRec) $ goRow row b+    TypeForall _ kw bindings _ ty -> do+      let+        mkForAll a b t = do+          let ann' = widenLeft (tokAnn $ nameTok a) $ T.getAnnForType t+          T.ForAll ann' (getIdent $ nameValue a) b t Nothing+        k (TypeVarKinded (Wrapped _ (Labeled a _ b) _)) = mkForAll a (Just (go b))+        k (TypeVarName a) = mkForAll a Nothing+        ty' = foldr k (go ty) bindings+        ann = widenLeft (tokAnn kw) $ T.getAnnForType ty'+      T.setAnnForType ann ty'+    TypeKinded _ ty _ kd -> do+      let+        ty' = go ty+        kd' = go kd+        ann = Pos.widenSourceAnn (T.getAnnForType ty') (T.getAnnForType kd')+      T.KindedType ann ty' kd'+    TypeApp _ a b -> do+      let+        a' = go a+        b' = go b+        ann = Pos.widenSourceAnn (T.getAnnForType a') (T.getAnnForType b')+      T.TypeApp ann a' b'+    ty@(TypeOp _ _ _ _) -> do+      let+        reassoc op b' a = do+          let+            a'  = go a+            op' = T.TypeOp (sourceQualName fileName op) $ qualified op+            ann = Pos.widenSourceAnn (T.getAnnForType a') (T.getAnnForType b')+          T.BinaryNoParensType ann op' (go a) b'+        loop k = \case+          TypeOp _ a op b -> loop (reassoc op (k b)) a+          expr' -> k expr'+      loop go ty+    TypeOpName _ op -> do+      let rng = qualRange op+      T.TypeOp (uncurry (sourceAnnCommented fileName) rng) (qualified op)+    TypeArr _ a arr b -> do+      let+        a' = go a+        b' = go b+        arr' = Env.tyFunction $> sourceAnnCommented fileName arr arr+        ann = Pos.widenSourceAnn (T.getAnnForType a') (T.getAnnForType b')+      T.TypeApp ann (T.TypeApp ann arr' a') b'+    TypeArrName _ a ->+      Env.tyFunction $> sourceAnnCommented fileName a a+    TypeConstrained _ a _ b -> do+      let+        a' = convertConstraint fileName a+        b' = go b+        ann = Pos.widenSourceAnn (T.constraintAnn a') (T.getAnnForType b')+      T.ConstrainedType ann a' b'+    TypeParens _ (Wrapped a ty b) ->+      T.ParensInType (sourceAnnCommented fileName a b) $ go ty+    ty@(TypeUnaryRow _ _ a) -> do+      let+        a' = go a+        rng = typeRange ty+        ann = uncurry (sourceAnnCommented fileName) rng+      T.setAnnForType ann $ Env.kindRow a'++convertConstraint :: String -> Constraint a -> T.SourceConstraint+convertConstraint fileName = go+  where+  go = \case+    cst@(Constraint _ name args) -> do+      let ann = uncurry (sourceAnnCommented fileName) $ constraintRange cst+      T.Constraint ann (qualified name) [] (convertType fileName <$> args) Nothing+    ConstraintParens _ (Wrapped _ c _) -> go c++convertGuarded :: String -> Guarded a -> [AST.GuardedExpr]+convertGuarded fileName = \case+  Unconditional _ x -> [AST.GuardedExpr [] (convertWhere fileName x)]+  Guarded gs -> (\(GuardedExpr _ ps _ x) -> AST.GuardedExpr (p <$> toList ps) (convertWhere fileName x)) <$> NE.toList gs+  where+  go = convertExpr fileName+  p (PatternGuard Nothing x) = AST.ConditionGuard (go x)+  p (PatternGuard (Just (b, _)) x) = AST.PatternGuard (convertBinder fileName b) (go x)++convertWhere :: String -> Where a -> AST.Expr+convertWhere fileName = \case+  Where expr Nothing -> convertExpr fileName expr+  Where expr (Just (_, bs)) -> do+    let ann = uncurry (sourceAnnCommented fileName) $ exprRange expr+    uncurry AST.PositionedValue ann . AST.Let AST.FromWhere (convertLetBinding fileName <$> NE.toList bs) $ convertExpr fileName expr++convertLetBinding :: String -> LetBinding a -> AST.Declaration+convertLetBinding fileName = \case+  LetBindingSignature _ lbl ->+    convertSignature fileName lbl+  binding@(LetBindingName _ fields) -> do+    let ann = uncurry (sourceAnnCommented fileName) $ letBindingRange binding+    convertValueBindingFields fileName ann fields+  binding@(LetBindingPattern _ a _ b) -> do+    let ann = uncurry (sourceAnnCommented fileName) $ letBindingRange binding+    AST.BoundValueDeclaration ann (convertBinder fileName a) (convertWhere fileName b)++convertExpr :: forall a. String -> Expr a -> AST.Expr+convertExpr fileName = go+  where+  positioned =+    uncurry AST.PositionedValue++  goDoStatement = \case+    stmt@(DoLet _ as) -> do+      let ann = uncurry (sourceAnnCommented fileName) $ doStatementRange stmt+      uncurry AST.PositionedDoNotationElement ann . AST.DoNotationLet $ convertLetBinding fileName <$> NE.toList as+    stmt@(DoDiscard a) -> do+      let ann = uncurry (sourceAnn fileName) $ doStatementRange stmt+      uncurry AST.PositionedDoNotationElement ann . AST.DoNotationValue $ go a+    stmt@(DoBind a _ b) -> do+      let+        ann = uncurry (sourceAnn fileName) $ doStatementRange stmt+        a' = convertBinder fileName a+        b' = go b+      uncurry AST.PositionedDoNotationElement ann $ AST.DoNotationBind a' b'++  go = \case+    ExprHole _ a ->+      positioned (sourceName fileName a) . AST.Hole . getIdent $ nameValue a+    ExprSection _ a ->+      positioned (sourceAnnCommented fileName a a) AST.AnonymousArgument+    ExprIdent _ a -> do+      let ann = sourceQualName fileName a+      positioned ann . AST.Var (fst ann) . qualified $ fmap ident a+    ExprConstructor _ a -> do+      let ann = sourceQualName fileName a+      positioned ann . AST.Constructor (fst ann) $ qualified a+    ExprBoolean _ a b -> do+      let ann = sourceAnnCommented fileName a a+      positioned ann . AST.Literal (fst ann) $ AST.BooleanLiteral b+    ExprChar _ a b -> do+      let ann = sourceAnnCommented fileName a a+      positioned ann . AST.Literal (fst ann) $ AST.CharLiteral b+    ExprString _ a b -> do+      let ann = sourceAnnCommented fileName a a+      positioned ann . AST.Literal (fst ann) . AST.StringLiteral $ b+    ExprNumber _ a b -> do+      let ann = sourceAnnCommented fileName a a+      positioned ann . AST.Literal (fst ann) $ AST.NumericLiteral b+    ExprArray _ (Wrapped a bs c) -> do+      let+        ann = sourceAnnCommented fileName a c+        vals = case bs of+          Just (Separated x xs) -> go x : (go . snd <$> xs)+          Nothing -> []+      positioned ann . AST.Literal (fst ann) $ AST.ArrayLiteral vals+    ExprRecord z (Wrapped a bs c) -> do+      let+        ann = sourceAnnCommented fileName a c+        lbl = \case+          RecordPun f -> (mkString . getIdent $ nameValue f, go . ExprIdent z $ QualifiedName (nameTok f) Nothing (nameValue f))+          RecordField f _ v -> (lblName f, go v)+        vals = case bs of+          Just (Separated x xs) -> lbl x : (lbl . snd <$> xs)+          Nothing -> []+      positioned ann . AST.Literal (fst ann) $ AST.ObjectLiteral vals+    ExprParens _ (Wrapped a b c) ->+      positioned (sourceAnnCommented fileName a c) . AST.Parens $ go b+    expr@(ExprTyped _ a _ b) -> do+      let+        a' = go a+        b' = convertType fileName b+        ann = (sourceSpan fileName . toSourceRange $ exprRange expr, [])+      positioned ann $ AST.TypedValue True a' b'+    expr@(ExprInfix _ a (Wrapped _ b _) c) -> do+      let ann = (sourceSpan fileName . toSourceRange $ exprRange expr, [])+      positioned ann $ AST.BinaryNoParens (go b) (go a) (go c)+    expr@(ExprOp _ _ _ _) -> do+      let+        ann = uncurry (sourceAnn fileName) $ exprRange expr+        reassoc op b a = do+          let op' = AST.Op (sourceSpan fileName . toSourceRange $ qualRange op) $ qualified op+          AST.BinaryNoParens op' (go a) b+        loop k = \case+          ExprOp _ a op b -> loop (reassoc op (k b)) a+          expr' -> k expr'+      positioned ann $ loop go expr+    ExprOpName _ op -> do+      let+        rng = qualRange op+        op' = AST.Op (sourceSpan fileName $ toSourceRange rng) $ qualified op+      positioned (uncurry (sourceAnnCommented fileName) rng) op'+    expr@(ExprNegate _ _ b) -> do+      let ann = uncurry (sourceAnnCommented fileName) $ exprRange expr+      positioned ann . AST.UnaryMinus (fst ann) $ go b+    expr@(ExprRecordAccessor _ (RecordAccessor a _ (Separated h t))) -> do+      let+        ann = uncurry (sourceAnnCommented fileName) $ exprRange expr+        field x f = AST.Accessor (lblName f) x+      positioned ann $ foldl' (\x (_, f) -> field x f) (field (go a) h) t+    expr@(ExprRecordUpdate _ a b) -> do+      let+        ann = uncurry (sourceAnnCommented fileName) $ exprRange expr+        k (RecordUpdateLeaf f _ x) = (lblName f, AST.Leaf $ go x)+        k (RecordUpdateBranch f xs) = (lblName f, AST.Branch $ toTree xs)+        toTree (Wrapped _ xs _) = AST.PathTree . AST.AssocList . map k $ toList xs+      positioned ann . AST.ObjectUpdateNested (go a) $ toTree b+    expr@(ExprApp _ a b) -> do+      let ann = uncurry (sourceAnn fileName) $ exprRange expr+      positioned ann $ AST.App (go a) (go b)+    expr@(ExprLambda _ (Lambda _ as _ b)) -> do+      let ann = uncurry (sourceAnnCommented fileName) $ exprRange expr+      positioned ann+        . AST.Abs (convertBinder fileName (NE.head as))+        . foldr (AST.Abs . convertBinder fileName) (go b)+        $ NE.tail as+    expr@(ExprIf _ (IfThenElse _ a _ b _ c)) -> do+      let ann = uncurry (sourceAnnCommented fileName) $ exprRange expr+      positioned ann $ AST.IfThenElse (go a) (go b) (go c)+    expr@(ExprCase _ (CaseOf _ as _ bs)) -> do+      let+        ann = uncurry (sourceAnnCommented fileName) $ exprRange expr+        as' = go <$> toList as+        bs' = uncurry AST.CaseAlternative . bimap (map (convertBinder fileName) . toList) (convertGuarded fileName) <$> NE.toList bs+      positioned ann $ AST.Case as' bs'+    expr@(ExprLet _ (LetIn _ as _ b)) -> do+      let ann = uncurry (sourceAnnCommented fileName) $ exprRange expr+      positioned ann . AST.Let AST.FromLet (convertLetBinding fileName <$> NE.toList as) $ go b+    -- expr@(ExprWhere _ (Where a _ bs)) -> do+    --   let ann = uncurry (sourceAnnCommented fileName) $ exprRange expr+    --   positioned ann . AST.Let AST.FromWhere (goLetBinding <$> bs) $ go a+    expr@(ExprDo _ (DoBlock kw stmts)) -> do+      let ann = uncurry (sourceAnnCommented fileName) $ exprRange expr+      positioned ann . AST.Do (moduleName $ tokValue kw) $ goDoStatement <$> NE.toList stmts+    expr@(ExprAdo _ (AdoBlock kw stms _ a)) -> do+      let ann = uncurry (sourceAnnCommented fileName) $ exprRange expr+      positioned ann . AST.Ado (moduleName $ tokValue kw) (goDoStatement <$> stms) $ go a++convertBinder :: String -> Binder a -> AST.Binder+convertBinder fileName = go+  where+  positioned =+    uncurry AST.PositionedBinder++  go = \case+    BinderWildcard _ a ->+      positioned (sourceAnnCommented fileName a a) AST.NullBinder+    BinderVar _ a -> do+      let ann = sourceName fileName a+      positioned ann . AST.VarBinder (fst ann) . ident $ nameValue a+    binder@(BinderNamed _ a _ b) -> do+      let ann = uncurry (sourceAnnCommented fileName) $ binderRange binder+      positioned ann . AST.NamedBinder (fst ann) (ident $ nameValue a) $ go b+    binder@(BinderConstructor _ a bs) -> do+      let ann = uncurry (sourceAnnCommented fileName) $ binderRange binder+      positioned ann . AST.ConstructorBinder (fst ann) (qualified a) $ go <$> bs+    BinderBoolean _ a b -> do+      let ann = sourceAnnCommented fileName a a+      positioned ann . AST.LiteralBinder (fst ann) $ AST.BooleanLiteral b+    BinderChar _ a b -> do+      let ann = sourceAnnCommented fileName a a+      positioned ann . AST.LiteralBinder (fst ann) $ AST.CharLiteral b+    BinderString _ a b -> do+      let ann = sourceAnnCommented fileName a a+      positioned ann . AST.LiteralBinder (fst ann) . AST.StringLiteral $ b+    BinderNumber _ n a b -> do+      let+        ann = sourceAnnCommented fileName a a+        b'+          | isJust n = bimap negate negate b+          | otherwise = b+      positioned ann . AST.LiteralBinder (fst ann) $ AST.NumericLiteral b'+    BinderArray _ (Wrapped a bs c) -> do+      let+        ann = sourceAnnCommented fileName a c+        vals = case bs of+          Just (Separated x xs) -> go x : (go . snd <$> xs)+          Nothing -> []+      positioned ann . AST.LiteralBinder (fst ann) $ AST.ArrayLiteral vals+    BinderRecord z (Wrapped a bs c) -> do+      let+        ann = sourceAnnCommented fileName a c+        lbl = \case+          RecordPun f -> (mkString . getIdent $ nameValue f, go $ BinderVar z f)+          RecordField f _ v -> (lblName f, go v)+        vals = case bs of+          Just (Separated x xs) -> lbl x : (lbl . snd <$> xs)+          Nothing -> []+      positioned ann . AST.LiteralBinder (fst ann) $ AST.ObjectLiteral vals+    BinderParens _ (Wrapped a b c) ->+      positioned (sourceAnnCommented fileName a c) . AST.ParensInBinder $ go b+    binder@(BinderTyped _ a _ b) -> do+      let+        a' = go a+        b' = convertType fileName b+        ann = (sourceSpan fileName . toSourceRange $ binderRange binder, [])+      positioned ann $ AST.TypedBinder b' a'+    binder@(BinderOp _ _ _ _) -> do+      let+        ann = uncurry (sourceAnn fileName) $ binderRange binder+        reassoc op b a = do+          let op' = AST.OpBinder (sourceSpan fileName . toSourceRange $ qualRange op) $ qualified op+          AST.BinaryNoParensBinder op' (go a) b+        loop k = \case+          BinderOp _ a op b -> loop (reassoc op (k b)) a+          binder' -> k binder'+      positioned ann $ loop go binder++convertDeclaration :: String -> Declaration a -> [AST.Declaration]+convertDeclaration fileName decl = case decl of+  DeclData _ (DataHead _ a vars) bd -> do+    let+      ctrs :: SourceToken -> DataCtor a -> [(SourceToken, DataCtor a)] -> [AST.DataConstructorDeclaration]+      ctrs st (DataCtor _ name fields) tl+        = AST.DataConstructorDeclaration (sourceAnnCommented fileName st (nameTok name)) (nameValue name) (zip ctrFields $ convertType fileName <$> fields)+        : (case tl of+            [] -> []+            (st', ctor) : tl' -> ctrs st' ctor tl'+          )+    pure $ AST.DataDeclaration ann Env.Data (nameValue a) (goTypeVar <$> vars) (maybe [] (\(st, Separated hd tl) -> ctrs st hd tl) bd)+  DeclType _ (DataHead _ a vars) _ bd ->+    pure $ AST.TypeSynonymDeclaration ann+      (nameValue a)+      (goTypeVar <$> vars)+      (convertType fileName bd)+  DeclNewtype _ (DataHead _ a vars) st x ys -> do+    let ctrs = [AST.DataConstructorDeclaration (sourceAnnCommented fileName st (snd $ declRange decl)) (nameValue x) [(head ctrFields, convertType fileName ys)]]+    pure $ AST.DataDeclaration ann Env.Newtype (nameValue a) (goTypeVar <$> vars) ctrs+  DeclClass _ (ClassHead _ sup name vars fdeps) bd -> do+    let+      goTyVar (TypeVarKinded (Wrapped _ (Labeled a _ _) _)) = nameValue a+      goTyVar (TypeVarName a) = nameValue a+      vars' = zip (toList $ goTyVar <$> vars) [0..]+      goName = fromJust . flip lookup vars' . nameValue+      goFundep (FundepDetermined _ bs) = Env.FunctionalDependency [] (goName <$> NE.toList bs)+      goFundep (FundepDetermines as _ bs) = Env.FunctionalDependency (goName <$> NE.toList as) (goName <$> NE.toList bs)+      goSig (Labeled n _ ty) = do+        let+          ty' = convertType fileName ty+          ann' = widenLeft (tokAnn $ nameTok n) $ T.getAnnForType ty'+        AST.TypeDeclaration $ AST.TypeDeclarationData ann' (ident $ nameValue n) ty'+    pure $ AST.TypeClassDeclaration ann+      (nameValue name)+      (goTypeVar <$> vars)+      (convertConstraint fileName <$> maybe [] (toList . fst) sup)+      (goFundep <$> maybe [] (toList . snd) fdeps)+      (goSig <$> maybe [] (NE.toList . snd) bd)+  DeclInstanceChain _ insts -> do+    let+      instName (Instance (InstanceHead _ a _ _ _ _) _) = ident $ nameValue a+      chainId = instName <$> toList insts+      goInst ix inst@(Instance (InstanceHead _ name _ ctrs cls args) bd) = do+        let ann' = uncurry (sourceAnnCommented fileName) $ instanceRange inst+        AST.TypeInstanceDeclaration ann' chainId ix+          (ident $ nameValue name)+          (convertConstraint fileName <$> maybe [] (toList . fst) ctrs)+          (qualified cls)+          (convertType fileName <$> args)+          (AST.ExplicitInstance $ goInstanceBinding <$> maybe [] (NE.toList . snd) bd)+    uncurry goInst <$> zip [0..] (toList insts)+  DeclDerive _ _ new (InstanceHead _ name _ ctrs cls args) -> do+    let+      name' = ident $ nameValue name+      instTy+        | isJust new = AST.NewtypeInstance+        | otherwise = AST.DerivedInstance+    pure $ AST.TypeInstanceDeclaration ann [name'] 0 name'+      (convertConstraint fileName <$> maybe [] (toList . fst) ctrs)+      (qualified cls)+      (convertType fileName <$> args)+      instTy+  DeclKindSignature _ kw (Labeled name _ ty) -> do+    let+      kindFor = case tokValue kw of+        TokLowerName [] "data" -> AST.DataSig+        TokLowerName [] "newtype" -> AST.NewtypeSig+        TokLowerName [] "type" -> AST.TypeSynonymSig+        TokLowerName [] "class" -> AST.ClassSig+        tok -> internalError $ "Invalid kind signature keyword " <> Text.unpack (printToken tok)+    pure . AST.KindDeclaration ann kindFor (nameValue name) $ convertType fileName ty+  DeclSignature _ lbl ->+    pure $ convertSignature fileName lbl+  DeclValue _ fields ->+    pure $ convertValueBindingFields fileName ann fields+  DeclFixity _ (FixityFields (_, kw) (_, prec) fxop) -> do+    let+      assoc =  case kw of+        Infix  -> AST.Infix+        Infixr -> AST.Infixr+        Infixl -> AST.Infixl+      fixity = AST.Fixity assoc prec+    pure $ AST.FixityDeclaration ann $ case fxop of+      FixityValue name _ op -> do+        Left $ AST.ValueFixity fixity (first ident <$> qualified name) (nameValue op)+      FixityType _ name _ op ->+        Right $ AST.TypeFixity fixity (qualified name) (nameValue op)+  DeclForeign _ _ _ frn ->+    pure $ case frn of+      ForeignValue (Labeled a _ b) ->+        AST.ExternDeclaration ann (ident $ nameValue a) $ convertType fileName b+      ForeignData _ (Labeled a _ b) ->+        AST.ExternDataDeclaration ann (nameValue a) $ convertType fileName b+      ForeignKind _ a ->+        AST.DataDeclaration ann Env.Data (nameValue a) [] []+  DeclRole _ _ _ name roles ->+    pure $ AST.RoleDeclaration $+      AST.RoleDeclarationData ann (nameValue name) (roleValue <$> NE.toList roles)+  where+  ann =+    uncurry (sourceAnnCommented fileName) $ declRange decl++  goTypeVar = \case+    TypeVarKinded (Wrapped _ (Labeled x _ y) _) -> (getIdent $ nameValue x, Just $ convertType fileName y)+    TypeVarName x -> (getIdent $ nameValue x, Nothing)++  goInstanceBinding = \case+    InstanceBindingSignature _ lbl ->+      convertSignature fileName lbl+    binding@(InstanceBindingName _ fields) -> do+      let ann' = uncurry (sourceAnnCommented fileName) $ instanceBindingRange binding+      convertValueBindingFields fileName ann' fields++convertSignature :: String -> Labeled (Name Ident) (Type a) -> AST.Declaration+convertSignature fileName (Labeled a _ b) = do+  let+    b' = convertType fileName b+    ann = widenLeft (tokAnn $ nameTok a) $ T.getAnnForType b'+  AST.TypeDeclaration $ AST.TypeDeclarationData ann (ident $ nameValue a) b'++convertValueBindingFields :: String -> Pos.SourceAnn -> ValueBindingFields a -> AST.Declaration+convertValueBindingFields fileName ann (ValueBindingFields a bs c) = do+  let+    bs' = convertBinder fileName <$> bs+    cs' = convertGuarded fileName c+  AST.ValueDeclaration $ AST.ValueDeclarationData ann (ident $ nameValue a) Env.Public bs' cs'++convertImportDecl+  :: String+  -> ImportDecl a+  -> (Pos.SourceAnn, N.ModuleName, AST.ImportDeclarationType, Maybe N.ModuleName)+convertImportDecl fileName decl@(ImportDecl _ _ modName mbNames mbQual) = do+  let+    ann = uncurry (sourceAnnCommented fileName) $ importDeclRange decl+    importTy = case mbNames of+      Nothing -> AST.Implicit+      Just (hiding, (Wrapped _ imps _)) -> do+        let imps' = convertImport fileName <$> toList imps+        if isJust hiding+          then AST.Hiding imps'+          else AST.Explicit imps'+  (ann, nameValue modName, importTy, nameValue . snd <$> mbQual)++convertImport :: String -> Import a -> AST.DeclarationRef+convertImport fileName imp = case imp of+  ImportValue _ a ->+    AST.ValueRef ann . ident $ nameValue a+  ImportOp _ a ->+    AST.ValueOpRef ann $ nameValue a+  ImportType _ a mb -> do+    let+      ctrs = case mb of+        Nothing -> Just []+        Just (DataAll _ _) -> Nothing+        Just (DataEnumerated _ (Wrapped _ Nothing _)) -> Just []+        Just (DataEnumerated _ (Wrapped _ (Just idents) _)) ->+          Just . map nameValue $ toList idents+    AST.TypeRef ann (nameValue a) ctrs+  ImportTypeOp _ _ a ->+    AST.TypeOpRef ann $ nameValue a+  ImportClass _ _ a ->+    AST.TypeClassRef ann $ nameValue a+  ImportKind _ _ a ->+    AST.TypeRef ann (nameValue a) (Just [])+  where+  ann = sourceSpan fileName . toSourceRange $ importRange imp++convertExport :: String -> Export a -> AST.DeclarationRef+convertExport fileName export = case export of+  ExportValue _ a ->+    AST.ValueRef ann . ident $ nameValue a+  ExportOp _ a ->+    AST.ValueOpRef ann $ nameValue a+  ExportType _ a mb -> do+    let+      ctrs = case mb of+        Nothing -> Just []+        Just (DataAll _ _) -> Nothing+        Just (DataEnumerated _ (Wrapped _ Nothing _)) -> Just []+        Just (DataEnumerated _ (Wrapped _ (Just idents) _)) ->+          Just . map nameValue $ toList idents+    AST.TypeRef ann (nameValue a) ctrs+  ExportTypeOp _ _ a ->+    AST.TypeOpRef ann $ nameValue a+  ExportClass _ _ a ->+    AST.TypeClassRef ann $ nameValue a+  ExportKind _ _ a ->+    AST.TypeRef ann (nameValue a) Nothing+  ExportModule _ _ a ->+    AST.ModuleRef ann (nameValue a)+  where+  ann = sourceSpan fileName . toSourceRange $ exportRange export++convertModule :: String -> Module a -> AST.Module+convertModule fileName module'@(Module _ _ modName exps _ imps decls _) = do+  let+    ann = uncurry (sourceAnnCommented fileName) $ moduleRange module'+    imps' = importCtr. convertImportDecl fileName <$> imps+    decls' = convertDeclaration fileName =<< decls+    exps' = map (convertExport fileName) . toList . wrpValue <$> exps+  uncurry AST.Module ann (nameValue modName) (imps' <> decls') exps'+  where+  importCtr (a, b, c, d) = AST.ImportDeclaration a b c d++ctrFields :: [N.Ident]+ctrFields = [N.Ident ("value" <> Text.pack (show (n :: Integer))) | n <- [0..]]
+ src/Language/PureScript/CST/Errors.hs view
@@ -0,0 +1,195 @@+module Language.PureScript.CST.Errors+  ( ParserErrorInfo(..)+  , ParserErrorType(..)+  , ParserWarningType(..)+  , ParserError+  , ParserWarning+  , prettyPrintError+  , prettyPrintErrorMessage+  , prettyPrintWarningMessage+  ) where++import Prelude++import qualified Data.Text as Text+import Data.Char (isSpace, toUpper)+import Language.PureScript.CST.Layout+import Language.PureScript.CST.Print+import Language.PureScript.CST.Types+import Text.Printf (printf)++data ParserErrorType+  = ErrWildcardInType+  | ErrConstraintInKind+  | ErrHoleInType+  | ErrExprInBinder+  | ErrExprInDeclOrBinder+  | ErrExprInDecl+  | ErrBinderInDecl+  | ErrRecordUpdateInCtr+  | ErrRecordPunInUpdate+  | ErrRecordCtrInUpdate+  | ErrTypeInConstraint+  | ErrElseInDecl+  | ErrInstanceNameMismatch+  | ErrUnknownFundep+  | ErrImportInDecl+  | ErrGuardInLetBinder+  | ErrKeywordVar+  | ErrKeywordSymbol+  | ErrQuotedPun+  | ErrToken+  | ErrLineFeedInString+  | ErrAstralCodePointInChar+  | ErrCharEscape+  | ErrNumberOutOfRange+  | ErrLeadingZero+  | ErrExpectedFraction+  | ErrExpectedExponent+  | ErrExpectedHex+  | ErrReservedSymbol+  | ErrCharInGap Char+  | ErrModuleName+  | ErrQualifiedName+  | ErrEmptyDo+  | ErrLexeme (Maybe String) [String]+  | ErrEof+  | ErrCustom String+  deriving (Show, Eq, Ord)++data ParserWarningType+  = WarnDeprecatedRowSyntax+  | WarnDeprecatedForeignKindSyntax+  | WarnDeprecatedConstraintInForeignImportSyntax+  | WarnDeprecatedKindImportSyntax+  | WarnDeprecatedKindExportSyntax+  deriving (Show, Eq, Ord)++data ParserErrorInfo a = ParserErrorInfo+  { errRange :: SourceRange+  , errToks :: [SourceToken]+  , errStack :: LayoutStack+  , errType :: a+  } deriving (Show, Eq)++type ParserError = ParserErrorInfo ParserErrorType+type ParserWarning = ParserErrorInfo ParserWarningType++prettyPrintError :: ParserError -> String+prettyPrintError pe@(ParserErrorInfo { errRange }) =+  prettyPrintErrorMessage pe <> " at " <> errPos+  where+  errPos = case errRange of+    SourceRange (SourcePos line col) _ ->+      "line " <> show line <> ", column " <> show col++prettyPrintErrorMessage :: ParserError -> String+prettyPrintErrorMessage (ParserErrorInfo {..}) = case errType of+  ErrWildcardInType ->+    "Unexpected wildcard in type; type wildcards are only allowed in value annotations"+  ErrConstraintInKind ->+    "Unsupported constraint in kind; constraints are only allowed in value annotations"+  ErrHoleInType ->+    "Unexpected hole in type; type holes are only allowed in value annotations"+  ErrExprInBinder ->+    "Expected pattern, saw expression"+  ErrExprInDeclOrBinder ->+    "Expected declaration or pattern, saw expression"+  ErrExprInDecl ->+    "Expected declaration, saw expression"+  ErrBinderInDecl ->+    "Expected declaration, saw pattern"+  ErrRecordUpdateInCtr ->+    "Expected ':', saw '='"+  ErrRecordPunInUpdate ->+    "Expected record update, saw pun"+  ErrRecordCtrInUpdate ->+    "Expected '=', saw ':'"+  ErrTypeInConstraint ->+    "Expected constraint, saw type"+  ErrElseInDecl ->+    "Expected declaration, saw 'else'"+  ErrInstanceNameMismatch ->+    "All instances in a chain must implement the same type class"+  ErrUnknownFundep ->+    "Unknown type variable in functional dependency"+  ErrImportInDecl ->+    "Expected declaration, saw 'import'"+  ErrGuardInLetBinder ->+    "Unexpected guard in let pattern"+  ErrKeywordVar ->+    "Expected variable, saw keyword"+  ErrKeywordSymbol ->+    "Expected symbol, saw reserved symbol"+  ErrQuotedPun ->+    "Unexpected quoted label in record pun, perhaps due to a missing ':'"+  ErrEof ->+    "Unexpected end of input"+  ErrLexeme (Just (hd : _)) _ | isSpace hd ->+    "Illegal whitespace character " <> displayCodePoint hd+  ErrLexeme (Just a) _ ->+    "Unexpected " <> a+  ErrLineFeedInString ->+    "Unexpected line feed in string literal"+  ErrAstralCodePointInChar ->+    "Illegal astral code point in character literal"+  ErrCharEscape ->+    "Illegal character escape code"+  ErrNumberOutOfRange ->+    "Number literal is out of range"+  ErrLeadingZero ->+    "Unexpected leading zeros"+  ErrExpectedFraction ->+    "Expected fraction"+  ErrExpectedExponent ->+    "Expected exponent"+  ErrExpectedHex ->+    "Expected hex digit"+  ErrReservedSymbol ->+    "Unexpected reserved symbol"+  ErrCharInGap ch ->+    "Unexpected character '" <> [ch] <> "' in gap"+  ErrModuleName ->+    "Invalid module name; underscores and primes are not allowed in module names"+  ErrQualifiedName ->+    "Unexpected qualified name"+  ErrEmptyDo ->+    "Expected do statement"+  ErrLexeme _ _ ->+    basicError+  ErrToken+    | SourceToken _ (TokLeftArrow _) : _ <- errToks ->+        "Unexpected \"<-\" in expression, perhaps due to a missing 'do' or 'ado' keyword"+  ErrToken ->+    basicError+  ErrCustom err ->+    err++  where+  basicError = case errToks of+    tok : _ -> basicTokError (tokValue tok)+    [] -> "Unexpected input"++  basicTokError = \case+    TokLayoutStart -> "Unexpected or mismatched indentation"+    TokLayoutSep   -> "Unexpected or mismatched indentation"+    TokLayoutEnd   -> "Unexpected or mismatched indentation"+    TokEof         -> "Unexpected end of input"+    tok            -> "Unexpected token '" <> Text.unpack (printToken tok) <> "'"++  displayCodePoint :: Char -> String+  displayCodePoint x =+    "U+" <> map toUpper (printf "%0.4x" (fromEnum x))++prettyPrintWarningMessage :: ParserWarning -> String+prettyPrintWarningMessage (ParserErrorInfo {..}) = case errType of+  WarnDeprecatedRowSyntax ->+    "Unary '#' syntax for row kinds is deprecated and will be removed in a future release. Use the 'Row' kind instead."+  WarnDeprecatedForeignKindSyntax ->+    "Foreign kind imports are deprecated and will be removed in a future release. Use empty 'data' instead."+  WarnDeprecatedConstraintInForeignImportSyntax ->+    "Constraints are deprecated in foreign imports and will be removed in a future release. Omit the constraint instead and update the foreign module accordingly."+  WarnDeprecatedKindImportSyntax ->+    "Kind imports are deprecated and will be removed in a future release. Omit the 'kind' keyword instead."+  WarnDeprecatedKindExportSyntax ->+    "Kind exports are deprecated and will be removed in a future release. Omit the 'kind' keyword instead."
+ src/Language/PureScript/CST/Flatten.hs view
@@ -0,0 +1,314 @@+module Language.PureScript.CST.Flatten where++import Prelude++import Data.DList (DList)+import Language.PureScript.CST.Types+import Language.PureScript.CST.Positions++flattenModule :: Module a -> DList SourceToken+flattenModule m@(Module _ a b c d e f g) =+  pure a <>+  flattenName b <>+  foldMap (flattenWrapped (flattenSeparated flattenExport)) c <>+  pure d <>+  foldMap flattenImportDecl e <>+  foldMap flattenDeclaration f <>+  pure (SourceToken (TokenAnn eofRange g []) TokEof)+  where+    (_, endTkn) = moduleRange m+    eofPos = advanceLeading (srcEnd (srcRange endTkn)) g+    eofRange = SourceRange eofPos eofPos++flattenDataHead :: DataHead a -> DList SourceToken+flattenDataHead (DataHead a b c) = pure a <> flattenName b <> foldMap flattenTypeVarBinding c++flattenDataCtor :: DataCtor a -> DList SourceToken+flattenDataCtor (DataCtor _ a b) = flattenName a <> foldMap flattenType b++flattenClassHead :: ClassHead a -> DList SourceToken+flattenClassHead (ClassHead a b c d e) =+  pure a <>+  foldMap (\(f, g) -> flattenOneOrDelimited flattenConstraint f <> pure g) b <>+  flattenName c <>+  foldMap flattenTypeVarBinding d <>+  foldMap (\(f, g) -> pure f <> flattenSeparated flattenClassFundep g) e++flattenClassFundep :: ClassFundep -> DList SourceToken+flattenClassFundep = \case+  FundepDetermined a b ->+    pure a <> foldMap flattenName b+  FundepDetermines a b c ->+    foldMap flattenName a <> pure b <> foldMap flattenName c++flattenInstance :: Instance a -> DList SourceToken+flattenInstance (Instance a b) =+  flattenInstanceHead a <> foldMap (\(c, d) -> pure c <> foldMap flattenInstanceBinding d) b++flattenInstanceHead :: InstanceHead a -> DList SourceToken+flattenInstanceHead (InstanceHead a b c d e f) =+  pure a <>+  flattenName b <>+  pure c <>+  foldMap (\(g, h) -> flattenOneOrDelimited flattenConstraint g <> pure h) d <>+  flattenQualifiedName e <>+  foldMap flattenType f++flattenInstanceBinding :: InstanceBinding a -> DList SourceToken+flattenInstanceBinding = \case+  InstanceBindingSignature _ a -> flattenLabeled flattenName flattenType a+  InstanceBindingName _ a -> flattenValueBindingFields a++flattenValueBindingFields :: ValueBindingFields a -> DList SourceToken+flattenValueBindingFields (ValueBindingFields a b c) =+  flattenName a <>+  foldMap flattenBinder b <>+  flattenGuarded c++flattenBinder :: Binder a -> DList SourceToken+flattenBinder = \case+  BinderWildcard _ a -> pure a+  BinderVar _ a -> flattenName a+  BinderNamed _ a b c -> flattenName a <> pure b <> flattenBinder c+  BinderConstructor _ a b -> flattenQualifiedName a <> foldMap flattenBinder b+  BinderBoolean _ a _ -> pure a+  BinderChar _ a _ -> pure a+  BinderString _ a _ -> pure a+  BinderNumber _ a b _ -> foldMap pure a <> pure b+  BinderArray _ a -> flattenWrapped (foldMap (flattenSeparated flattenBinder)) a+  BinderRecord _ a ->+    flattenWrapped (foldMap (flattenSeparated (flattenRecordLabeled flattenBinder))) a+  BinderParens _ a -> flattenWrapped flattenBinder a+  BinderTyped _ a b c -> flattenBinder a <> pure b <> flattenType c+  BinderOp _ a b c -> flattenBinder a <> flattenQualifiedName b <> flattenBinder c++flattenRecordLabeled :: (a -> DList SourceToken) -> RecordLabeled a -> DList SourceToken+flattenRecordLabeled f = \case+  RecordPun a -> flattenName a+  RecordField a b c -> flattenLabel a <> pure b <> f c++flattenRecordAccessor :: RecordAccessor a -> DList SourceToken+flattenRecordAccessor (RecordAccessor a b c) =+  flattenExpr a <> pure b <> flattenSeparated flattenLabel c++flattenRecordUpdate :: RecordUpdate a -> DList SourceToken+flattenRecordUpdate = \case+  RecordUpdateLeaf a b c -> flattenLabel a <> pure b <> flattenExpr c+  RecordUpdateBranch a b ->+    flattenLabel a <> flattenWrapped (flattenSeparated flattenRecordUpdate) b++flattenLambda :: Lambda a -> DList SourceToken+flattenLambda (Lambda a b c d) =+  pure a <> foldMap flattenBinder b <> pure c <> flattenExpr d++flattenIfThenElse :: IfThenElse a -> DList SourceToken+flattenIfThenElse (IfThenElse a b c d e f) =+  pure a <> flattenExpr b <> pure c <> flattenExpr d <> pure e <> flattenExpr f++flattenCaseOf :: CaseOf a -> DList SourceToken+flattenCaseOf (CaseOf a b c d) =+  pure a <>+  flattenSeparated flattenExpr b <>+  pure c <>+  foldMap (\(e, f) -> flattenSeparated flattenBinder e <> flattenGuarded f) d++flattenLetIn :: LetIn a -> DList SourceToken+flattenLetIn (LetIn a b c d) =+  pure a <> foldMap flattenLetBinding b <> pure c <> flattenExpr d++flattenDoBlock :: DoBlock a -> DList SourceToken+flattenDoBlock (DoBlock a b) =+  pure a <> foldMap flattenDoStatement b++flattenAdoBlock :: AdoBlock a -> DList SourceToken+flattenAdoBlock (AdoBlock a b c d) =+  pure a <> foldMap flattenDoStatement b <> pure c <> flattenExpr d++flattenDoStatement :: DoStatement a -> DList SourceToken+flattenDoStatement = \case+  DoLet a b -> pure a <> foldMap flattenLetBinding b+  DoDiscard a -> flattenExpr a+  DoBind a b c -> flattenBinder a <> pure b <> flattenExpr c++flattenExpr :: Expr a -> DList SourceToken+flattenExpr = \case+  ExprHole _ a -> flattenName a+  ExprSection _ a -> pure a+  ExprIdent _ a -> flattenQualifiedName a+  ExprConstructor _ a -> flattenQualifiedName a+  ExprBoolean _ a _ -> pure a+  ExprChar _ a _ -> pure a+  ExprString _ a _ -> pure a+  ExprNumber _ a _ -> pure a+  ExprArray _ a -> flattenWrapped (foldMap (flattenSeparated flattenExpr)) a+  ExprRecord _ a ->+    flattenWrapped (foldMap (flattenSeparated (flattenRecordLabeled flattenExpr))) a+  ExprParens _ a -> flattenWrapped flattenExpr a+  ExprTyped _ a b c -> flattenExpr a <> pure b <> flattenType c+  ExprInfix _ a b c -> flattenExpr a <> flattenWrapped flattenExpr b <> flattenExpr c+  ExprOp _ a b c -> flattenExpr a <> flattenQualifiedName b <> flattenExpr c+  ExprOpName _ a -> flattenQualifiedName a+  ExprNegate _ a b -> pure a <> flattenExpr b+  ExprRecordAccessor _ a -> flattenRecordAccessor a+  ExprRecordUpdate _ a b -> flattenExpr a <> flattenWrapped (flattenSeparated flattenRecordUpdate) b+  ExprApp _ a b -> flattenExpr a <> flattenExpr b+  ExprLambda _ a -> flattenLambda a+  ExprIf _ a -> flattenIfThenElse a+  ExprCase _ a -> flattenCaseOf a+  ExprLet _ a -> flattenLetIn a+  ExprDo _ a -> flattenDoBlock a+  ExprAdo _ a -> flattenAdoBlock a++flattenLetBinding :: LetBinding a -> DList SourceToken+flattenLetBinding = \case+  LetBindingSignature _ a -> flattenLabeled flattenName flattenType a+  LetBindingName _ a -> flattenValueBindingFields a+  LetBindingPattern _ a b c -> flattenBinder a <> pure b <> flattenWhere c++flattenWhere :: Where a -> DList SourceToken+flattenWhere (Where a b) =+  flattenExpr a <> foldMap (\(c, d) -> pure c <> foldMap flattenLetBinding d) b++flattenPatternGuard :: PatternGuard a -> DList SourceToken+flattenPatternGuard (PatternGuard a b) =+  foldMap (\(c, d) -> flattenBinder c <> pure d) a <> flattenExpr b++flattenGuardedExpr :: GuardedExpr a -> DList SourceToken+flattenGuardedExpr (GuardedExpr a b c d) =+  pure a <>+  flattenSeparated flattenPatternGuard b <>+  pure c <>+  flattenWhere d++flattenGuarded :: Guarded a -> DList SourceToken+flattenGuarded = \case+  Unconditional a b -> pure a <> flattenWhere b+  Guarded a -> foldMap flattenGuardedExpr a++flattenFixityFields :: FixityFields -> DList SourceToken+flattenFixityFields (FixityFields (a, _) (b, _) c) =+  pure a <> pure b <> flattenFixityOp c++flattenFixityOp :: FixityOp -> DList SourceToken+flattenFixityOp = \case+  FixityValue a b c -> flattenQualifiedName a <> pure b <> flattenName c+  FixityType a b c d -> pure a <> flattenQualifiedName b <> pure c <> flattenName d++flattenForeign :: Foreign a -> DList SourceToken+flattenForeign = \case+  ForeignValue a -> flattenLabeled flattenName flattenType a+  ForeignData a b -> pure a <> flattenLabeled flattenName flattenType b+  ForeignKind a b -> pure a <> flattenName b++flattenRole :: Role -> DList SourceToken+flattenRole = pure . roleTok++flattenDeclaration :: Declaration a -> DList SourceToken+flattenDeclaration = \case+  DeclData _ a b ->+    flattenDataHead a <>+    foldMap (\(t, cs) -> pure t <> flattenSeparated flattenDataCtor cs) b+  DeclType _ a b c ->flattenDataHead a <> pure b <> flattenType c+  DeclNewtype _ a b c d -> flattenDataHead a <> pure b <> flattenName c <> flattenType d+  DeclClass _ a b ->+    flattenClassHead a <>+    foldMap (\(c, d) -> pure c <> foldMap (flattenLabeled flattenName flattenType) d) b+  DeclInstanceChain _ a -> flattenSeparated flattenInstance a+  DeclDerive _ a b c -> pure a <> foldMap pure b <> flattenInstanceHead c+  DeclKindSignature _ a b -> pure a <> flattenLabeled flattenName flattenType b+  DeclSignature _ a -> flattenLabeled flattenName flattenType a+  DeclFixity _ a -> flattenFixityFields a+  DeclForeign _ a b c -> pure a <> pure b <> flattenForeign c+  DeclRole _ a b c d -> pure a <> pure b <> flattenName c <> foldMap flattenRole d+  DeclValue _ a -> flattenValueBindingFields a++flattenQualifiedName :: QualifiedName a -> DList SourceToken+flattenQualifiedName = pure . qualTok++flattenName :: Name a -> DList SourceToken+flattenName = pure . nameTok++flattenLabel :: Label -> DList SourceToken+flattenLabel = pure . lblTok++flattenExport :: Export a -> DList SourceToken+flattenExport = \case+  ExportValue _ n -> flattenName n+  ExportOp _ n -> flattenName n+  ExportType _ n dms -> flattenName n <> foldMap flattenDataMembers dms+  ExportTypeOp _ t n -> pure t <> flattenName n+  ExportClass _ t n -> pure t <> flattenName n+  ExportKind _ t n -> pure t <> flattenName n+  ExportModule _ t n -> pure t <> flattenName n++flattenDataMembers :: DataMembers a -> DList SourceToken+flattenDataMembers = \case+  DataAll _ t -> pure t+  DataEnumerated _ ns -> flattenWrapped (foldMap (flattenSeparated flattenName)) ns++flattenImportDecl :: ImportDecl a -> DList SourceToken+flattenImportDecl (ImportDecl _ a b c d) =+  pure a <>+  flattenName b <>+  foldMap (\(mt, is) ->+             foldMap pure mt <> flattenWrapped (flattenSeparated flattenImport) is) c <>+  foldMap (\(t, n) -> pure t <> flattenName n) d++flattenImport :: Import a -> DList SourceToken+flattenImport = \case+  ImportValue _ n -> flattenName n+  ImportOp _ n -> flattenName n+  ImportType _ n dms -> flattenName n <> foldMap flattenDataMembers dms+  ImportTypeOp _ t n -> pure t <> flattenName n+  ImportClass _ t n -> pure t <> flattenName n+  ImportKind _ t n -> pure t <> flattenName n++flattenWrapped :: (a -> DList SourceToken) -> Wrapped a -> DList SourceToken+flattenWrapped k (Wrapped a b c) = pure a <> k b <> pure c++flattenSeparated :: (a -> DList SourceToken) -> Separated a -> DList SourceToken+flattenSeparated k (Separated a b) = k a <> foldMap (\(c, d) -> pure c <> k d) b++flattenOneOrDelimited+  :: (a -> DList SourceToken) -> OneOrDelimited a -> DList SourceToken+flattenOneOrDelimited f = \case+  One a -> f a+  Many a -> flattenWrapped (flattenSeparated f) a++flattenLabeled :: (a -> DList SourceToken) -> (b -> DList SourceToken) -> Labeled a b -> DList SourceToken+flattenLabeled ka kc (Labeled a b c) = ka a <> pure b <> kc c++flattenType :: Type a -> DList SourceToken+flattenType = \case+  TypeVar _ a -> pure $ nameTok a+  TypeConstructor _ a -> pure $ qualTok a+  TypeWildcard _ a -> pure a+  TypeHole _ a -> pure $ nameTok a+  TypeString _ a _ -> pure a+  TypeRow _ a -> flattenWrapped flattenRow a+  TypeRecord _ a -> flattenWrapped flattenRow a+  TypeForall _ a b c d -> pure a <> foldMap flattenTypeVarBinding b <> pure c <> flattenType d+  TypeKinded _ a b c -> flattenType a <> pure b <> flattenType c+  TypeApp _ a b -> flattenType a <> flattenType b+  TypeOp _ a b c -> flattenType a <> pure (qualTok b) <> flattenType c+  TypeOpName _ a -> pure $ qualTok a+  TypeArr _ a b c -> flattenType a <> pure b <> flattenType c+  TypeArrName _ a -> pure a+  TypeConstrained _ a b c -> flattenConstraint a <> pure b <> flattenType c+  TypeParens _ a -> flattenWrapped flattenType a+  TypeUnaryRow _ a b -> pure a <> flattenType b++flattenRow :: Row a -> DList SourceToken+flattenRow (Row lbls tl) =+  foldMap (flattenSeparated (flattenLabeled (pure . lblTok) flattenType)) lbls+    <> foldMap (\(a, b) -> pure a <> flattenType b) tl++flattenTypeVarBinding :: TypeVarBinding a -> DList SourceToken+flattenTypeVarBinding = \case+  TypeVarKinded a -> flattenWrapped (flattenLabeled (pure . nameTok) flattenType) a+  TypeVarName a -> pure $ nameTok a++flattenConstraint :: Constraint a -> DList SourceToken+flattenConstraint = \case+  Constraint _ a b -> pure (qualTok a) <> foldMap flattenType b+  ConstraintParens _ a -> flattenWrapped flattenConstraint a
+ src/Language/PureScript/CST/Layout.hs view
@@ -0,0 +1,401 @@+-- | The parser itself is unaware of indentation, and instead only parses explicit+-- delimiters which are inserted by this layout algorithm (much like Haskell).+-- This is convenient because the actual grammar can be specified apart from the+-- indentation rules. Haskell has a few problematic productions which make it+-- impossible to implement a purely lexical layout algorithm, so it also has an+-- additional (and somewhat contentious) parser error side condition. PureScript+-- does not have these problematic productions (particularly foo, bar ::+-- SomeType syntax in declarations), but it does have a few gotchas of it's own.+-- The algorithm is "non-trivial" to say the least, but it is implemented as a+-- purely lexical delimiter parser on a token-by-token basis, which is highly+-- convenient, since it can be replicated in any language or toolchain. There is+-- likely room to simplify it, but there are some seemingly innocuous things+-- that complicate it.+--+-- "Naked" commas (case, patterns, guards, fundeps) are a constant source of+-- complexity, and indeed too much of this is what prevents Haskell from having+-- such an algorithm. Unquoted properties for layout keywords introduce a domino+-- effect of complexity since we have to mask and unmask any usage of . (also in+-- foralls!) or labels in record literals.++module Language.PureScript.CST.Layout where++import Prelude++import Data.DList (snoc)+import qualified Data.DList as DList+import Data.Foldable (find)+import Data.Function ((&))+import Language.PureScript.CST.Types++type LayoutStack = [(SourcePos, LayoutDelim)]++data LayoutDelim+  = LytRoot+  | LytTopDecl+  | LytTopDeclHead+  | LytDeclGuard+  | LytCase+  | LytCaseBinders+  | LytCaseGuard+  | LytLambdaBinders+  | LytParen+  | LytBrace+  | LytSquare+  | LytIf+  | LytThen+  | LytProperty+  | LytForall+  | LytTick+  | LytLet+  | LytLetStmt+  | LytWhere+  | LytOf+  | LytDo+  | LytAdo+  deriving (Show, Eq, Ord)++isIndented :: LayoutDelim -> Bool+isIndented = \case+  LytLet     -> True+  LytLetStmt -> True+  LytWhere   -> True+  LytOf      -> True+  LytDo      -> True+  LytAdo     -> True+  _          -> False++isTopDecl :: SourcePos -> LayoutStack -> Bool+isTopDecl tokPos = \case+  [(lytPos, LytWhere), (_, LytRoot)]+    | srcColumn tokPos == srcColumn lytPos -> True+  _ -> False++lytToken :: SourcePos -> Token -> SourceToken+lytToken pos = SourceToken ann+  where+  ann = TokenAnn+    { tokRange = SourceRange pos pos+    , tokLeadingComments = []+    , tokTrailingComments = []+    }++insertLayout :: SourceToken -> SourcePos -> LayoutStack -> (LayoutStack, [SourceToken])+insertLayout src@(SourceToken tokAnn tok) nextPos stack =+  DList.toList <$> insert (stack, mempty)+  where+  tokPos =+    srcStart $ tokRange tokAnn++  insert state@(stk, acc) = case tok of+    -- `data` declarations need masking (LytTopDecl) because the usage of `|`+    -- should not introduce a LytDeclGard context.+    TokLowerName [] "data" ->+      case state & insertDefault of+        state'@(stk', _) | isTopDecl tokPos stk' ->+          state' & pushStack tokPos LytTopDecl+        state' ->+          state' & popStack (== LytProperty)++    -- `class` declaration heads need masking (LytTopDeclHead) because the+    -- usage of commas in functional dependencies.+    TokLowerName [] "class" ->+      case state & insertDefault of+        state'@(stk', _) | isTopDecl tokPos stk' ->+          state' & pushStack tokPos LytTopDeclHead+        state' ->+          state' & popStack (== LytProperty)++    TokLowerName [] "where" ->+      case stk of+        (_, LytTopDeclHead) : stk' ->+          (stk', acc) & insertToken src & insertStart LytWhere+        (_, LytProperty) : stk' ->+          (stk', acc) & insertToken src+        _ ->+          state & collapse whereP & insertToken src & insertStart LytWhere+      where+      -- `where` always closes do blocks:+      --     example = do do do do foo where foo = ...+      --+      -- `where` closes layout contexts even when indented at the same level:+      --     example = case+      --       Foo -> ...+      --       Bar -> ...+      --       where foo = ...+      whereP _      LytDo = True+      whereP lytPos lyt   = offsideEndP lytPos lyt++    TokLowerName [] "in" ->+      case collapse inP state of+        -- `let/in` is not allowed in `ado` syntax. `in` is treated as a+        -- delimiter and must always close the `ado`.+        --    example = ado+        --      foo <- ...+        --      let bar = ...+        --      in ...+        ((_, LytLetStmt) : (_, LytAdo) : stk', acc') ->+          (stk', acc') & insertEnd & insertEnd & insertToken src+        ((_, lyt) : stk', acc') | isIndented lyt ->+          (stk', acc') & insertEnd & insertToken src+        _ ->+          state & insertDefault & popStack (== LytProperty)+      where+      inP _ LytLet = False+      inP _ LytAdo = False+      inP _ lyt    = isIndented lyt++    TokLowerName [] "let" ->+      state & insertKwProperty next+      where+      next state'@(stk', _) = case stk' of+        (p, LytDo) : _ | srcColumn p == srcColumn tokPos ->+          state' & insertStart LytLetStmt+        (p, LytAdo) : _ | srcColumn p == srcColumn tokPos ->+          state' & insertStart LytLetStmt+        _ ->+          state' & insertStart LytLet++    TokLowerName _ "do" ->+      state & insertKwProperty (insertStart LytDo)++    TokLowerName _ "ado" ->+      state & insertKwProperty (insertStart LytAdo)++    -- `case` heads need masking due to commas.+    TokLowerName [] "case" ->+      state & insertKwProperty (pushStack tokPos LytCase)++    TokLowerName [] "of" ->+      case collapse indentedP state of+        -- When `of` is matched with a `case`, we are in a case block, and we+        -- need to mask additional contexts (LytCaseBinders, LytCaseGuards)+        -- due to commas.+        ((_, LytCase) : stk', acc') ->+          (stk', acc') & insertToken src & insertStart LytOf & pushStack nextPos LytCaseBinders+        state' ->+          state' & insertDefault & popStack (== LytProperty)++    -- `if/then/else` is considered a delimiter context. This allows us to+    -- write chained expressions in `do` blocks without stair-stepping:+    --     example = do+    --       foo+    --       if ... then+    --         ...+    --       else if ... then+    --         ...+    --       else+    --         ...+    TokLowerName [] "if" ->+      state & insertKwProperty (pushStack tokPos LytIf)++    TokLowerName [] "then" ->+      case state & collapse indentedP of+        ((_, LytIf) : stk', acc') ->+          (stk', acc') & insertToken src & pushStack tokPos LytThen+        _ ->+          state & insertDefault & popStack (== LytProperty)++    TokLowerName [] "else" ->+      case state & collapse indentedP of+        ((_, LytThen) : stk', acc') ->+          (stk', acc') & insertToken src+        _ ->+          -- We don't want to insert a layout separator for top-level `else` in+          -- instance chains.+          case state & collapse offsideP of+            state'@(stk', _) | isTopDecl tokPos stk' ->+              state' & insertToken src+            state' ->+              state' & insertSep & insertToken src & popStack (== LytProperty)++    -- `forall` binders need masking because the usage of `.` should not+    -- introduce a LytProperty context.+    TokForall _ ->+      state & insertKwProperty (pushStack tokPos LytForall)++    -- Lambdas need masking because the usage of `->` should not close a+    -- LytDeclGuard or LytCaseGuard context.+    TokBackslash ->+      state & insertDefault & pushStack tokPos LytLambdaBinders++    TokRightArrow _ ->+      state & collapse arrowP & popStack guardP & insertToken src+      where+      arrowP _      LytDo     = True+      arrowP _      LytOf     = False+      arrowP lytPos lyt       = offsideEndP lytPos lyt++      guardP LytCaseBinders   = True+      guardP LytCaseGuard     = True+      guardP LytLambdaBinders = True+      guardP _                = False++    TokEquals ->+      case state & collapse equalsP of+        ((_, LytDeclGuard) : stk', acc') ->+          (stk', acc') & insertToken src+        _ ->+          state & insertDefault+      where+      equalsP _ LytWhere   = True+      equalsP _ LytLet     = True+      equalsP _ LytLetStmt = True+      equalsP _ _          = False++    -- Guards need masking because of commas.+    TokPipe ->+      case collapse offsideEndP state of+        state'@((_, LytOf) : _, _) ->+          state' & pushStack tokPos LytCaseGuard & insertToken src+        state'@((_, LytLet) : _, _) ->+          state' & pushStack tokPos LytDeclGuard & insertToken src+        state'@((_, LytLetStmt) : _, _) ->+          state' & pushStack tokPos LytDeclGuard & insertToken src+        state'@((_, LytWhere) : _, _) ->+          state' & pushStack tokPos LytDeclGuard & insertToken src+        _ ->+          state & insertDefault++    -- Ticks can either start or end an infix expression. We preemptively+    -- collapse all indentation contexts in search of a starting delimiter,+    -- and backtrack if we don't find one.+    TokTick ->+      case state & collapse indentedP of+        ((_, LytTick) : stk', acc') ->+          (stk', acc') & insertToken src+        _ ->+          state & insertDefault & pushStack tokPos LytTick++    -- In general, commas should close all indented contexts.+    --     example = [ do foo+    --                    bar, baz ]+    TokComma ->+      case state & collapse indentedP of+        -- If we see a LytBrace, then we are in a record type or literal.+        -- Record labels need masking so we can use unquoted keywords as labels+        -- without accidentally littering layout delimiters.+        state'@((_, LytBrace) : _, _) ->+          state' & insertToken src & pushStack tokPos LytProperty+        state' ->+          state' & insertToken src++    -- TokDot tokens usually entail property access, which need masking so we+    -- can use unquoted keywords as labels.+    TokDot ->+      case state & insertDefault of+        ((_, LytForall) : stk', acc') ->+          (stk', acc')+        state' ->+          state' & pushStack tokPos LytProperty++    TokLeftParen ->+      state & insertDefault & pushStack tokPos LytParen++    TokLeftBrace ->+      state & insertDefault & pushStack tokPos LytBrace & pushStack tokPos LytProperty++    TokLeftSquare ->+      state & insertDefault & pushStack tokPos LytSquare++    TokRightParen ->+      state & collapse indentedP & popStack (== LytParen) & insertToken src++    TokRightBrace ->+      state & collapse indentedP & popStack (== LytProperty) & popStack (== LytBrace) & insertToken src++    TokRightSquare ->+      state & collapse indentedP & popStack (== LytSquare) & insertToken src++    TokString _ _ ->+      state & insertDefault & popStack (== LytProperty)++    TokLowerName [] _ ->+      state & insertDefault & popStack (== LytProperty)++    TokOperator _ _ ->+      state & collapse offsideEndP & insertSep & insertToken src++    _ ->+      state & insertDefault++  insertDefault state =+    state & collapse offsideP & insertSep & insertToken src++  insertStart lyt state@(stk, _) =+    -- We only insert a new layout start when it's going to increase indentation.+    -- This prevents things like the following from parsing:+    --     instance foo :: Foo where+    --     foo = 42+    case find (isIndented . snd) stk of+      Just (pos, _) | srcColumn nextPos <= srcColumn pos -> state+      _ -> state & pushStack nextPos lyt & insertToken (lytToken nextPos TokLayoutStart)++  insertSep state@(stk, acc) = case stk of+    -- LytTopDecl is closed by a separator.+    (lytPos, LytTopDecl) : stk' | sepP lytPos ->+      (stk', acc) & insertToken sepTok+    -- LytTopDeclHead can be closed by a separator if there is no `where`.+    (lytPos, LytTopDeclHead) : stk' | sepP lytPos ->+      (stk', acc) & insertToken sepTok+    (lytPos, lyt) : _ | indentSepP lytPos lyt ->+      case lyt of+        -- If a separator is inserted in a case block, we need to push an+        -- additional LytCaseBinders context for comma masking.+        LytOf -> state & insertToken sepTok & pushStack tokPos LytCaseBinders+        _     -> state & insertToken sepTok+    _ -> state+    where+    sepTok = lytToken tokPos TokLayoutSep++  insertKwProperty k state =+    case state & insertDefault of+      ((_, LytProperty) : stk', acc') ->+        (stk', acc')+      state' ->+        k state'++  insertEnd =+    insertToken (lytToken tokPos TokLayoutEnd)++  insertToken token (stk, acc) =+    (stk, acc `snoc` token)++  pushStack lytPos lyt (stk, acc) =+    ((lytPos, lyt) : stk, acc)++  popStack p ((_, lyt) : stk', acc)+    | p lyt = (stk', acc)+  popStack _ state = state++  collapse p = uncurry go+    where+    go ((lytPos, lyt) : stk) acc+      | p lytPos lyt =+          go stk $ if isIndented lyt+                   then acc `snoc` lytToken tokPos TokLayoutEnd+                   else acc+    go stk acc = (stk, acc)++  indentedP =+    const isIndented++  offsideP lytPos lyt =+    isIndented lyt && srcColumn tokPos < srcColumn lytPos++  offsideEndP lytPos lyt =+    isIndented lyt && srcColumn tokPos <= srcColumn lytPos++  indentSepP lytPos lyt =+    isIndented lyt && sepP lytPos++  sepP lytPos =+    srcColumn tokPos == srcColumn lytPos && srcLine tokPos /= srcLine lytPos++unwindLayout :: SourcePos -> [Comment LineFeed] -> LayoutStack -> [SourceToken]+unwindLayout pos leading = go+  where+  go [] = []+  go ((_, LytRoot) : _) = [SourceToken (TokenAnn (SourceRange pos pos) leading []) TokEof]+  go ((_, lyt) : stk) | isIndented lyt = lytToken pos TokLayoutEnd : go stk+  go (_ : stk) = go stk
+ src/Language/PureScript/CST/Lexer.hs view
@@ -0,0 +1,717 @@+module Language.PureScript.CST.Lexer+  ( lenient+  , lex+  , lexTopLevel+  , lexWithState+  , isUnquotedKey+  ) where++import Prelude hiding (lex, exp, exponent, lines)++import Control.Monad (join)+import qualified Data.Char as Char+import qualified Data.DList as DList+import Data.Foldable (foldl')+import Data.Functor (($>))+import qualified Data.Scientific as Sci+import Data.String (fromString)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.PureScript as Text+import Language.PureScript.CST.Errors+import Language.PureScript.CST.Monad hiding (token)+import Language.PureScript.CST.Layout+import Language.PureScript.CST.Positions+import Language.PureScript.CST.Types++-- | Stops at the first lexing error and replaces it with TokEof. Otherwise,+-- the parser will fail when it attempts to draw a lookahead token.+lenient :: [LexResult] -> [LexResult]+lenient = go+  where+  go [] = []+  go (Right a : as) = Right a : go as+  go (Left (st, _) : _) = do+    let+      pos = lexPos st+      ann = TokenAnn (SourceRange pos pos) (lexLeading st) []+    [Right (SourceToken ann TokEof)]++-- | Lexes according to root layout rules.+lex :: Text -> [LexResult]+lex src = do+  let (leading, src') = comments src+  lexWithState $ LexState+    { lexPos = advanceLeading (SourcePos 1 1) leading+    , lexLeading = leading+    , lexSource = src'+    , lexStack = [(SourcePos 0 0, LytRoot)]+    }++-- | Lexes according to top-level declaration context rules.+lexTopLevel :: Text -> [LexResult]+lexTopLevel src = do+  let+    (leading, src') = comments src+    lexPos = advanceLeading (SourcePos 1 1) leading+    hd = Right $ lytToken lexPos TokLayoutStart+    tl = lexWithState $ LexState+      { lexPos = lexPos+      , lexLeading = leading+      , lexSource = src'+      , lexStack = [(lexPos, LytWhere), (SourcePos 0 0, LytRoot)]+      }+  hd : tl++-- | Lexes according to some LexState.+lexWithState :: LexState -> [LexResult]+lexWithState = go+  where+  Parser lexK =+    tokenAndComments++  go state@(LexState {..}) =+    lexK lexSource onError onSuccess+    where+    onError lexSource' err = do+      let+        len1 = Text.length lexSource+        len2 = Text.length lexSource'+        chunk = Text.take (max 0 (len1 - len2)) lexSource+        chunkDelta = textDelta chunk+        pos = applyDelta lexPos chunkDelta+      pure $ Left+        ( state { lexSource = lexSource' }+        , ParserErrorInfo (SourceRange pos $ applyDelta pos (0, 1)) [] lexStack err+        )++    onSuccess _ (TokEof, _) =+      Right <$> unwindLayout lexPos lexLeading lexStack+    onSuccess lexSource' (tok, (trailing, lexLeading')) = do+      let+        endPos = advanceToken lexPos tok+        lexPos' = advanceLeading (advanceTrailing endPos trailing) lexLeading'+        tokenAnn = TokenAnn+          { tokRange = SourceRange lexPos endPos+          , tokLeadingComments = lexLeading+          , tokTrailingComments = trailing+          }+        (lexStack', toks) =+          insertLayout (SourceToken tokenAnn tok) lexPos' lexStack+        state' = LexState+          { lexPos = lexPos'+          , lexLeading = lexLeading'+          , lexSource = lexSource'+          , lexStack = lexStack'+          }+      go2 state' toks++  go2 state [] = go state+  go2 state (t : ts) = Right t : go2 state ts++type Lexer = ParserM ParserErrorType Text++{-# INLINE next #-}+next :: Lexer ()+next = Parser $ \inp _ ksucc ->+  ksucc (Text.drop 1 inp) ()++{-# INLINE nextWhile #-}+nextWhile :: (Char -> Bool) -> Lexer Text+nextWhile p = Parser $ \inp _ ksucc -> do+  let (chs, inp') = Text.span p inp+  ksucc inp' chs++{-# INLINE nextWhile' #-}+nextWhile' :: Int -> (Char -> Bool) -> Lexer Text+nextWhile' n p = Parser $ \inp _ ksucc -> do+  let (chs, inp') = Text.spanUpTo n p inp+  ksucc inp' chs++{-# INLINE peek #-}+peek :: Lexer (Maybe Char)+peek = Parser $ \inp _ ksucc ->+  if Text.null inp+    then ksucc inp Nothing+    else ksucc inp $ Just $ Text.head inp++{-# INLINE restore #-}+restore :: (ParserErrorType -> Bool) -> Lexer a -> Lexer a+restore p (Parser k) = Parser $ \inp kerr ksucc ->+  k inp (\inp' err -> kerr (if p err then inp else inp') err) ksucc++tokenAndComments :: Lexer (Token, ([Comment void], [Comment LineFeed]))+tokenAndComments = (,) <$> token <*> breakComments++comments :: Text -> ([Comment LineFeed], Text)+comments = \src -> k src (\_ _ -> ([], src)) (\inp (a, b) -> (a <> b, inp))+  where+  Parser k = breakComments++breakComments :: Lexer ([Comment void], [Comment LineFeed])+breakComments = k0 []+  where+  k0 acc = do+    spaces <- nextWhile (== ' ')+    lines  <- nextWhile isLineFeed+    let+      acc'+        | Text.null spaces = acc+        | otherwise = Space (Text.length spaces) : acc+    if Text.null lines+      then do+        mbComm <- comment+        case mbComm of+          Just comm -> k0 (comm : acc')+          Nothing   -> pure (reverse acc', [])+      else+        k1 acc' (goWs [] $ Text.unpack lines)++  k1 trl acc = do+    ws <- nextWhile (\c -> c == ' ' || isLineFeed c)+    let acc' = goWs acc $ Text.unpack ws+    mbComm <- comment+    case mbComm of+      Just comm -> k1 trl (comm : acc')+      Nothing   -> pure (reverse trl, reverse acc')++  goWs a ('\r' : '\n' : ls) = goWs (Line CRLF : a) ls+  goWs a ('\r' : ls) = goWs (Line CRLF : a) ls+  goWs a ('\n' : ls) = goWs (Line LF : a) ls+  goWs a (' ' : ls) = goSpace a 1 ls+  goWs a _ = a++  goSpace a !n (' ' : ls) = goSpace a (n + 1) ls+  goSpace a !n ls = goWs (Space n : a) ls++  isBlockComment = Parser $ \inp _ ksucc ->+    case Text.uncons inp of+      Just ('-', inp2) ->+        case Text.uncons inp2 of+          Just ('-', inp3) ->+            ksucc inp3 $ Just False+          _ ->+            ksucc inp Nothing+      Just ('{', inp2) ->+        case Text.uncons inp2 of+          Just ('-', inp3) ->+            ksucc inp3 $ Just True+          _ ->+            ksucc inp Nothing+      _ ->+        ksucc inp Nothing++  comment = isBlockComment >>= \case+    Just True  -> Just <$> blockComment "{-"+    Just False -> Just <$> lineComment "--"+    Nothing    -> pure $ Nothing++  lineComment acc = do+    comm <- nextWhile (\c -> c /= '\r' && c /= '\n')+    pure $ Comment (acc <> comm)++  blockComment acc = do+    chs <- nextWhile (/= '-')+    dashes <- nextWhile (== '-')+    if Text.null dashes+      then pure $ Comment $ acc <> chs+      else peek >>= \case+        Just '}' -> next $> Comment (acc <> chs <> dashes <> "}")+        _ -> blockComment (acc <> chs <> dashes)++token :: Lexer Token+token = peek >>= maybe (pure TokEof) k0+  where+  k0 ch1 = case ch1 of+    '('  -> next *> leftParen+    ')'  -> next $> TokRightParen+    '{'  -> next $> TokLeftBrace+    '}'  -> next $> TokRightBrace+    '['  -> next $> TokLeftSquare+    ']'  -> next $> TokRightSquare+    '`'  -> next $> TokTick+    ','  -> next $> TokComma+    '∷'  -> next *> orOperator1 (TokDoubleColon Unicode) ch1+    '←'  -> next *> orOperator1 (TokLeftArrow Unicode) ch1+    '→'  -> next *> orOperator1 (TokRightArrow Unicode) ch1+    '⇒'  -> next *> orOperator1 (TokRightFatArrow Unicode) ch1+    '∀'  -> next *> orOperator1 (TokForall Unicode) ch1+    '|'  -> next *> orOperator1 TokPipe ch1+    '.'  -> next *> orOperator1 TokDot ch1+    '\\' -> next *> orOperator1 TokBackslash ch1+    '<'  -> next *> orOperator2 (TokLeftArrow ASCII) ch1 '-'+    '-'  -> next *> orOperator2 (TokRightArrow ASCII) ch1 '>'+    '='  -> next *> orOperator2' TokEquals (TokRightFatArrow ASCII) ch1 '>'+    ':'  -> next *> orOperator2' (TokOperator [] ":") (TokDoubleColon ASCII) ch1 ':'+    '?'  -> next *> hole+    '\'' -> next *> char+    '"'  -> next *> string+    _  | Char.isDigit ch1 -> restore (== ErrNumberOutOfRange) (next *> number ch1)+       | Char.isUpper ch1 -> next *> upper [] ch1+       | isIdentStart ch1 -> next *> lower [] ch1+       | isSymbolChar ch1 -> next *> operator [] [ch1]+       | otherwise        -> throw $ ErrLexeme (Just [ch1]) []++  {-# INLINE orOperator1 #-}+  orOperator1 :: Token -> Char -> Lexer Token+  orOperator1 tok ch1 = join $ Parser $ \inp _ ksucc ->+    case Text.uncons inp of+      Just (ch2, inp2) | isSymbolChar ch2 ->+        ksucc inp2 $ operator [] [ch1, ch2]+      _ ->+        ksucc inp $ pure tok++  {-# INLINE orOperator2 #-}+  orOperator2 :: Token -> Char -> Char -> Lexer Token+  orOperator2 tok ch1 ch2 = join $ Parser $ \inp _ ksucc ->+    case Text.uncons inp of+      Just (ch2', inp2) | ch2 == ch2' ->+        case Text.uncons inp2 of+          Just (ch3, inp3) | isSymbolChar ch3 ->+            ksucc inp3 $ operator [] [ch1, ch2, ch3]+          _ ->+            ksucc inp2 $ pure tok+      _ ->+        ksucc inp $ operator [] [ch1]++  {-# INLINE orOperator2' #-}+  orOperator2' :: Token -> Token -> Char -> Char -> Lexer Token+  orOperator2' tok1 tok2 ch1 ch2 = join $ Parser $ \inp _ ksucc ->+    case Text.uncons inp of+      Just (ch2', inp2) | ch2 == ch2' ->+        case Text.uncons inp2 of+          Just (ch3, inp3) | isSymbolChar ch3 ->+            ksucc inp3 $ operator [] [ch1, ch2, ch3]+          _ ->+            ksucc inp2 $ pure tok2+      Just (ch2', inp2) | isSymbolChar ch2' ->+        ksucc inp2 $ operator [] [ch1, ch2']+      _ ->+        ksucc inp $ pure tok1++  {-+    leftParen+      : '(' '→'  ')'+      | '(' '->' ')'+      | '('  symbolChar+  ')'+      | '('+  -}+  leftParen :: Lexer Token+  leftParen = Parser $ \inp kerr ksucc ->+    case Text.span isSymbolChar inp of+      (chs, inp2)+        | Text.null chs -> ksucc inp TokLeftParen+        | otherwise ->+            case Text.uncons inp2 of+              Just (')', inp3) ->+                case chs of+                  "→"  -> ksucc inp3 $ TokSymbolArr Unicode+                  "->" -> ksucc inp3 $ TokSymbolArr ASCII+                  _ | isReservedSymbol chs -> kerr inp ErrReservedSymbol+                    | otherwise -> ksucc inp3 $ TokSymbolName [] chs+              _ -> ksucc inp TokLeftParen++  {-+    symbol+      : '(' symbolChar+ ')'+  -}+  symbol :: [Text] -> Lexer Token+  symbol qual = restore isReservedSymbolError $ peek >>= \case+    Just ch | isSymbolChar ch ->+      nextWhile isSymbolChar >>= \chs ->+        peek >>= \case+          Just ')'+            | isReservedSymbol chs -> throw ErrReservedSymbol+            | otherwise -> next $> TokSymbolName (reverse qual) chs+          Just ch2 -> throw $ ErrLexeme (Just [ch2]) []+          Nothing  -> throw ErrEof+    Just ch -> throw $ ErrLexeme (Just [ch]) []+    Nothing -> throw ErrEof++  {-+    operator+      : symbolChar++  -}+  operator :: [Text] -> [Char] -> Lexer Token+  operator qual pre = do+    rest <- nextWhile isSymbolChar+    pure . TokOperator (reverse qual) $ Text.pack pre <> rest++  {-+    moduleName+      : upperChar alphaNumChar*++    qualifier+      : (moduleName '.')* moduleName++    upper+      : (qualifier '.')? upperChar identChar*+      | qualifier '.' lowerQualified+      | qualifier '.' operator+      | qualifier '.' symbol+  -}+  upper :: [Text] -> Char -> Lexer Token+  upper qual pre = do+    rest <- nextWhile isIdentChar+    ch1  <- peek+    let name = Text.cons pre rest+    case ch1 of+      Just '.' -> do+        let qual' = name : qual+        next *> peek >>= \case+          Just '(' -> next *> symbol qual'+          Just ch2+            | Char.isUpper ch2 -> next *> upper qual' ch2+            | isIdentStart ch2 -> next *> lower qual' ch2+            | isSymbolChar ch2 -> next *> operator qual' [ch2]+            | otherwise -> throw $ ErrLexeme (Just [ch2]) []+          Nothing ->+            throw ErrEof+      _ ->+        pure $ TokUpperName (reverse qual) name++  {-+    lower+      : '_'+      | 'forall'+      | lowerChar identChar*++    lowerQualified+      : lowerChar identChar*+  -}+  lower :: [Text] -> Char -> Lexer Token+  lower qual pre = do+    rest <- nextWhile isIdentChar+    case pre of+      '_' | Text.null rest ->+        if null qual+          then pure TokUnderscore+          else throw $ ErrLexeme (Just [pre]) []+      _ ->+        case Text.cons pre rest of+          "forall" | null qual -> pure $ TokForall ASCII+          name -> pure $ TokLowerName (reverse qual) name++  {-+    hole+      : '?' identChar++  -}+  hole :: Lexer Token+  hole = do+    name <- nextWhile isIdentChar+    if Text.null name+      then operator [] ['?']+      else pure $ TokHole name++  {-+    char+      : "'" '\' escape "'"+      | "'" [^'] "'"+  -}+  char :: Lexer Token+  char = do+    (raw, ch) <- peek >>= \case+      Just '\\' -> do+        (raw, ch2) <- next *> escape+        pure (Text.cons '\\' raw, ch2)+      Just ch ->+        next $> (Text.singleton ch, ch)+      Nothing ->+        throw $ ErrEof+    peek >>= \case+      Just '\''+        | fromEnum ch > 0xFFFF -> throw ErrAstralCodePointInChar+        | otherwise -> next $> TokChar raw ch+      Just ch2 ->+        throw $ ErrLexeme (Just [ch2]) []+      _ ->+        throw $ ErrEof++  {-+    stringPart+      : '\' escape+      | '\' [ \r\n]+ '\'+      | [^"]++    string+      : '"' stringPart* '"'+      | '"""' '"'{0,2} ([^"]+ '"'{1,2})* [^"]* '"""'++    A raw string literal can't contain any sequence of 3 or more quotes,+    although sequences of 1 or 2 quotes are allowed anywhere, including at the+    beginning or the end.+  -}+  string :: Lexer Token+  string = do+    quotes1 <- nextWhile' 7 (== '"')+    case Text.length quotes1 of+      0 -> do+        let+          go raw acc = do+            chs <- nextWhile isNormalStringChar+            let+              raw' = raw <> chs+              acc' = acc <> DList.fromList (Text.unpack chs)+            peek >>= \case+              Just '"'  -> next $> TokString raw' (fromString (DList.toList acc'))+              Just '\\' -> next *> goEscape (raw' <> "\\") acc'+              Just _    -> throw ErrLineFeedInString+              Nothing   -> throw ErrEof++          goEscape raw acc = do+            mbCh <- peek+            case mbCh of+              Just ch1 | isStringGapChar ch1 -> do+                gap <- nextWhile isStringGapChar+                peek >>= \case+                  Just '"'  -> next $> TokString (raw <> gap) (fromString (DList.toList acc))+                  Just '\\' -> next *> go (raw <> gap <> "\\") acc+                  Just ch   -> throw $ ErrCharInGap ch+                  Nothing   -> throw ErrEof+              _ -> do+                (raw', ch) <- escape+                go (raw <> raw') (acc <> DList.singleton ch)+        go "" mempty+      1 ->+        pure $ TokString "" ""+      n | n >= 5 ->+        pure $ TokRawString $ Text.drop 5 quotes1+      _ -> do+        let+          go acc = do+            chs <- nextWhile (/= '"')+            quotes2 <- nextWhile' 5 (== '"')+            case Text.length quotes2 of+              0          -> throw ErrEof+              n | n >= 3 -> pure $ TokRawString $ acc <> chs <> Text.drop 3 quotes2+              _          -> go (acc <> chs <> quotes2)+        go $ Text.drop 2 quotes1++  {-+    escape+      : 't'+      | 'r'+      | 'n'+      | "'"+      | '"'+      | 'x' [0-9a-fA-F]{0,6}+  -}+  escape :: Lexer (Text, Char)+  escape = do+    ch <- peek+    case ch of+      Just 't'  -> next $> ("t", '\t')+      Just 'r'  -> next $> ("r", '\r')+      Just 'n'  -> next $> ("n", '\n')+      Just '"'  -> next $> ("\"", '"')+      Just '\'' -> next $> ("'", '\'')+      Just '\\' -> next $> ("\\", '\\')+      Just 'x'  -> (*>) next $ Parser $ \inp kerr ksucc -> do+        let+          go n acc (ch' : chs)+            | Char.isHexDigit ch' = go (n * 16 + Char.digitToInt ch') (ch' : acc) chs+          go n acc _+            | n <= 0x10FFFF =+                ksucc (Text.drop (length acc) inp)+                  ("x" <> Text.pack (reverse acc), Char.chr n)+            | otherwise =+                kerr inp ErrCharEscape -- TODO+        go 0 [] $ Text.unpack $ Text.take 6 inp+      _ -> throw ErrCharEscape++  {-+    number+      : hexadecimal+      | integer ('.'  fraction)? exponent?+  -}+  number :: Char -> Lexer Token+  number ch1 = peek >>= \ch2 -> case (ch1, ch2) of+    ('0', Just 'x') -> next *> hexadecimal+    (_, _) -> do+      mbInt <- integer1 ch1+      mbFraction <- fraction+      case (mbInt, mbFraction) of+        (Just (raw, int), Nothing) -> do+          let int' = digitsToInteger int+          exponent >>= \case+            Just (raw', exp) ->+              sciDouble (raw <> raw') $ Sci.scientific int' exp+            Nothing ->+              pure $ TokInt raw int'+        (Just (raw, int), Just (raw', frac)) -> do+          let sci = digitsToScientific int frac+          exponent >>= \case+            Just (raw'', exp) ->+              sciDouble (raw <> raw' <> raw'') $ uncurry Sci.scientific $ (+ exp) <$> sci+            Nothing ->+              sciDouble (raw <> raw') $ uncurry Sci.scientific sci+        (Nothing, Just (raw, frac)) -> do+          let sci = digitsToScientific [] frac+          exponent >>= \case+            Just (raw', exp) ->+              sciDouble (raw <> raw') $ uncurry Sci.scientific $ (+ exp) <$> sci+            Nothing ->+              sciDouble raw $ uncurry Sci.scientific sci+        (Nothing, Nothing) ->+          peek >>= \ch -> throw $ ErrLexeme (pure <$> ch) []++  sciDouble :: Text -> Sci.Scientific -> Lexer Token+  sciDouble raw sci = case Sci.toBoundedRealFloat sci of+    Left _ -> throw ErrNumberOutOfRange+    Right n -> pure $ TokNumber raw n++  {-+    integer+      : '0'+      | [1-9] digits+  -}+  integer :: Lexer (Maybe (Text, String))+  integer = peek >>= \case+    Just '0' -> next *> peek >>= \case+      Just ch | isNumberChar ch -> throw ErrLeadingZero+      _ -> pure $ Just ("0", "0")+    Just ch | isDigitChar ch -> Just <$> digits+    _ -> pure $ Nothing++  {-+    integer1+      : '0'+      | [1-9] digits++    This is the same as 'integer', the only difference is that this expects the+    first char to be consumed during dispatch.+  -}+  integer1 :: Char -> Lexer (Maybe (Text, String))+  integer1 = \case+    '0' -> peek >>= \case+      Just ch | isNumberChar ch -> throw ErrLeadingZero+      _ -> pure $ Just ("0", "0")+    ch | isDigitChar ch -> do+      (raw, chs) <- digits+      pure $ Just (Text.cons ch raw, ch : chs)+    _ -> pure $ Nothing++  {-+    fraction+      : '.' [0-9_]++  -}+  fraction :: Lexer (Maybe (Text, String))+  fraction = Parser $ \inp _ ksucc ->+    -- We need more than a single char lookahead for things like `1..10`.+    case Text.uncons inp of+      Just ('.', inp')+        | (raw, inp'') <- Text.span isNumberChar inp'+        , not (Text.null raw) ->+            ksucc inp'' $ Just ("." <> raw, filter (/= '_') $ Text.unpack raw)+      _ ->+        ksucc inp Nothing++  {-+    digits+      : [0-9_]*++    Digits can contain underscores, which are ignored.+  -}+  digits :: Lexer (Text, String)+  digits = do+    raw <- nextWhile isNumberChar+    pure (raw, filter (/= '_') $ Text.unpack raw)++  {-+    exponent+      : 'e' ('+' | '-')? integer+  -}+  exponent :: Lexer (Maybe (Text, Int))+  exponent = peek >>= \case+    Just 'e' -> do+      (neg, sign) <- next *> peek >>= \case+        Just '-' -> next $> (True, "-")+        Just '+' -> next $> (False, "+")+        _   -> pure (False, "")+      integer >>= \case+        Just (raw, chs) -> do+          let+            int | neg = negate $ digitsToInteger chs+                | otherwise = digitsToInteger chs+          pure $ Just ("e" <> sign <> raw, fromInteger int)+        Nothing -> throw ErrExpectedExponent+    _ ->+      pure Nothing++  {-+    hexadecimal+      : '0x' [0-9a-fA-F]++  -}+  hexadecimal :: Lexer Token+  hexadecimal = do+    chs <- nextWhile Char.isHexDigit+    if Text.null chs+      then throw ErrExpectedHex+      else pure $ TokInt ("0x" <> chs) $ digitsToIntegerBase 16 $ Text.unpack chs++digitsToInteger :: [Char] -> Integer+digitsToInteger = digitsToIntegerBase 10++digitsToIntegerBase :: Integer -> [Char] -> Integer+digitsToIntegerBase b = foldl' (\n c -> n * b + (toInteger (Char.digitToInt c))) 0++digitsToScientific :: [Char] -> [Char] -> (Integer, Int)+digitsToScientific = go 0 . reverse+  where+  go !exp is [] = (digitsToInteger (reverse is), exp)+  go !exp is (f : fs) = go (exp - 1) (f : is) fs++isSymbolChar :: Char -> Bool+isSymbolChar c = (c `elem` (":!#$%&*+./<=>?@\\^|-~" :: [Char])) || (not (Char.isAscii c) && Char.isSymbol c)++isReservedSymbolError :: ParserErrorType -> Bool+isReservedSymbolError = (== ErrReservedSymbol)++isReservedSymbol :: Text -> Bool+isReservedSymbol = flip elem symbols+  where+  symbols =+    [ "::"+    , "∷"+    , "<-"+    , "←"+    , "->"+    , "→"+    , "=>"+    , "⇒"+    , "∀"+    , "|"+    , "."+    , "\\"+    , "="+    ]++isIdentStart :: Char -> Bool+isIdentStart c = Char.isLower c || c == '_'++isIdentChar :: Char -> Bool+isIdentChar c = Char.isAlphaNum c || c == '_' || c == '\''++isDigitChar :: Char -> Bool+isDigitChar c = c >= '0' && c <= '9'++isNumberChar :: Char -> Bool+isNumberChar c = (c >= '0' && c <= '9') || c == '_'++isNormalStringChar :: Char -> Bool+isNormalStringChar c = c /= '"' && c /= '\\' && c /= '\r' && c /= '\n'++isStringGapChar :: Char -> Bool+isStringGapChar c = c == ' ' || c == '\r' || c == '\n'++isLineFeed :: Char -> Bool+isLineFeed c = c == '\r' || c == '\n'++-- | Checks if some identifier is a valid unquoted key.+isUnquotedKey :: Text -> Bool+isUnquotedKey t =+  case Text.uncons t of+    Nothing ->+      False+    Just (hd, tl) ->+      isIdentStart hd && Text.all isIdentChar tl
+ src/Language/PureScript/CST/Monad.hs view
@@ -0,0 +1,189 @@+module Language.PureScript.CST.Monad where++import Prelude++import Data.List (sortBy)+import qualified Data.List.NonEmpty as NE+import Data.Ord (comparing)+import Data.Text (Text)+import Language.PureScript.CST.Errors+import Language.PureScript.CST.Layout+import Language.PureScript.CST.Positions+import Language.PureScript.CST.Types++type LexResult = Either (LexState, ParserError) SourceToken++data LexState = LexState+  { lexPos :: SourcePos+  , lexLeading :: [Comment LineFeed]+  , lexSource :: Text+  , lexStack :: LayoutStack+  } deriving (Show)++data ParserState = ParserState+  { parserBuff :: [LexResult]+  , parserErrors :: [ParserError]+  , parserWarnings :: [ParserWarning]+  } deriving (Show)++-- | A bare bones, CPS'ed `StateT s (Except e) a`.+newtype ParserM e s a =+  Parser (forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)++type Parser = ParserM ParserError ParserState++instance Functor (ParserM e s) where+  {-# INLINE fmap #-}+  fmap f (Parser k) =+    Parser $ \st kerr ksucc ->+      k st kerr (\st' a -> ksucc st' (f a))++instance Applicative (ParserM e s) where+  {-# INLINE pure #-}+  pure a = Parser $ \st _ k -> k st a+  {-# INLINE (<*>) #-}+  Parser k1 <*> Parser k2 =+    Parser $ \st kerr ksucc ->+      k1 st kerr $ \st' f ->+        k2 st' kerr $ \st'' a ->+          ksucc st'' (f a)++instance Monad (ParserM e s) where+  {-# INLINE return #-}+  return = pure+  {-# INLINE (>>=) #-}+  Parser k1 >>= k2 =+    Parser $ \st kerr ksucc ->+      k1 st kerr $ \st' a -> do+        let Parser k3 = k2 a+        k3 st' kerr ksucc++runParser :: ParserState -> Parser a -> (ParserState, Either (NE.NonEmpty ParserError) a)+runParser st (Parser k) = k st left right+  where+  left st'@(ParserState {..}) err =+    (st', Left $ NE.sortBy (comparing errRange) $ err NE.:| parserErrors)++  right st'@(ParserState {..}) res+    | null parserErrors = (st', Right res)+    | otherwise = (st', Left $ NE.fromList $ sortBy (comparing errRange) parserErrors)++runTokenParser :: Parser a -> [LexResult] -> Either (NE.NonEmpty ParserError) ([ParserWarning], a)+runTokenParser p buff = fmap (warnings,) res+  where+  (ParserState _ _ warnings, res) =+    runParser initialState p++  initialState = ParserState+    { parserBuff = buff+    , parserErrors = []+    , parserWarnings = []+    }++{-# INLINE throw #-}+throw :: e -> ParserM e s a+throw e = Parser $ \st kerr _ -> kerr st e++parseError :: SourceToken -> Parser a+parseError tok = Parser $ \st kerr _ ->+  kerr st $ ParserErrorInfo+    { errRange = tokRange . tokAnn $ tok+    , errToks = [tok]+    , errStack = [] -- TODO parserStack st+    , errType = ErrToken+    }++mkParserError :: LayoutStack -> [SourceToken] -> a -> ParserErrorInfo a+mkParserError stack toks ty =+  ParserErrorInfo+    { errRange =  range+    , errToks = toks+    , errStack = stack+    , errType = ty+    }+  where+  range = case toks of+    [] -> SourceRange (SourcePos 0 0) (SourcePos 0 0)+    _  -> widen (tokRange . tokAnn $ head toks) (tokRange . tokAnn $ last toks)++addFailure :: [SourceToken] -> ParserErrorType -> Parser ()+addFailure toks ty = Parser $ \st _ ksucc ->+  ksucc (st { parserErrors = mkParserError [] toks ty : parserErrors st }) ()++addFailures :: [ParserError] -> Parser ()+addFailures errs = Parser $ \st _ ksucc ->+  ksucc (st { parserErrors = errs <> parserErrors st }) ()++parseFail' :: [SourceToken] -> ParserErrorType -> Parser a+parseFail' toks msg = Parser $ \st kerr _ -> kerr st (mkParserError [] toks msg)++parseFail :: SourceToken -> ParserErrorType -> Parser a+parseFail = parseFail' . pure++addWarning :: [SourceToken] -> ParserWarningType -> Parser ()+addWarning toks ty = Parser $ \st _ ksucc ->+  ksucc (st { parserWarnings = mkParserError [] toks ty : parserWarnings st }) ()++pushBack :: SourceToken -> Parser ()+pushBack tok = Parser $ \st _ ksucc ->+  ksucc (st { parserBuff = Right tok : parserBuff st }) ()++{-# INLINE tryPrefix #-}+tryPrefix :: Parser a -> Parser b -> Parser (Maybe a, b)+tryPrefix (Parser lhs) rhs = Parser $ \st kerr ksucc ->+  lhs st+    (\_ _ -> do+      let Parser k = (Nothing,) <$> rhs+      k st kerr ksucc)+    (\st' res -> do+      let Parser k = (Just res,) <$> rhs+      k st' kerr ksucc)++oneOf :: NE.NonEmpty (Parser a) -> Parser a+oneOf parsers = Parser $ \st kerr ksucc -> do+  let+    prevErrs = parserErrors st+    go (st', Right a) _ = (st', Right a)+    go _ (st', Right a) = (st', Right a)+    go (st1, Left errs1) (st2, Left errs2)+      | errRange (NE.last errs2) > errRange (NE.last errs1) = (st2, Left errs2)+      | otherwise = (st1, Left errs1)+  case foldr1 go $ runParser (st { parserErrors = [] }) <$> parsers of+    (st', Left errs) -> kerr (st' { parserErrors = prevErrs <> NE.tail errs}) $ NE.head errs+    (st', Right res) -> ksucc (st' { parserErrors = prevErrs }) res++manyDelimited :: Token -> Token -> Token -> Parser a -> Parser [a]+manyDelimited open close sep p = do+  _   <- token open+  res <- go1+  _   <- token close+  pure $ res+  where+  go1 =+    oneOf $ NE.fromList+      [ go2 . pure =<< p+      , pure []+      ]++  go2 acc =+    oneOf $ NE.fromList+      [ token sep *> (go2 . (: acc) =<< p)+      , pure (reverse acc)+      ]++token :: Token -> Parser SourceToken+token t = do+  t' <- munch+  if t == tokValue t'+    then pure t'+    else parseError t'++munch :: Parser SourceToken+munch = Parser $ \state@(ParserState {..}) kerr ksucc ->+  case parserBuff of+    Right tok : parserBuff' ->+      ksucc (state { parserBuff = parserBuff' }) tok+    Left (_,  err) : _ ->+      kerr state err+    [] ->+      error "Empty input"
+ src/Language/PureScript/CST/Parser.y view
@@ -0,0 +1,814 @@+{+module Language.PureScript.CST.Parser+  ( parseType+  , parseExpr+  , parseDecl+  , parseIdent+  , parseOperator+  , parseModule+  , parseImportDeclP+  , parseDeclP+  , parseExprP+  , parseTypeP+  , parseModuleNameP+  , parseQualIdentP+  , parse+  , PartialResult(..)+  ) where++import Prelude hiding (lex)++import Control.Monad ((<=<), when)+import Data.Foldable (foldl', for_, toList)+import qualified Data.List.NonEmpty as NE+import Data.Text (Text)+import Data.Traversable (for, sequence)+import Language.PureScript.CST.Errors+import Language.PureScript.CST.Flatten (flattenType)+import Language.PureScript.CST.Lexer+import Language.PureScript.CST.Monad+import Language.PureScript.CST.Positions+import Language.PureScript.CST.Types+import Language.PureScript.CST.Utils+import qualified Language.PureScript.Names as N+import qualified Language.PureScript.Roles as R+import Language.PureScript.PSString (PSString)+}++%expect 93++%name parseType type+%name parseExpr expr+%name parseIdent ident+%name parseOperator op+%name parseModuleBody moduleBody+%name parseDecl decl+%partial parseImportDeclP importDeclP+%partial parseDeclP declP+%partial parseExprP exprP+%partial parseTypeP typeP+%partial parseModuleNameP moduleNameP+%partial parseQualIdentP qualIdentP+%partial parseModuleHeader moduleHeader+%partial parseDoStatement doStatement+%partial parseDoExpr doExpr+%partial parseDoNext doNext+%partial parseGuardExpr guardExpr+%partial parseGuardNext guardNext+%partial parseGuardStatement guardStatement+%partial parseClassSignature classSignature+%partial parseClassSuper classSuper+%partial parseClassNameAndFundeps classNameAndFundeps+%partial parseBinderAndArrow binderAndArrow+%tokentype { SourceToken }+%monad { Parser }+%error { parseError }+%lexer { lexer } { SourceToken _ TokEof }++%token+  '('                { SourceToken _ TokLeftParen }+  ')'                { SourceToken _ TokRightParen }+  '{'                { SourceToken _ TokLeftBrace }+  '}'                { SourceToken _ TokRightBrace }+  '['                { SourceToken _ TokLeftSquare }+  ']'                { SourceToken _ TokRightSquare }+  '\{'               { SourceToken _ TokLayoutStart }+  '\}'               { SourceToken _ TokLayoutEnd }+  '\;'               { SourceToken _ TokLayoutSep }+  '<-'               { SourceToken _ (TokLeftArrow _) }+  '->'               { SourceToken _ (TokRightArrow _) }+  '<='               { SourceToken _ (TokOperator [] sym) | isLeftFatArrow sym }+  '=>'               { SourceToken _ (TokRightFatArrow _) }+  ':'                { SourceToken _ (TokOperator [] ":") }+  '::'               { SourceToken _ (TokDoubleColon _) }+  '='                { SourceToken _ TokEquals }+  '|'                { SourceToken _ TokPipe }+  '`'                { SourceToken _ TokTick }+  '.'                { SourceToken _ TokDot }+  ','                { SourceToken _ TokComma }+  '_'                { SourceToken _ TokUnderscore }+  '\\'               { SourceToken _ TokBackslash }+  '-'                { SourceToken _ (TokOperator [] "-") }+  '@'                { SourceToken _ (TokOperator [] "@") }+  '#'                { SourceToken _ (TokOperator [] "#") }+  'ado'              { SourceToken _ (TokLowerName _ "ado") }+  'as'               { SourceToken _ (TokLowerName [] "as") }+  'case'             { SourceToken _ (TokLowerName [] "case") }+  'class'            { SourceToken _ (TokLowerName [] "class") }+  'data'             { SourceToken _ (TokLowerName [] "data") }+  'derive'           { SourceToken _ (TokLowerName [] "derive") }+  'do'               { SourceToken _ (TokLowerName _ "do") }+  'else'             { SourceToken _ (TokLowerName [] "else") }+  'false'            { SourceToken _ (TokLowerName [] "false") }+  'forall'           { SourceToken _ (TokForall ASCII) }+  'forallu'          { SourceToken _ (TokForall Unicode) }+  'foreign'          { SourceToken _ (TokLowerName [] "foreign") }+  'hiding'           { SourceToken _ (TokLowerName [] "hiding") }+  'import'           { SourceToken _ (TokLowerName [] "import") }+  'if'               { SourceToken _ (TokLowerName [] "if") }+  'in'               { SourceToken _ (TokLowerName [] "in") }+  'infix'            { SourceToken _ (TokLowerName [] "infix") }+  'infixl'           { SourceToken _ (TokLowerName [] "infixl") }+  'infixr'           { SourceToken _ (TokLowerName [] "infixr") }+  'instance'         { SourceToken _ (TokLowerName [] "instance") }+  'kind'             { SourceToken _ (TokLowerName [] "kind") }+  'let'              { SourceToken _ (TokLowerName [] "let") }+  'module'           { SourceToken _ (TokLowerName [] "module") }+  'newtype'          { SourceToken _ (TokLowerName [] "newtype") }+  'nominal'          { SourceToken _ (TokLowerName [] "nominal") }+  'phantom'          { SourceToken _ (TokLowerName [] "phantom") }+  'of'               { SourceToken _ (TokLowerName [] "of") }+  'representational' { SourceToken _ (TokLowerName [] "representational") }+  'role'             { SourceToken _ (TokLowerName [] "role") }+  'then'             { SourceToken _ (TokLowerName [] "then") }+  'true'             { SourceToken _ (TokLowerName [] "true") }+  'type'             { SourceToken _ (TokLowerName [] "type") }+  'where'            { SourceToken _ (TokLowerName [] "where") }+  '(->)'             { SourceToken _ (TokSymbolArr _) }+  '(..)'             { SourceToken _ (TokSymbolName [] "..") }+  LOWER              { SourceToken _ (TokLowerName [] _) }+  QUAL_LOWER         { SourceToken _ (TokLowerName _ _) }+  UPPER              { SourceToken _ (TokUpperName [] _) }+  QUAL_UPPER         { SourceToken _ (TokUpperName _ _) }+  SYMBOL             { SourceToken _ (TokSymbolName [] _) }+  QUAL_SYMBOL        { SourceToken _ (TokSymbolName _ _) }+  OPERATOR           { SourceToken _ (TokOperator [] _) }+  QUAL_OPERATOR      { SourceToken _ (TokOperator _ _) }+  LIT_HOLE           { SourceToken _ (TokHole _) }+  LIT_CHAR           { SourceToken _ (TokChar _ _) }+  LIT_STRING         { SourceToken _ (TokString _ _) }+  LIT_RAW_STRING     { SourceToken _ (TokRawString _) }+  LIT_INT            { SourceToken _ (TokInt _ _) }+  LIT_NUMBER         { SourceToken _ (TokNumber _ _) }++%%++many(a) :: { NE.NonEmpty a }+  : many1(a) { NE.reverse $1 }++many1(a) :: { NE.NonEmpty a }+  : a { pure $1 }+  | many1(a) a { NE.cons $2 $1 }++manySep(a, sep) :: { NE.NonEmpty a }+  : manySep1(a, sep) { NE.reverse $1 }++manySep1(a, sep) :: { NE.NonEmpty a }+  : a { pure $1 }+  | manySep1(a, sep) sep a { NE.cons $3 $1 }++manySepOrEmpty(a, sep) :: { [a] }+  : {- empty -} { [] }+  | manySep(a, sep) { NE.toList $1 }++manyOrEmpty(a) :: { [a] }+  : {- empty -} { [] }+  | many(a) { NE.toList $1 }++sep(a, s) :: { Separated a }+  : sep1(a, s) { separated $1 }++sep1(a, s) :: { [(SourceToken, a)] }+  : a { [(placeholder, $1)] }+  | sep1(a, s) s a { ($2, $3) : $1 }++delim(a, b, c, d) :: { Delimited b }+  : a d { Wrapped $1 Nothing $2 }+  | a sep(b, c) d { Wrapped $1 (Just $2) $3 }++moduleName :: { Name N.ModuleName }+  : UPPER {% upperToModuleName $1 }+  | QUAL_UPPER {% upperToModuleName $1 }++qualProperName :: { QualifiedProperName }+  : UPPER {% qualifiedProperName <\$> toQualifiedName N.ProperName $1 }+  | QUAL_UPPER {% qualifiedProperName <\$> toQualifiedName N.ProperName $1 }++properName :: { ProperName }+  : UPPER {% properName <\$> toName N.ProperName $1 }++qualIdent :: { QualifiedName Ident }+  : LOWER {% toQualifiedName Ident $1 }+  | QUAL_LOWER {% toQualifiedName Ident $1 }+  | 'as' {% toQualifiedName Ident $1 }+  | 'hiding' {% toQualifiedName Ident $1 }+  | 'kind' {% toQualifiedName Ident $1 }+  | 'role' {% toQualifiedName Ident $1 }+  | 'nominal' {% toQualifiedName Ident $1 }+  | 'representational' {% toQualifiedName Ident $1 }+  | 'phantom' {% toQualifiedName Ident $1 }++ident :: { Name Ident }+  : LOWER {% toName Ident $1 }+  | 'as' {% toName Ident $1 }+  | 'hiding' {% toName Ident $1 }+  | 'kind' {% toName Ident $1 }+  | 'role' {% toName Ident $1 }+  | 'nominal' {% toName Ident $1 }+  | 'representational' {% toName Ident $1 }+  | 'phantom' {% toName Ident $1 }++qualOp :: { QualifiedOpName }+  : OPERATOR {% qualifiedOpName <\$> toQualifiedName N.OpName $1 }+  | QUAL_OPERATOR {% qualifiedOpName <\$> toQualifiedName N.OpName $1 }+  | '<=' {% qualifiedOpName <\$> toQualifiedName N.OpName $1 }+  | '-' {% qualifiedOpName <\$> toQualifiedName N.OpName $1 }+  | '#' {% qualifiedOpName <\$> toQualifiedName N.OpName $1 }+  | ':' {% qualifiedOpName <\$> toQualifiedName N.OpName $1 }++op :: { OpName }+  : OPERATOR {% opName <\$> toName N.OpName $1 }+  | '<=' {% opName <\$> toName N.OpName $1 }+  | '-' {% opName <\$> toName N.OpName $1 }+  | '#' {% opName <\$> toName N.OpName $1 }+  | ':' {% opName <\$> toName N.OpName $1 }++qualSymbol :: { QualifiedOpName }+  : SYMBOL {% qualifiedOpName <\$> toQualifiedName N.OpName $1 }+  | QUAL_SYMBOL {% qualifiedOpName <\$> toQualifiedName N.OpName $1 }+  | '(..)' {% qualifiedOpName <\$> toQualifiedName N.OpName $1 }++symbol :: { OpName }+  : SYMBOL {% opName <\$> toName N.OpName $1 }+  | '(..)' {% opName <\$> toName N.OpName $1 }++label :: { Label }+  : LOWER { toLabel $1 }+  | LIT_STRING { toLabel $1 }+  | LIT_RAW_STRING { toLabel $1 }+  | 'ado' { toLabel $1 }+  | 'as' { toLabel $1 }+  | 'case' { toLabel $1 }+  | 'class' { toLabel $1 }+  | 'data' { toLabel $1 }+  | 'derive' { toLabel $1 }+  | 'do' { toLabel $1 }+  | 'else' { toLabel $1 }+  | 'false' { toLabel $1 }+  | 'forall' { toLabel $1 }+  | 'foreign' { toLabel $1 }+  | 'hiding' { toLabel $1 }+  | 'import' { toLabel $1 }+  | 'if' { toLabel $1 }+  | 'in' { toLabel $1 }+  | 'infix' { toLabel $1 }+  | 'infixl' { toLabel $1 }+  | 'infixr' { toLabel $1 }+  | 'instance' { toLabel $1 }+  | 'kind' { toLabel $1 }+  | 'let' { toLabel $1 }+  | 'module' { toLabel $1 }+  | 'newtype' { toLabel $1 }+  | 'nominal' { toLabel $1 }+  | 'of' { toLabel $1 }+  | 'phantom' { toLabel $1 }+  | 'representational' { toLabel $1 }+  | 'role' { toLabel $1 }+  | 'then' { toLabel $1 }+  | 'true' { toLabel $1 }+  | 'type' { toLabel $1 }+  | 'where' { toLabel $1 }++hole :: { Name Ident }+  : LIT_HOLE {% toName Ident $1 }++string :: { (SourceToken, PSString) }+  : LIT_STRING { toString $1 }+  | LIT_RAW_STRING { toString $1 }++char :: { (SourceToken, Char) }+  : LIT_CHAR { toChar $1 }++number :: { (SourceToken, Either Integer Double) }+  : LIT_INT { toNumber $1 }+  | LIT_NUMBER { toNumber $1 }++int :: { (SourceToken, Integer) }+  : LIT_INT { toInt $1 }++boolean :: { (SourceToken, Bool) }+  : 'true' { toBoolean $1 }+  | 'false' { toBoolean $1 }++type :: { Type () }+  : type1 { $1 }+  | type1 '::' type { TypeKinded () $1 $2 $3 }++type1 :: { Type () }+  : type2 { $1 }+  | forall many(typeVarBinding) '.' type1 { TypeForall () $1 $2 $3 $4 }++type2 :: { Type () }+  : type3 { $1 }+  | type3 '->' type1 { TypeArr () $1 $2 $3 }+  | type3 '=>' type1 {% do cs <- toConstraint $1; pure $ TypeConstrained () cs $2 $3 }++type3 :: { Type () }+  : type4 { $1 }+  | type3 qualOp type4 { TypeOp () $1 (getQualifiedOpName $2) $3 }++type4 :: { Type () }+  : type5 { $1 }+  | '#' type4 {% addWarning ($1 : toList (flattenType $2)) WarnDeprecatedRowSyntax *> pure (TypeUnaryRow () $1 $2) }++type5 :: { Type () }+  : typeAtom { $1 }+  | type5 typeAtom { TypeApp () $1 $2 }++typeAtom :: { Type ()}+  : '_' { TypeWildcard () $1 }+  | ident { TypeVar () $1 }+  | qualProperName { TypeConstructor () (getQualifiedProperName $1) }+  | qualSymbol { TypeOpName () (getQualifiedOpName $1) }+  | string { uncurry (TypeString ()) $1 }+  | hole { TypeHole () $1 }+  | '(->)' { TypeArrName () $1 }+  | '{' row '}' { TypeRecord () (Wrapped $1 $2 $3) }+  | '(' row ')' { TypeRow () (Wrapped $1 $2 $3) }+  | '(' type1 ')' { TypeParens () (Wrapped $1 $2 $3) }+  | '(' typeKindedAtom '::' type ')' { TypeParens () (Wrapped $1 (TypeKinded () $2 $3 $4) $5) }++-- Due to a conflict between row syntax and kinded type syntax, we require+-- kinded type variables to be wrapped in parens. Thus `(a :: Foo)` is always a+-- row, and to annotate `a` with kind `Foo`, one must use `((a) :: Foo)`.+typeKindedAtom :: { Type () }+  : '_' { TypeWildcard () $1 }+  | qualProperName { TypeConstructor () (getQualifiedProperName $1) }+  | qualSymbol { TypeOpName () (getQualifiedOpName $1) }+  | hole { TypeHole () $1 }+  | '{' row '}' { TypeRecord () (Wrapped $1 $2 $3) }+  | '(' row ')' { TypeRow () (Wrapped $1 $2 $3) }+  | '(' type1 ')' { TypeParens () (Wrapped $1 $2 $3) }+  | '(' typeKindedAtom '::' type ')' { TypeParens () (Wrapped $1 (TypeKinded () $2 $3 $4) $5) }++row :: { Row () }+  : {- empty -} { Row Nothing Nothing }+  | '|' type { Row Nothing (Just ($1, $2)) }+  | sep(rowLabel, ',') { Row (Just $1) Nothing }+  | sep(rowLabel, ',') '|' type { Row (Just $1) (Just ($2, $3)) }++rowLabel :: { Labeled Label (Type ()) }+  : label '::' type { Labeled $1 $2 $3 }++typeVarBinding :: { TypeVarBinding () }+  : ident { TypeVarName $1 }+  | '(' ident '::' type ')' {% checkNoWildcards $4 *> pure (TypeVarKinded (Wrapped $1 (Labeled $2 $3 $4) $5)) }++forall :: { SourceToken }+  : 'forall' { $1 }+  | 'forallu' { $1 }++exprWhere :: { Where () }+  : expr { Where $1 Nothing }+  | expr 'where' '\{' manySep(letBinding, '\;') '\}' { Where $1 (Just ($2, $4)) }++expr :: { Expr () }+  : expr1 { $1 }+  | expr1 '::' type { ExprTyped () $1 $2 $3 }++expr1 :: { Expr () }+  : expr2 { $1 }+  | expr1 qualOp expr2 { ExprOp () $1 (getQualifiedOpName $2) $3 }++expr2 :: { Expr () }+  : expr3 { $1 }+  | expr2 '`' exprBacktick '`' expr3 { ExprInfix () $1 (Wrapped $2 $3 $4) $5 }++exprBacktick :: { Expr () }+  : expr3 { $1 }+  | exprBacktick qualOp expr3 { ExprOp () $1 (getQualifiedOpName $2) $3 }++expr3 :: { Expr () }+  : expr4 { $1 }+  | '-' expr3 { ExprNegate () $1 $2 }++expr4 :: { Expr () }+  : expr5 { $1 }+  | expr4 expr5+      { -- Record application/updates can introduce a function application+        -- associated to the right, so we need to correct it.+        case $2 of+          ExprApp _ lhs rhs ->+            ExprApp () (ExprApp () $1 lhs) rhs+          _ -> ExprApp () $1 $2+      }++expr5 :: { Expr () }+  : expr6 { $1 }+  | 'if' expr 'then' expr 'else' expr { ExprIf () (IfThenElse $1 $2 $3 $4 $5 $6) }+  | doBlock { ExprDo () $1 }+  | adoBlock 'in' expr { ExprAdo () $ uncurry AdoBlock $1 $2 $3 }+  | '\\' many(binderAtom) '->' expr { ExprLambda () (Lambda $1 $2 $3 $4) }+  | 'let' '\{' manySep(letBinding, '\;') '\}' 'in' expr { ExprLet () (LetIn $1 $3 $5 $6) }+  | 'case' sep(expr, ',') 'of' '\{' manySep(caseBranch, '\;') '\}' { ExprCase () (CaseOf $1 $2 $3 $5) }+  -- These special cases handle some idiosynchratic syntax that the current+  -- parser allows. Technically the parser allows the rhs of a case branch to be+  -- at any level, but this is ambiguous. We allow it in the case of a singleton+  -- case, since this is used in the wild.+  | 'case' sep(expr, ',') 'of' '\{' sep(binder1, ',') '->' '\}' exprWhere+      { ExprCase () (CaseOf $1 $2 $3 (pure ($5, Unconditional $6 $8))) }+  | 'case' sep(expr, ',') 'of' '\{' sep(binder1, ',') '\}' guardedCase+      { ExprCase () (CaseOf $1 $2 $3 (pure ($5, $7))) }++expr6 :: { Expr () }+  : expr7 { $1 }+  | expr7 '{' '}' { ExprApp () $1 (ExprRecord () (Wrapped $2 Nothing $3)) }+  | expr7 '{' sep(recordUpdateOrLabel, ',') '}'+      {% toRecordFields $3 >>= \case+          Left xs -> pure $ ExprApp () $1 (ExprRecord () (Wrapped $2 (Just xs) $4))+          Right xs -> pure $ ExprRecordUpdate () $1 (Wrapped $2 xs $4)+      }++expr7 :: { Expr () }+  : exprAtom { $1 }+  | exprAtom '.' sep(label, '.') { ExprRecordAccessor () (RecordAccessor $1 $2 $3) }++exprAtom :: { Expr () }+  : '_' { ExprSection () $1 }+  | hole { ExprHole () $1 }+  | qualIdent { ExprIdent () $1 }+  | qualProperName { ExprConstructor () (getQualifiedProperName $1) }+  | qualSymbol { ExprOpName () (getQualifiedOpName $1) }+  | boolean { uncurry (ExprBoolean ()) $1 }+  | char { uncurry (ExprChar ()) $1 }+  | string { uncurry (ExprString ()) $1 }+  | number { uncurry (ExprNumber ()) $1 }+  | delim('[', expr, ',', ']') { ExprArray () $1 }+  | delim('{', recordLabel, ',', '}') { ExprRecord () $1 }+  | '(' expr ')' { ExprParens () (Wrapped $1 $2 $3) }++recordLabel :: { RecordLabeled (Expr ()) }+  : label {% fmap RecordPun . toName Ident $ lblTok $1 }+  | label '=' expr {% addFailure [$2] ErrRecordUpdateInCtr *> pure (RecordPun $ unexpectedName $ lblTok $1) }+  | label ':' expr { RecordField $1 $2 $3 }++recordUpdateOrLabel :: { Either (RecordLabeled (Expr ())) (RecordUpdate ()) }+  : label ':' expr { Left (RecordField $1 $2 $3) }+  | label {% fmap (Left . RecordPun) . toName Ident $ lblTok $1 }+  | label '=' expr { Right (RecordUpdateLeaf $1 $2 $3) }+  | label '{' sep(recordUpdate, ',') '}' { Right (RecordUpdateBranch $1 (Wrapped $2 $3 $4)) }++recordUpdate :: { RecordUpdate () }+  : label '=' expr { RecordUpdateLeaf $1 $2 $3 }+  | label '{' sep(recordUpdate, ',') '}' { RecordUpdateBranch $1 (Wrapped $2 $3 $4) }++letBinding :: { LetBinding () }+  : ident '::' type { LetBindingSignature () (Labeled $1 $2 $3) }+  | ident guardedDecl { LetBindingName () (ValueBindingFields $1 [] $2) }+  | ident many(binderAtom) guardedDecl { LetBindingName () (ValueBindingFields $1 (NE.toList $2) $3) }+  | binder1 '=' exprWhere { LetBindingPattern () $1 $2 $3 }++caseBranch :: { (Separated (Binder ()), Guarded ()) }+  : sep(binder1, ',') guardedCase { ($1, $2) }++guardedDecl :: { Guarded () }+  : '=' exprWhere { Unconditional $1 $2 }+  | many(guardedDeclExpr) { Guarded $1 }++guardedDeclExpr :: { GuardedExpr () }+  : guard '=' exprWhere { uncurry GuardedExpr $1 $2 $3 }++guardedCase :: { Guarded () }+  : '->' exprWhere { Unconditional $1 $2 }+  | many(guardedCaseExpr) { Guarded $1 }++guardedCaseExpr :: { GuardedExpr () }+  : guard '->' exprWhere { uncurry GuardedExpr $1 $2 $3 }++-- Do/Ado statements and pattern guards require unbounded lookahead due to many+-- conflicts between `binder` and `expr` syntax. For example `Foo a b c` can+-- either be a constructor `binder` or several `expr` applications, and we won't+-- know until we see a `<-` or layout separator.+--+-- One way to resolve this would be to parse a `binder` as an `expr` and then+-- reassociate it after the fact. However this means we can't use the `binder`+-- productions to parse it, so we'd have to maintain an ad-hoc handwritten+-- parser which is very difficult to audit.+--+-- As an alternative we introduce some backtracking. Using %partial parsers and+-- monadic reductions, we can invoke productions manually and use the+-- backtracking `tryPrefix` combinator. Binders are generally very short in+-- comparison to expressions, so the cost is modest.+--+--     doBlock+--       : 'do' '\{' manySep(doStatement, '\;') '\}'+--+--     doStatement+--       : 'let' '\{' manySep(letBinding, '\;') '\}'+--       | expr+--       | binder '<-' expr+--+--     guard+--       : '|' sep(patternGuard, ',')+--+--     patternGuard+--       : expr1+--       | binder '<-' expr1+--+doBlock :: { DoBlock () }+  : 'do' '\{'+      {%% revert $ do+        res <- parseDoStatement+        when (null res) $ addFailure [$2] ErrEmptyDo+        pure $ DoBlock $1 $ NE.fromList res+      }++adoBlock :: { (SourceToken, [DoStatement ()]) }+  : 'ado' '\{' '\}' { ($1, []) }+  | 'ado' '\{'+      {%% revert $ fmap ($1,) parseDoStatement }++doStatement :: { [DoStatement ()] }+  : 'let' '\{' manySep(letBinding, '\;') '\}'+      {%^ revert $ fmap (DoLet $1 $3 :) parseDoNext }+  | {- empty -}+      {%^ revert $ do+        stmt <- tryPrefix parseBinderAndArrow parseDoExpr+        let+          ctr = case stmt of+            (Just (binder, sep), expr) ->+              (DoBind binder sep expr :)+            (Nothing, expr) ->+              (DoDiscard expr :)+        fmap ctr parseDoNext+      }++doExpr :: { Expr () }+  : expr {%^ revert $ pure $1 }++doNext :: { [DoStatement ()] }+  : '\;' {%^ revert parseDoStatement }+  | '\}' {%^ revert $ pure [] }++guard :: { (SourceToken, Separated (PatternGuard ())) }+  : '|' {%% revert $ fmap (($1,) . uncurry Separated) parseGuardStatement }++guardStatement :: { (PatternGuard (), [(SourceToken, PatternGuard ())]) }+  : {- empty -}+      {%^ revert $ do+        grd <- fmap (uncurry PatternGuard) $ tryPrefix parseBinderAndArrow parseGuardExpr+        fmap (grd,) parseGuardNext+      }++guardExpr :: { Expr() }+  : expr1 {%^ revert $ pure $1 }++guardNext :: { [(SourceToken, PatternGuard ())] }+  : ',' {%^ revert $ fmap (\(g, gs) -> ($1, g) : gs) parseGuardStatement }+  | {- empty -} {%^ revert $ pure [] }++binderAndArrow :: { (Binder (), SourceToken) }+  : binder '<-' {%^ revert $ pure ($1, $2) }++binder :: { Binder () }+  : binder1 { $1 }+  | binder1 '::' type { BinderTyped () $1 $2 $3 }++binder1 :: { Binder () }+  : binder2 { $1 }+  | binder1 qualOp binder2 { BinderOp () $1 (getQualifiedOpName $2) $3 }++binder2 :: { Binder () }+  : many(binderAtom) {% toBinderConstructor $1 }+  | '-' number { uncurry (BinderNumber () (Just $1)) $2 }++binderAtom :: { Binder () }+  : '_' { BinderWildcard () $1 }+  | ident { BinderVar () $1 }+  | ident '@' binderAtom { BinderNamed () $1 $2 $3 }+  | qualProperName { BinderConstructor () (getQualifiedProperName $1) [] }+  | boolean { uncurry (BinderBoolean ()) $1 }+  | char { uncurry (BinderChar ()) $1 }+  | string { uncurry (BinderString ()) $1 }+  | number { uncurry (BinderNumber () Nothing) $1 }+  | delim('[', binder, ',', ']') { BinderArray () $1 }+  | delim('{', recordBinder, ',', '}') { BinderRecord () $1 }+  | '(' binder ')' { BinderParens () (Wrapped $1 $2 $3) }++recordBinder :: { RecordLabeled (Binder ()) }+  : label {% fmap RecordPun . toName Ident $ lblTok $1 }+  | label '=' binder {% addFailure [$2] ErrRecordUpdateInCtr *> pure (RecordPun $ unexpectedName $ lblTok $1) }+  | label ':' binder { RecordField $1 $2 $3 }++-- By splitting up the module header from the body, we can incrementally parse+-- just the header, and then continue parsing the body while still sharing work.+moduleHeader :: { Module () }+  : 'module' moduleName exports 'where' '\{' moduleImports+      { (Module () $1 $2 $3 $4 $6 [] []) }++moduleBody :: { ([Declaration ()], [Comment LineFeed]) }+  : moduleDecls '\}'+      {%^ \(SourceToken ann _) -> pure (snd $1, tokLeadingComments ann) }++moduleImports :: { [ImportDecl ()] }+  : importDecls importDecl '\}'+      {%^ revert $ pushBack $3 *> pure (reverse ($2 : $1)) }+  | importDecls+      {%^ revert $ pure (reverse $1) }++importDecls :: { [ImportDecl ()] }+  : importDecls importDecl '\;' { $2 : $1 }+  | {- empty -} { [] }++moduleDecls :: { ([ImportDecl ()], [Declaration ()]) }+  : manySep(moduleDecl, '\;') {% toModuleDecls $ NE.toList $1 }+  | {- empty -} { ([], []) }++moduleDecl :: { TmpModuleDecl () }+  : importDecl { TmpImport $1 }+  | sep(decl, declElse) { TmpChain $1 }++declElse :: { SourceToken }+  : 'else' { $1 }+  | 'else' '\;' { $1 }++exports :: { Maybe (DelimitedNonEmpty (Export ())) }+  : {- empty -} { Nothing }+  | '(' sep(export, ',') ')' { Just (Wrapped $1 $2 $3) }++export :: { Export () }+  : ident { ExportValue () $1 }+  | symbol { ExportOp () (getOpName $1) }+  | properName { ExportType () (getProperName $1) Nothing }+  | properName dataMembers { ExportType () (getProperName $1) (Just $2) }+  | 'type' symbol { ExportTypeOp () $1 (getOpName $2) }+  | 'class' properName { ExportClass () $1 (getProperName $2) }+  | 'kind' properName {% addWarning [$1, nameTok (getProperName $2)] WarnDeprecatedKindExportSyntax *> pure (ExportKind () $1 (getProperName $2)) }+  | 'module' moduleName { ExportModule () $1 $2 }++dataMembers :: { (DataMembers ()) }+ : '(..)' { DataAll () $1 }+ | '(' ')' { DataEnumerated () (Wrapped $1 Nothing $2) }+ | '(' sep(properName, ',') ')' { DataEnumerated () (Wrapped $1 (Just \$ getProperName <\$> $2) $3) }++importDecl :: { ImportDecl () }+  : 'import' moduleName imports { ImportDecl () $1 $2 $3 Nothing }+  | 'import' moduleName imports 'as' moduleName { ImportDecl () $1 $2 $3 (Just ($4, $5)) }++imports :: { Maybe (Maybe SourceToken, DelimitedNonEmpty (Import ())) }+  : {- empty -} { Nothing }+  | '(' sep(import, ',') ')' { Just (Nothing, Wrapped $1 $2 $3) }+  | 'hiding' '(' sep(import, ',') ')' { Just (Just $1, Wrapped $2 $3 $4) }++import :: { Import () }+  : ident { ImportValue () $1 }+  | symbol { ImportOp () (getOpName $1) }+  | properName { ImportType () (getProperName $1) Nothing }+  | properName dataMembers { ImportType () (getProperName $1) (Just $2) }+  | 'type' symbol { ImportTypeOp () $1 (getOpName $2) }+  | 'class' properName { ImportClass () $1 (getProperName $2) }+  | 'kind' properName {% addWarning [$1, nameTok (getProperName $2)] WarnDeprecatedKindImportSyntax *> pure (ImportKind () $1 (getProperName $2)) }++decl :: { Declaration () }+  : dataHead { DeclData () $1 Nothing }+  | dataHead '=' sep(dataCtor, '|') { DeclData () $1 (Just ($2, $3)) }+  | typeHead '=' type {% checkNoWildcards $3 *> pure (DeclType () $1 $2 $3) }+  | newtypeHead '=' properName typeAtom {% checkNoWildcards $4 *> pure (DeclNewtype () $1 $2 (getProperName $3) $4) }+  | classHead { either id (\h -> DeclClass () h Nothing) $1 }+  | classHead 'where' '\{' manySep(classMember, '\;') '\}' {% either (const (parseError $2)) (\h -> pure $ DeclClass () h (Just ($2, $4))) $1 }+  | instHead { DeclInstanceChain () (Separated (Instance $1 Nothing) []) }+  | instHead 'where' '\{' manySep(instBinding, '\;') '\}' { DeclInstanceChain () (Separated (Instance $1 (Just ($2, $4))) []) }+  | 'data' properName '::' type {% checkNoWildcards $4 *> pure (DeclKindSignature () $1 (Labeled (getProperName $2) $3 $4)) }+  | 'newtype' properName '::' type {% checkNoWildcards $4 *> pure (DeclKindSignature () $1 (Labeled (getProperName $2) $3 $4)) }+  | 'type' properName '::' type {% checkNoWildcards $4 *> pure (DeclKindSignature () $1 (Labeled (getProperName $2) $3 $4)) }+  | 'derive' instHead { DeclDerive () $1 Nothing $2 }+  | 'derive' 'newtype' instHead { DeclDerive () $1 (Just $2) $3 }+  | ident '::' type { DeclSignature () (Labeled $1 $2 $3) }+  | ident manyOrEmpty(binderAtom) guardedDecl { DeclValue () (ValueBindingFields $1 $2 $3) }+  | fixity { DeclFixity () $1 }+  | 'foreign' 'import' ident '::' type {% when (isConstrained $5) (addWarning ([$1, $2, nameTok $3, $4] <> toList (flattenType $5)) WarnDeprecatedConstraintInForeignImportSyntax) *> pure (DeclForeign () $1 $2 (ForeignValue (Labeled $3 $4 $5))) }+  | 'foreign' 'import' 'data' properName '::' type { DeclForeign () $1 $2 (ForeignData $3 (Labeled (getProperName $4) $5 $6)) }+  | 'foreign' 'import' 'kind' properName {% addWarning [$1, $2, $3, nameTok (getProperName $4)] WarnDeprecatedForeignKindSyntax *> pure (DeclForeign () $1 $2 (ForeignKind $3 (getProperName $4))) }+  | 'type' 'role' properName many(role) { DeclRole () $1 $2 (getProperName $3) $4 }++dataHead :: { DataHead () }+  : 'data' properName manyOrEmpty(typeVarBinding) { DataHead $1 (getProperName $2) $3 }++typeHead :: { DataHead () }+  : 'type' properName manyOrEmpty(typeVarBinding) { DataHead $1 (getProperName $2) $3 }++newtypeHead :: { DataHead () }+  : 'newtype' properName manyOrEmpty(typeVarBinding) { DataHead $1 (getProperName $2) $3 }++dataCtor :: { DataCtor () }+  : properName manyOrEmpty(typeAtom)+      {% for_ $2 checkNoWildcards *> pure (DataCtor () (getProperName $1) $2) }++-- Class head syntax requires unbounded lookahead due to a conflict between+-- row syntax and `typeVarBinding`. `(a :: B)` is either a row in `constraint`+-- where `B` is a type or a `typeVarBinding` where `B` is a kind. We must see+-- either a `<=`, `where`, or layout delimiter before deciding which it is.+--+--     classHead+--       : 'class' classNameAndFundeps+--       | 'class' constraints '<=' classNameAndFundeps+--+classHead :: { Either (Declaration ()) (ClassHead ()) }+  : 'class'+      {%% revert $ oneOf $ NE.fromList+          [ fmap (Left . DeclKindSignature () $1) parseClassSignature+          , do+              (super, (name, vars, fundeps)) <- tryPrefix parseClassSuper parseClassNameAndFundeps+              let hd = ClassHead $1 super name vars fundeps+              checkFundeps hd+              pure $ Right hd+          ]+      }++classSignature :: { Labeled (Name (N.ProperName 'N.TypeName)) (Type ()) }+  : properName '::' type {%^ revert $ checkNoWildcards $3 *> pure (Labeled (getProperName $1) $2 $3) }++classSuper :: { (OneOrDelimited (Constraint ()), SourceToken) }+  : constraints '<=' {%^ revert $ pure ($1, $2) }++classNameAndFundeps :: { (Name (N.ProperName 'N.ClassName), [TypeVarBinding ()], Maybe (SourceToken, Separated ClassFundep)) }+  : properName manyOrEmpty(typeVarBinding) fundeps {%^ revert $ pure (getProperName $1, $2, $3) }++fundeps :: { Maybe (SourceToken, Separated ClassFundep) }+  : {- empty -} { Nothing }+  | '|' sep(fundep, ',') { Just ($1, $2) }++fundep :: { ClassFundep }+  : '->' many(ident) { FundepDetermined $1 $2 }+  | many(ident) '->' many(ident) { FundepDetermines $1 $2 $3 }++classMember :: { Labeled (Name Ident) (Type ()) }+  : ident '::' type {% checkNoWildcards $3 *> pure (Labeled $1 $2 $3) }++instHead :: { InstanceHead () }+  : 'instance' ident '::' constraints '=>' qualProperName manyOrEmpty(typeAtom)+      { InstanceHead $1 $2 $3 (Just ($4, $5)) (getQualifiedProperName $6) $7 }+  | 'instance' ident '::' qualProperName manyOrEmpty(typeAtom)+      { InstanceHead $1 $2 $3 Nothing (getQualifiedProperName $4) $5 }++constraints :: { OneOrDelimited (Constraint ()) }+  : constraint { One $1 }+  | '(' sep(constraint, ',') ')' { Many (Wrapped $1 $2 $3) }++constraint :: { Constraint () }+  : qualProperName manyOrEmpty(typeAtom) {% for_ $2 checkNoWildcards *> for_ $2 checkNoForalls *> pure (Constraint () (getQualifiedProperName $1) $2) }+  | '(' constraint ')' { ConstraintParens () (Wrapped $1 $2 $3) }++instBinding :: { InstanceBinding () }+  : ident '::' type { InstanceBindingSignature () (Labeled $1 $2 $3) }+  | ident manyOrEmpty(binderAtom) guardedDecl { InstanceBindingName () (ValueBindingFields $1 $2 $3) }++fixity :: { FixityFields }+  : infix int qualIdent 'as' op { FixityFields $1 $2 (FixityValue (fmap Left $3) $4 (getOpName $5)) }+  | infix int qualProperName 'as' op { FixityFields $1 $2 (FixityValue (fmap Right (getQualifiedProperName $3)) $4 (getOpName $5)) }+  | infix int 'type' qualProperName 'as' op { FixityFields $1 $2 (FixityType $3 (getQualifiedProperName $4) $5 (getOpName $6)) }++infix :: { (SourceToken, Fixity) }+  : 'infix' { ($1, Infix) }+  | 'infixl' { ($1, Infixl) }+  | 'infixr' { ($1, Infixr) }++role :: { Role }+  : 'nominal' { Role $1 R.Nominal }+  | 'representational' { Role $1 R.Representational }+  | 'phantom' { Role $1 R.Phantom }++-- Partial parsers which can be combined with combinators for adhoc use. We need+-- to revert the lookahead token so that it doesn't consume an extra token+-- before succeeding.++importDeclP :: { ImportDecl () }+  : importDecl {%^ revert $ pure $1 }++declP :: { Declaration () }+  : decl {%^ revert $ pure $1 }++exprP :: { Expr () }+  : expr {%^ revert $ pure $1 }++typeP :: { Type () }+  : type {%^ revert $ pure $1 }++moduleNameP :: { Name N.ModuleName }+  : moduleName {%^ revert $ pure $1 }++qualIdentP :: { QualifiedName Ident }+  : qualIdent {%^ revert $ pure $1 }++{+lexer :: (SourceToken -> Parser a) -> Parser a+lexer k = munch >>= k++parse :: Text -> ([ParserWarning], Either (NE.NonEmpty ParserError) (Module ()))+parse = either (([],) . Left) resFull . parseModule . lex++data PartialResult a = PartialResult+  { resPartial :: a+  , resFull :: ([ParserWarning], Either (NE.NonEmpty ParserError) a)+  } deriving (Functor)++parseModule :: [LexResult] -> Either (NE.NonEmpty ParserError) (PartialResult (Module ()))+parseModule toks = fmap (\header -> PartialResult header (parseFull header)) headerRes+  where+  (st, headerRes) =+    runParser (ParserState toks [] []) parseModuleHeader++  parseFull header = do+    let (ParserState _ _ warnings, res) = runParser st parseModuleBody+    (warnings, (\(decls, trailing) -> header { modDecls = decls, modTrailingComments = trailing }) <$> res)+}
+ src/Language/PureScript/CST/Positions.hs view
@@ -0,0 +1,345 @@+-- | This module contains utilities for calculating positions and offsets. While+-- tokens are annotated with ranges, CST nodes are not, but they can be+-- dynamically derived with the functions in this module, which will return the+-- first and last tokens for a given node.++module Language.PureScript.CST.Positions where++import Prelude++import Data.Foldable (foldl')+import qualified Data.List.NonEmpty as NE+import Data.Text (Text)+import Data.Void (Void)+import qualified Data.Text as Text+import Language.PureScript.CST.Types++advanceToken :: SourcePos -> Token -> SourcePos+advanceToken pos = applyDelta pos . tokenDelta++advanceLeading :: SourcePos -> [Comment LineFeed] -> SourcePos+advanceLeading pos = foldl' (\a -> applyDelta a . commentDelta lineDelta) pos++advanceTrailing :: SourcePos -> [Comment Void] -> SourcePos+advanceTrailing pos = foldl' (\a -> applyDelta a . commentDelta (const (0, 0))) pos++tokenDelta :: Token -> (Int, Int)+tokenDelta = \case+  TokLeftParen             -> (0, 1)+  TokRightParen            -> (0, 1)+  TokLeftBrace             -> (0, 1)+  TokRightBrace            -> (0, 1)+  TokLeftSquare            -> (0, 1)+  TokRightSquare           -> (0, 1)+  TokLeftArrow ASCII       -> (0, 2)+  TokLeftArrow Unicode     -> (0, 1)+  TokRightArrow ASCII      -> (0, 2)+  TokRightArrow Unicode    -> (0, 1)+  TokRightFatArrow ASCII   -> (0, 2)+  TokRightFatArrow Unicode -> (0, 1)+  TokDoubleColon ASCII     -> (0, 2)+  TokDoubleColon Unicode   -> (0, 1)+  TokForall ASCII          -> (0, 6)+  TokForall Unicode        -> (0, 1)+  TokEquals                -> (0, 1)+  TokPipe                  -> (0, 1)+  TokTick                  -> (0, 1)+  TokDot                   -> (0, 1)+  TokComma                 -> (0, 1)+  TokUnderscore            -> (0, 1)+  TokBackslash             -> (0, 1)+  TokLowerName qual name   -> (0, qualDelta qual + Text.length name)+  TokUpperName qual name   -> (0, qualDelta qual + Text.length name)+  TokOperator qual sym     -> (0, qualDelta qual + Text.length sym)+  TokSymbolName qual sym   -> (0, qualDelta qual + Text.length sym + 2)+  TokSymbolArr Unicode     -> (0, 3)+  TokSymbolArr ASCII       -> (0, 4)+  TokHole hole             -> (0, Text.length hole + 1)+  TokChar raw _            -> (0, Text.length raw + 2)+  TokInt raw _             -> (0, Text.length raw)+  TokNumber raw _          -> (0, Text.length raw)+  TokString raw _          -> multiLine 1 $ textDelta raw+  TokRawString raw         -> multiLine 3 $ textDelta raw+  TokLayoutStart           -> (0, 0)+  TokLayoutSep             -> (0, 0)+  TokLayoutEnd             -> (0, 0)+  TokEof                   -> (0, 0)++qualDelta :: [Text] -> Int+qualDelta = foldr ((+) . (+ 1) . Text.length) 0++multiLine :: Int -> (Int, Int) -> (Int, Int)+multiLine n (0, c) = (0, c + n + n)+multiLine n (l, c) = (l, c + n)++commentDelta :: (a -> (Int, Int)) -> Comment a -> (Int, Int)+commentDelta k = \case+  Comment raw -> textDelta raw+  Space n -> (0, n)+  Line a -> k a++lineDelta :: LineFeed -> (Int, Int)+lineDelta _ = (1, 1)++textDelta :: Text -> (Int, Int)+textDelta = Text.foldl' go (0, 0)+  where+  go (!l, !c) = \case+    '\n' -> (l + 1, 1)+    _    -> (l, c + 1)++applyDelta :: SourcePos -> (Int, Int) -> SourcePos+applyDelta (SourcePos l c) = \case+  (0, n) -> SourcePos l (c + n)+  (k, d) -> SourcePos (l + k) d++sepLast :: Separated a -> a+sepLast (Separated hd []) = hd+sepLast (Separated _ tl) = snd $ last tl++type TokenRange = (SourceToken, SourceToken)++toSourceRange :: TokenRange -> SourceRange+toSourceRange (a, b) = widen (srcRange a) (srcRange b)++widen :: SourceRange -> SourceRange -> SourceRange+widen (SourceRange s1 _) (SourceRange _ e2) = SourceRange s1 e2++srcRange :: SourceToken -> SourceRange+srcRange = tokRange . tokAnn++nameRange :: Name a -> TokenRange+nameRange a = (nameTok a, nameTok a)++qualRange :: QualifiedName a -> TokenRange+qualRange a = (qualTok a, qualTok a)++labelRange :: Label -> TokenRange+labelRange a = (lblTok a, lblTok a)++wrappedRange :: Wrapped a -> TokenRange+wrappedRange (Wrapped { wrpOpen, wrpClose }) = (wrpOpen, wrpClose)++moduleRange :: Module a -> TokenRange+moduleRange (Module { modKeyword, modWhere, modImports, modDecls }) =+  case (modImports, modDecls) of+    ([], []) -> (modKeyword, modWhere)+    (is, []) -> (modKeyword, snd . importDeclRange $ last is)+    (_,  ds) -> (modKeyword, snd . declRange $ last ds)++exportRange :: Export a -> TokenRange+exportRange = \case+  ExportValue _ a -> nameRange a+  ExportOp _ a -> nameRange a+  ExportType _ a b+    | Just b' <- b -> (nameTok a, snd $ dataMembersRange b')+    | otherwise -> nameRange a+  ExportTypeOp _ a b -> (a, nameTok b)+  ExportClass _ a b -> (a, nameTok b)+  ExportKind _ a b -> (a, nameTok b)+  ExportModule _ a b -> (a, nameTok b)++importDeclRange :: ImportDecl a -> TokenRange+importDeclRange (ImportDecl { impKeyword, impModule, impNames, impQual })+  | Just (_, modName) <- impQual = (impKeyword, nameTok modName)+  | Just (_, imports) <- impNames = (impKeyword, wrpClose imports)+  | otherwise = (impKeyword, nameTok impModule)++importRange :: Import a -> TokenRange+importRange = \case+  ImportValue _ a -> nameRange a+  ImportOp _ a -> nameRange a+  ImportType _ a b+    | Just b' <- b -> (nameTok a, snd $ dataMembersRange b')+    | otherwise -> nameRange a+  ImportTypeOp _ a b -> (a, nameTok b)+  ImportClass _ a b -> (a, nameTok b)+  ImportKind _ a b -> (a, nameTok b)++dataMembersRange :: DataMembers a -> TokenRange+dataMembersRange = \case+  DataAll _ a -> (a, a)+  DataEnumerated _ (Wrapped a _ b) -> (a, b)++declRange :: Declaration a -> TokenRange+declRange = \case+  DeclData _ hd ctors+    | Just (_, cs) <- ctors -> (fst start, snd . dataCtorRange $ sepLast cs)+    | otherwise -> start+    where start = dataHeadRange hd+  DeclType _ a _ b -> (fst $ dataHeadRange a,  snd $ typeRange b)+  DeclNewtype _ a _ _ b -> (fst $ dataHeadRange a, snd $ typeRange b)+  DeclClass _ hd body+    | Just (_, ts) <- body -> (fst start, snd . typeRange . lblValue $ NE.last ts)+    | otherwise -> start+    where start = classHeadRange hd+  DeclInstanceChain _ a -> (fst . instanceRange $ sepHead a, snd . instanceRange $ sepLast a)+  DeclDerive _ a _ b -> (a, snd $ instanceHeadRange b)+  DeclKindSignature _ a (Labeled _ _ b) -> (a, snd $ typeRange b)+  DeclSignature _ (Labeled a _ b) -> (nameTok a, snd $ typeRange b)+  DeclValue _ a -> valueBindingFieldsRange a+  DeclFixity _ (FixityFields a _ (FixityValue _ _ b)) -> (fst a, nameTok b)+  DeclFixity _ (FixityFields a _ (FixityType _ _ _ b)) -> (fst a, nameTok b)+  DeclForeign _ a _ b -> (a, snd $ foreignRange b)+  DeclRole _ a _ _ b -> (a, roleTok $ NE.last b)++dataHeadRange :: DataHead a -> TokenRange+dataHeadRange (DataHead kw name vars)+  | [] <- vars = (kw, nameTok name)+  | otherwise = (kw, snd . typeVarBindingRange $ last vars)++dataCtorRange :: DataCtor a -> TokenRange+dataCtorRange (DataCtor _ name fields)+  | [] <- fields = nameRange name+  | otherwise = (nameTok name, snd . typeRange $ last fields)++classHeadRange :: ClassHead a -> TokenRange+classHeadRange (ClassHead kw _ name vars fdeps)+  | Just (_, fs) <- fdeps = (kw, snd .classFundepRange $ sepLast fs)+  | [] <- vars = (kw, snd $ nameRange name)+  | otherwise = (kw, snd . typeVarBindingRange $ last vars)++classFundepRange :: ClassFundep -> TokenRange+classFundepRange = \case+  FundepDetermined arr bs -> (arr, nameTok $ NE.last bs)+  FundepDetermines as _ bs -> (nameTok $ NE.head as, nameTok $ NE.last bs)++instanceRange :: Instance a -> TokenRange+instanceRange (Instance hd bd)+  | Just (_, ts) <- bd = (fst start, snd . instanceBindingRange $ NE.last ts)+  | otherwise = start+  where start = instanceHeadRange hd++instanceHeadRange :: InstanceHead a -> TokenRange+instanceHeadRange (InstanceHead kw _ _ _ cls types)+  | [] <- types = (kw, qualTok cls)+  | otherwise = (kw, snd . typeRange $ last types)++instanceBindingRange :: InstanceBinding a -> TokenRange+instanceBindingRange = \case+  InstanceBindingSignature _ (Labeled a _ b) -> (nameTok a, snd $ typeRange b)+  InstanceBindingName _ a -> valueBindingFieldsRange a++foreignRange :: Foreign a -> TokenRange+foreignRange = \case+  ForeignValue (Labeled a _ b) -> (nameTok a, snd $ typeRange b)+  ForeignData a (Labeled _ _ b) -> (a, snd $ typeRange b)+  ForeignKind a b -> (a, nameTok b)++valueBindingFieldsRange :: ValueBindingFields a -> TokenRange+valueBindingFieldsRange (ValueBindingFields a _ b) = (nameTok a, snd $ guardedRange b)++guardedRange :: Guarded a -> TokenRange+guardedRange = \case+  Unconditional a b -> (a, snd $ whereRange b)+  Guarded as -> (fst . guardedExprRange $ NE.head as, snd . guardedExprRange $ NE.last as)++guardedExprRange :: GuardedExpr a -> TokenRange+guardedExprRange (GuardedExpr a _ _ b) = (a, snd $ whereRange b)++whereRange :: Where a -> TokenRange+whereRange (Where a bs)+  | Just (_, ls) <- bs = (fst $ exprRange a, snd . letBindingRange $ NE.last ls)+  | otherwise = exprRange a++typeRange :: Type a -> TokenRange+typeRange = \case+  TypeVar _ a -> nameRange a+  TypeConstructor _ a -> qualRange a+  TypeWildcard _ a -> (a, a)+  TypeHole _ a -> nameRange a+  TypeString _ a _ -> (a, a)+  TypeRow _ a -> wrappedRange a+  TypeRecord _ a -> wrappedRange a+  TypeForall _ a _ _ b -> (a, snd $ typeRange b)+  TypeKinded _ a _ b -> (fst $ typeRange a, snd $ typeRange b)+  TypeApp _ a b -> (fst $ typeRange a, snd $ typeRange b)+  TypeOp _ a _ b -> (fst $ typeRange a, snd $ typeRange b)+  TypeOpName _ a -> qualRange a+  TypeArr _ a _ b -> (fst $ typeRange a, snd $ typeRange b)+  TypeArrName _ a -> (a, a)+  TypeConstrained _ a _ b -> (fst $ constraintRange a, snd $ typeRange b)+  TypeParens _ a -> wrappedRange a+  TypeUnaryRow _ a b -> (a, snd $ typeRange b)++constraintRange :: Constraint a -> TokenRange+constraintRange = \case+  Constraint _ name args+    | [] <- args -> qualRange name+    | otherwise -> (qualTok name, snd . typeRange $ last args)+  ConstraintParens _ wrp -> wrappedRange wrp++typeVarBindingRange :: TypeVarBinding a -> TokenRange+typeVarBindingRange = \case+  TypeVarKinded a -> wrappedRange a+  TypeVarName a -> nameRange a++exprRange :: Expr a -> TokenRange+exprRange = \case+  ExprHole _ a -> nameRange a+  ExprSection _ a -> (a, a)+  ExprIdent _ a -> qualRange a+  ExprConstructor _ a -> qualRange a+  ExprBoolean _ a _ -> (a, a)+  ExprChar _ a _ -> (a, a)+  ExprString _ a _ -> (a, a)+  ExprNumber _ a _ -> (a, a)+  ExprArray _ a -> wrappedRange a+  ExprRecord _ a -> wrappedRange a+  ExprParens _ a -> wrappedRange a+  ExprTyped _ a _ b -> (fst $ exprRange a, snd $ typeRange b)+  ExprInfix _ a _ b -> (fst $ exprRange a, snd $ exprRange b)+  ExprOp _ a _ b -> (fst $ exprRange a, snd $ exprRange b)+  ExprOpName _ a -> qualRange a+  ExprNegate _ a b -> (a, snd $ exprRange b)+  ExprRecordAccessor _ (RecordAccessor a _ b) -> (fst $ exprRange a, lblTok $ sepLast b)+  ExprRecordUpdate _ a b -> (fst $ exprRange a, snd $ wrappedRange b)+  ExprApp _ a b -> (fst $ exprRange a, snd $ exprRange b)+  ExprLambda _ (Lambda a _ _ b) -> (a, snd $ exprRange b)+  ExprIf _ (IfThenElse a _ _ _ _ b) -> (a, snd $ exprRange b)+  ExprCase _ (CaseOf a _ _ c) -> (a, snd . guardedRange . snd $ NE.last c)+  ExprLet _ (LetIn a _ _ b) -> (a, snd $ exprRange b)+  ExprDo _ (DoBlock a b) -> (a,  snd . doStatementRange $ NE.last b)+  ExprAdo _ (AdoBlock a _ _ b) -> (a, snd $ exprRange b)++letBindingRange :: LetBinding a -> TokenRange+letBindingRange = \case+  LetBindingSignature _ (Labeled a _ b) -> (nameTok a, snd $ typeRange b)+  LetBindingName _ a -> valueBindingFieldsRange a+  LetBindingPattern _ a _ b -> (fst $ binderRange a, snd $ whereRange b)++doStatementRange :: DoStatement a -> TokenRange+doStatementRange = \case+  DoLet a bs -> (a, snd . letBindingRange $ NE.last bs)+  DoDiscard a -> exprRange a+  DoBind a _ b -> (fst $ binderRange a, snd $ exprRange b)++binderRange :: Binder a -> TokenRange+binderRange = \case+  BinderWildcard _ a -> (a, a)+  BinderVar _ a -> nameRange a+  BinderNamed _ a _ b -> (nameTok a, snd $ binderRange b)+  BinderConstructor _ a bs+    | [] <- bs -> qualRange a+    | otherwise -> (qualTok a, snd . binderRange $ last bs)+  BinderBoolean _ a _ -> (a, a)+  BinderChar _ a _ -> (a, a)+  BinderString _ a _ -> (a, a)+  BinderNumber _ a b _+    | Just a' <- a -> (a', b)+    | otherwise -> (b, b)+  BinderArray _ a -> wrappedRange a+  BinderRecord _ a -> wrappedRange a+  BinderParens _ a -> wrappedRange a+  BinderTyped _ a _ b -> (fst $ binderRange a, snd $ typeRange b)+  BinderOp _ a _ b -> (fst $ binderRange a, snd $ binderRange b)++recordUpdateRange :: RecordUpdate a -> TokenRange+recordUpdateRange = \case+  RecordUpdateLeaf a _ b -> (lblTok a, snd $ exprRange b)+  RecordUpdateBranch a (Wrapped _ _ b) -> (lblTok a, b)++recordLabeledExprRange :: RecordLabeled (Expr a) -> TokenRange+recordLabeledExprRange = \case+  RecordPun a -> nameRange a+  RecordField a _ b -> (fst $ labelRange a, snd $ exprRange b)
+ src/Language/PureScript/CST/Print.hs view
@@ -0,0 +1,96 @@+-- | This is just a simple token printer. It's not a full fledged formatter, but+-- it is used by the layout golden tests. Printing each token in the tree with+-- this printer will result in the exact input that was given to the lexer.++module Language.PureScript.CST.Print+  ( printToken+  , printTokens+  , printModule+  , printLeadingComment+  , printTrailingComment+  ) where++import Prelude++import qualified Data.DList as DList+import Data.Text (Text)+import qualified Data.Text as Text+import Language.PureScript.CST.Types+import Language.PureScript.CST.Flatten (flattenModule)++printToken :: Token -> Text+printToken = printToken' True++-- | Prints a given Token. The bool controls whether or not layout+-- tokens should be printed.+printToken' :: Bool -> Token -> Text+printToken' showLayout = \case+  TokLeftParen             -> "("+  TokRightParen            -> ")"+  TokLeftBrace             -> "{"+  TokRightBrace            -> "}"+  TokLeftSquare            -> "["+  TokRightSquare           -> "]"+  TokLeftArrow ASCII       -> "<-"+  TokLeftArrow Unicode     -> "←"+  TokRightArrow ASCII      -> "->"+  TokRightArrow Unicode    -> "→"+  TokRightFatArrow ASCII   -> "=>"+  TokRightFatArrow Unicode -> "⇒"+  TokDoubleColon ASCII     -> "::"+  TokDoubleColon Unicode   -> "∷"+  TokForall ASCII          -> "forall"+  TokForall Unicode        -> "∀"+  TokEquals                -> "="+  TokPipe                  -> "|"+  TokTick                  -> "`"+  TokDot                   -> "."+  TokComma                 -> ","+  TokUnderscore            -> "_"+  TokBackslash             -> "\\"+  TokLowerName qual name   -> printQual qual <> name+  TokUpperName qual name   -> printQual qual <> name+  TokOperator qual sym     -> printQual qual <> sym+  TokSymbolName qual sym   -> printQual qual <> "(" <> sym <> ")"+  TokSymbolArr Unicode     -> "(→)"+  TokSymbolArr ASCII       -> "(->)"+  TokHole hole             -> "?" <> hole+  TokChar raw _            -> "'" <> raw <> "'"+  TokString raw _          -> "\"" <> raw <> "\""+  TokRawString raw         -> "\"\"\"" <> raw <> "\"\"\""+  TokInt raw _             -> raw+  TokNumber raw _          -> raw+  TokLayoutStart           -> if showLayout then "{" else ""+  TokLayoutSep             -> if showLayout then ";" else ""+  TokLayoutEnd             -> if showLayout then "}" else ""+  TokEof                   -> if showLayout then "<eof>" else ""++printQual :: [Text] -> Text+printQual = Text.concat . map (<> ".")++printTokens :: [SourceToken] -> Text+printTokens = printTokens' True++printTokens' :: Bool -> [SourceToken] -> Text+printTokens' showLayout toks = Text.concat (map pp toks)+  where+  pp (SourceToken (TokenAnn _ leading trailing) tok) =+    Text.concat (map printLeadingComment leading)+      <> printToken' showLayout tok+      <> Text.concat (map printTrailingComment trailing)++printModule :: Module a -> Text+printModule = printTokens' False . DList.toList . flattenModule++printLeadingComment :: Comment LineFeed -> Text+printLeadingComment = \case+  Comment raw -> raw+  Space n -> Text.replicate n " "+  Line LF -> "\n"+  Line CRLF -> "\r\n"++printTrailingComment :: Comment void -> Text+printTrailingComment = \case+  Comment raw -> raw+  Space n -> Text.replicate n " "+  Line _ -> ""
+ src/Language/PureScript/CST/Traversals.hs view
@@ -0,0 +1,11 @@+module Language.PureScript.CST.Traversals where++import Prelude++import Language.PureScript.CST.Types++everythingOnSeparated :: (r -> r -> r) -> (a -> r) -> Separated a -> r+everythingOnSeparated op k (Separated hd tl) = go hd tl+  where+  go a [] = k a+  go a (b : bs) = k a `op` go (snd b) bs
+ src/Language/PureScript/CST/Traversals/Type.hs view
@@ -0,0 +1,40 @@+module Language.PureScript.CST.Traversals.Type where++import Prelude++import Language.PureScript.CST.Types+import Language.PureScript.CST.Traversals++everythingOnTypes :: (r -> r -> r) -> (Type a -> r) -> Type a -> r+everythingOnTypes op k = goTy+  where+  goTy ty = case ty of+    TypeVar _ _ -> k ty+    TypeConstructor _ _ -> k ty+    TypeWildcard _ _ -> k ty+    TypeHole _ _ -> k ty+    TypeString _ _ _ -> k ty+    TypeRow _ (Wrapped _ row _) -> goRow ty row+    TypeRecord _ (Wrapped _ row _) -> goRow ty row+    TypeForall _ _ _ _ ty2 -> k ty `op` goTy ty2+    TypeKinded _ ty2 _ ty3 -> k ty `op` (goTy ty2 `op` goTy ty3)+    TypeApp _ ty2 ty3 -> k ty `op` (goTy ty2 `op` goTy ty3)+    TypeOp _ ty2 _ ty3 -> k ty `op` (goTy ty2 `op` goTy ty3)+    TypeOpName _ _ -> k ty+    TypeArr _ ty2 _ ty3 -> k ty `op` (goTy ty2 `op` goTy ty3)+    TypeArrName _ _ -> k ty+    TypeConstrained _ (constraintTys -> ty2) _ ty3+      | null ty2 -> k ty `op` goTy ty3+      | otherwise -> k ty `op` (foldr1 op (k <$> ty2) `op` goTy ty3)+    TypeParens _ (Wrapped _ ty2 _) -> k ty `op` goTy ty2+    TypeUnaryRow _ _ ty2 -> k ty `op` goTy ty2++  goRow ty = \case+    Row Nothing Nothing -> k ty+    Row Nothing (Just (_, ty2)) -> k ty `op` goTy ty2+    Row (Just lbls) Nothing -> k ty `op` everythingOnSeparated op (goTy . lblValue) lbls+    Row (Just lbls) (Just (_, ty2)) -> k ty `op` (everythingOnSeparated op (goTy . lblValue) lbls `op` goTy ty2)++  constraintTys = \case+    Constraint _ _ tys -> tys+    ConstraintParens _ (Wrapped _ c _) -> constraintTys c
+ src/Language/PureScript/CST/Types.hs view
@@ -0,0 +1,439 @@+-- | This module contains data types for the entire PureScript surface language. Every+-- token is represented in the tree, and every token is annotated with+-- whitespace and comments (both leading and trailing). This means one can write+-- an exact printer so that `print . parse = id`. Every constructor is laid out+-- with tokens in left-to-right order. The core productions are given a slot for+-- arbitrary annotations, however this is not used by the parser.++module Language.PureScript.CST.Types where++import Prelude++import Data.List.NonEmpty (NonEmpty)+import Data.Text (Text)+import Data.Void (Void)+import GHC.Generics (Generic)+import qualified Language.PureScript.Names as N+import qualified Language.PureScript.Roles as R+import Language.PureScript.PSString (PSString)++data SourcePos = SourcePos+  { srcLine :: {-# UNPACK #-} !Int+  , srcColumn :: {-# UNPACK #-} !Int+  } deriving (Show, Eq, Ord, Generic)++data SourceRange = SourceRange+  { srcStart :: !SourcePos+  , srcEnd :: !SourcePos+  } deriving (Show, Eq, Ord, Generic)++data Comment l+  = Comment !Text+  | Space {-# UNPACK #-} !Int+  | Line !l+  deriving (Show, Eq, Ord, Generic, Functor)++data LineFeed = LF | CRLF+  deriving (Show, Eq, Ord, Generic)++data TokenAnn = TokenAnn+  { tokRange :: !SourceRange+  , tokLeadingComments :: ![Comment LineFeed]+  , tokTrailingComments :: ![Comment Void]+  } deriving (Show, Eq, Ord, Generic)++data SourceStyle = ASCII | Unicode+  deriving (Show, Eq, Ord, Generic)++data Token+  = TokLeftParen+  | TokRightParen+  | TokLeftBrace+  | TokRightBrace+  | TokLeftSquare+  | TokRightSquare+  | TokLeftArrow !SourceStyle+  | TokRightArrow !SourceStyle+  | TokRightFatArrow !SourceStyle+  | TokDoubleColon !SourceStyle+  | TokForall !SourceStyle+  | TokEquals+  | TokPipe+  | TokTick+  | TokDot+  | TokComma+  | TokUnderscore+  | TokBackslash+  | TokLowerName ![Text] !Text+  | TokUpperName ![Text] !Text+  | TokOperator ![Text] !Text+  | TokSymbolName ![Text] !Text+  | TokSymbolArr !SourceStyle+  | TokHole !Text+  | TokChar !Text !Char+  | TokString !Text !PSString+  | TokRawString !Text+  | TokInt !Text !Integer+  | TokNumber !Text !Double+  | TokLayoutStart+  | TokLayoutSep+  | TokLayoutEnd+  | TokEof+  deriving (Show, Eq, Ord, Generic)++data SourceToken = SourceToken+  { tokAnn :: !TokenAnn+  , tokValue :: !Token+  } deriving (Show, Eq, Ord, Generic)++data Ident = Ident+  { getIdent :: Text+  } deriving (Show, Eq, Ord, Generic)++data Name a = Name+  { nameTok :: SourceToken+  , nameValue :: a+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data QualifiedName a = QualifiedName+  { qualTok :: SourceToken+  , qualModule :: Maybe N.ModuleName+  , qualName :: a+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data Label = Label+  { lblTok :: SourceToken+  , lblName :: PSString+  } deriving (Show, Eq, Ord, Generic)++data Wrapped a = Wrapped+  { wrpOpen :: SourceToken+  , wrpValue :: a+  , wrpClose :: SourceToken+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data Separated a = Separated+  { sepHead :: a+  , sepTail :: [(SourceToken, a)]+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data Labeled a b = Labeled+  { lblLabel :: a+  , lblSep :: SourceToken+  , lblValue  :: b+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++type Delimited a = Wrapped (Maybe (Separated a))+type DelimitedNonEmpty a = Wrapped (Separated a)++data OneOrDelimited a+  = One a+  | Many (DelimitedNonEmpty a)+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data Type a+  = TypeVar a (Name Ident)+  | TypeConstructor a (QualifiedName (N.ProperName 'N.TypeName))+  | TypeWildcard a SourceToken+  | TypeHole a (Name Ident)+  | TypeString a SourceToken PSString+  | TypeRow a (Wrapped (Row a))+  | TypeRecord a (Wrapped (Row a))+  | TypeForall a SourceToken (NonEmpty (TypeVarBinding a)) SourceToken (Type a)+  | TypeKinded a (Type a) SourceToken (Type a)+  | TypeApp a (Type a) (Type a)+  | TypeOp a (Type a) (QualifiedName (N.OpName 'N.TypeOpName)) (Type a)+  | TypeOpName a (QualifiedName (N.OpName 'N.TypeOpName))+  | TypeArr a (Type a) SourceToken (Type a)+  | TypeArrName a SourceToken+  | TypeConstrained a (Constraint a) SourceToken (Type a)+  | TypeParens a (Wrapped (Type a))+  | TypeUnaryRow a SourceToken (Type a)+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data TypeVarBinding a+  = TypeVarKinded (Wrapped (Labeled (Name Ident) (Type a)))+  | TypeVarName (Name Ident)+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data Constraint a+  = Constraint a (QualifiedName (N.ProperName 'N.ClassName)) [Type a]+  | ConstraintParens a (Wrapped (Constraint a))+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data Row a = Row+  { rowLabels :: Maybe (Separated (Labeled Label (Type a)))+  , rowTail :: Maybe (SourceToken, Type a)+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data Module a = Module+  { modAnn :: a+  , modKeyword :: SourceToken+  , modNamespace :: Name N.ModuleName+  , modExports :: Maybe (DelimitedNonEmpty (Export a))+  , modWhere :: SourceToken+  , modImports :: [ImportDecl a]+  , modDecls :: [Declaration a]+  , modTrailingComments :: [Comment LineFeed]+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data Export a+  = ExportValue a (Name Ident)+  | ExportOp a (Name (N.OpName 'N.ValueOpName))+  | ExportType a (Name (N.ProperName 'N.TypeName)) (Maybe (DataMembers a))+  | ExportTypeOp a SourceToken (Name (N.OpName 'N.TypeOpName))+  | ExportClass a SourceToken (Name (N.ProperName 'N.ClassName))+  | ExportKind a SourceToken (Name (N.ProperName 'N.TypeName))+  | ExportModule a SourceToken (Name N.ModuleName)+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data DataMembers a+  = DataAll a SourceToken+  | DataEnumerated a (Delimited (Name (N.ProperName 'N.ConstructorName)))+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data Declaration a+  = DeclData a (DataHead a) (Maybe (SourceToken, Separated (DataCtor a)))+  | DeclType a (DataHead a) SourceToken (Type a)+  | DeclNewtype a (DataHead a) SourceToken (Name (N.ProperName 'N.ConstructorName)) (Type a)+  | DeclClass a (ClassHead a) (Maybe (SourceToken, NonEmpty (Labeled (Name Ident) (Type a))))+  | DeclInstanceChain a (Separated (Instance a))+  | DeclDerive a SourceToken (Maybe SourceToken) (InstanceHead a)+  | DeclKindSignature a SourceToken (Labeled (Name (N.ProperName 'N.TypeName)) (Type a))+  | DeclSignature a (Labeled (Name Ident) (Type a))+  | DeclValue a (ValueBindingFields a)+  | DeclFixity a FixityFields+  | DeclForeign a SourceToken SourceToken (Foreign a)+  | DeclRole a SourceToken SourceToken (Name (N.ProperName 'N.TypeName)) (NonEmpty Role)+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data Instance a = Instance+  { instHead :: InstanceHead a+  , instBody :: Maybe (SourceToken, NonEmpty (InstanceBinding a))+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data InstanceBinding a+  = InstanceBindingSignature a (Labeled (Name Ident) (Type a))+  | InstanceBindingName a (ValueBindingFields a)+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data ImportDecl a = ImportDecl+  { impAnn :: a+  , impKeyword :: SourceToken+  , impModule :: Name N.ModuleName+  , impNames :: Maybe (Maybe SourceToken, DelimitedNonEmpty (Import a))+  , impQual :: Maybe (SourceToken, Name N.ModuleName)+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data Import a+  = ImportValue a (Name Ident)+  | ImportOp a (Name (N.OpName 'N.ValueOpName))+  | ImportType a (Name (N.ProperName 'N.TypeName)) (Maybe (DataMembers a))+  | ImportTypeOp a SourceToken (Name (N.OpName 'N.TypeOpName))+  | ImportClass a SourceToken (Name (N.ProperName 'N.ClassName))+  | ImportKind a SourceToken (Name (N.ProperName 'N.TypeName))+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data DataHead a = DataHead+  { dataHdKeyword :: SourceToken+  , dataHdName :: Name (N.ProperName 'N.TypeName)+  , dataHdVars :: [TypeVarBinding a]+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data DataCtor a = DataCtor+  { dataCtorAnn :: a+  , dataCtorName :: Name (N.ProperName 'N.ConstructorName)+  , dataCtorFields :: [Type a]+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data ClassHead a = ClassHead+  { clsKeyword :: SourceToken+  , clsSuper :: Maybe (OneOrDelimited (Constraint a), SourceToken)+  , clsName :: Name (N.ProperName 'N.ClassName)+  , clsVars :: [TypeVarBinding a]+  , clsFundeps :: Maybe (SourceToken, Separated ClassFundep)+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data ClassFundep+  = FundepDetermined SourceToken (NonEmpty (Name Ident))+  | FundepDetermines (NonEmpty (Name Ident)) SourceToken (NonEmpty (Name Ident))+  deriving (Show, Eq, Ord, Generic)++data InstanceHead a = InstanceHead+  { instKeyword :: SourceToken+  , instName :: Name Ident+  , instSep :: SourceToken+  , instConstraints :: Maybe (OneOrDelimited (Constraint a), SourceToken)+  , instClass :: QualifiedName (N.ProperName 'N.ClassName)+  , instTypes :: [Type a]+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data Fixity+  = Infix+  | Infixl+  | Infixr+  deriving (Show, Eq, Ord, Generic)++data FixityOp+  = FixityValue (QualifiedName (Either Ident (N.ProperName 'N.ConstructorName))) SourceToken (Name (N.OpName 'N.ValueOpName))+  | FixityType SourceToken (QualifiedName (N.ProperName 'N.TypeName)) SourceToken (Name (N.OpName 'N.TypeOpName))+  deriving (Show, Eq, Ord, Generic)++data FixityFields = FixityFields+  { fxtKeyword :: (SourceToken, Fixity)+  , fxtPrec :: (SourceToken, Integer)+  , fxtOp :: FixityOp+  } deriving (Show, Eq, Ord, Generic)++data ValueBindingFields a = ValueBindingFields+  { valName :: Name Ident+  , valBinders :: [Binder a]+  , valGuarded :: Guarded a+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data Guarded a+  = Unconditional SourceToken (Where a)+  | Guarded (NonEmpty (GuardedExpr a))+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data GuardedExpr a = GuardedExpr+  { grdBar :: SourceToken+  , grdPatterns :: Separated (PatternGuard a)+  , grdSep :: SourceToken+  , grdWhere :: Where a+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data PatternGuard a = PatternGuard+  { patBinder :: Maybe (Binder a, SourceToken)+  , patExpr :: Expr a+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data Foreign a+  = ForeignValue (Labeled (Name Ident) (Type a))+  | ForeignData SourceToken (Labeled (Name (N.ProperName 'N.TypeName)) (Type a))+  | ForeignKind SourceToken (Name (N.ProperName 'N.TypeName))+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data Role = Role+  { roleTok :: SourceToken+  , roleValue :: R.Role+  } deriving (Show, Eq, Ord, Generic)++data Expr a+  = ExprHole a (Name Ident)+  | ExprSection a SourceToken+  | ExprIdent a (QualifiedName Ident)+  | ExprConstructor a (QualifiedName (N.ProperName 'N.ConstructorName))+  | ExprBoolean a SourceToken Bool+  | ExprChar a SourceToken Char+  | ExprString a SourceToken PSString+  | ExprNumber a SourceToken (Either Integer Double)+  | ExprArray a (Delimited (Expr a))+  | ExprRecord a (Delimited (RecordLabeled (Expr a)))+  | ExprParens a (Wrapped (Expr a))+  | ExprTyped a (Expr a) SourceToken (Type a)+  | ExprInfix a (Expr a) (Wrapped (Expr a)) (Expr a)+  | ExprOp a (Expr a) (QualifiedName (N.OpName 'N.ValueOpName)) (Expr a)+  | ExprOpName a (QualifiedName (N.OpName 'N.ValueOpName))+  | ExprNegate a SourceToken (Expr a)+  | ExprRecordAccessor a (RecordAccessor a)+  | ExprRecordUpdate a (Expr a) (DelimitedNonEmpty (RecordUpdate a))+  | ExprApp a (Expr a) (Expr a)+  | ExprLambda a (Lambda a)+  | ExprIf a (IfThenElse a)+  | ExprCase a (CaseOf a)+  | ExprLet a (LetIn a)+  | ExprDo a (DoBlock a)+  | ExprAdo a (AdoBlock a)+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data RecordLabeled a+  = RecordPun (Name Ident)+  | RecordField Label SourceToken a+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data RecordUpdate a+  = RecordUpdateLeaf Label SourceToken (Expr a)+  | RecordUpdateBranch Label (DelimitedNonEmpty (RecordUpdate a))+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data RecordAccessor a = RecordAccessor+  { recExpr :: Expr a+  , recDot :: SourceToken+  , recPath :: Separated Label+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data Lambda a = Lambda+  { lmbSymbol :: SourceToken+  , lmbBinders :: NonEmpty (Binder a)+  , lmbArr :: SourceToken+  , lmbBody :: Expr a+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data IfThenElse a = IfThenElse+  { iteIf :: SourceToken+  , iteCond :: Expr a+  , iteThen :: SourceToken+  , iteTrue :: Expr a+  , iteElse :: SourceToken+  , iteFalse :: Expr a+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data CaseOf a = CaseOf+  { caseKeyword :: SourceToken+  , caseHead :: Separated (Expr a)+  , caseOf :: SourceToken+  , caseBranches :: NonEmpty (Separated (Binder a), Guarded a)+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data LetIn a = LetIn+  { letKeyword :: SourceToken+  , letBindings :: NonEmpty (LetBinding a)+  , letIn :: SourceToken+  , letBody :: Expr a+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data Where a = Where+  { whereExpr :: Expr a+  , whereBindings :: Maybe (SourceToken, NonEmpty (LetBinding a))+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data LetBinding a+  = LetBindingSignature a (Labeled (Name Ident) (Type a))+  | LetBindingName a (ValueBindingFields a)+  | LetBindingPattern a (Binder a) SourceToken (Where a)+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data DoBlock a = DoBlock+  { doKeyword :: SourceToken+  , doStatements :: NonEmpty (DoStatement a)+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data DoStatement a+  = DoLet SourceToken (NonEmpty (LetBinding a))+  | DoDiscard (Expr a)+  | DoBind (Binder a) SourceToken (Expr a)+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data AdoBlock a = AdoBlock+  { adoKeyword :: SourceToken+  , adoStatements :: [DoStatement a]+  , adoIn :: SourceToken+  , adoResult :: Expr a+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)++data Binder a+  = BinderWildcard a SourceToken+  | BinderVar a (Name Ident)+  | BinderNamed a (Name Ident) SourceToken (Binder a)+  | BinderConstructor a (QualifiedName (N.ProperName 'N.ConstructorName)) [Binder a]+  | BinderBoolean a SourceToken Bool+  | BinderChar a SourceToken Char+  | BinderString a SourceToken PSString+  | BinderNumber a (Maybe SourceToken) SourceToken (Either Integer Double)+  | BinderArray a (Delimited (Binder a))+  | BinderRecord a (Delimited (RecordLabeled (Binder a)))+  | BinderParens a (Wrapped (Binder a))+  | BinderTyped a (Binder a) SourceToken (Type a)+  | BinderOp a (Binder a) (QualifiedName (N.OpName 'N.ValueOpName)) (Binder a)+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+ src/Language/PureScript/CST/Utils.hs view
@@ -0,0 +1,367 @@+module Language.PureScript.CST.Utils where++import Prelude++import Control.Monad (when)+import Data.Coerce (coerce)+import Data.Foldable (for_)+import Data.Functor (($>))+import qualified Data.List.NonEmpty as NE+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as Text+import Language.PureScript.CST.Errors+import Language.PureScript.CST.Monad+import Language.PureScript.CST.Positions+import Language.PureScript.CST.Traversals.Type+import Language.PureScript.CST.Types+import qualified Language.PureScript.Names as N+import Language.PureScript.PSString (PSString, mkString)++-- |+-- A newtype for a qualified proper name whose ProperNameType has not yet been determined.+-- This is a workaround for Happy's limited support for polymorphism; it is used+-- inside the parser to allow us to write just one parser for qualified proper names+-- which can be used for all of the different ProperNameTypes+-- (via a call to getQualifiedProperName).+newtype QualifiedProperName =+  QualifiedProperName { getQualifiedProperName :: forall a. QualifiedName (N.ProperName a) }++qualifiedProperName :: QualifiedName (N.ProperName a) -> QualifiedProperName+qualifiedProperName n = QualifiedProperName (N.coerceProperName <$> n)++-- |+-- A newtype for a proper name whose ProperNameType has not yet been determined.+-- This is a workaround for Happy's limited support for polymorphism; it is used+-- inside the parser to allow us to write just one parser for proper names+-- which can be used for all of the different ProperNameTypes+-- (via a call to getProperName).+newtype ProperName =+  ProperName { getProperName :: forall a. Name (N.ProperName a) }++properName :: Name (N.ProperName a) -> ProperName+properName n = ProperName (N.coerceProperName <$> n)++-- |+-- A newtype for a qualified operator name whose OpNameType has not yet been determined.+-- This is a workaround for Happy's limited support for polymorphism; it is used+-- inside the parser to allow us to write just one parser for qualified operator names+-- which can be used for all of the different OpNameTypes+-- (via a call to getQualifiedOpName).+newtype QualifiedOpName =+  QualifiedOpName { getQualifiedOpName :: forall a. QualifiedName (N.OpName a) }++qualifiedOpName :: QualifiedName (N.OpName a) -> QualifiedOpName+qualifiedOpName n = QualifiedOpName (N.coerceOpName <$> n)++-- |+-- A newtype for a operator name whose OpNameType has not yet been determined.+-- This is a workaround for Happy's limited support for polymorphism; it is used+-- inside the parser to allow us to write just one parser for operator names+-- which can be used for all of the different OpNameTypes+-- (via a call to getOpName).+newtype OpName =+  OpName { getOpName :: forall a. Name (N.OpName a) }++opName :: Name (N.OpName a) -> OpName+opName n = OpName (N.coerceOpName <$> n)++placeholder :: SourceToken+placeholder = SourceToken+  { tokAnn = TokenAnn (SourceRange (SourcePos 0 0) (SourcePos 0 0)) [] []+  , tokValue = TokLowerName [] "<placeholder>"+  }++unexpectedName :: SourceToken -> Name Ident+unexpectedName tok = Name tok (Ident "<unexpected>")++unexpectedQual :: SourceToken -> QualifiedName Ident+unexpectedQual tok = QualifiedName tok Nothing (Ident "<unexpected>")++unexpectedLabel :: SourceToken -> Label+unexpectedLabel tok = Label tok "<unexpected>"++unexpectedExpr :: Monoid a => [SourceToken] -> Expr a+unexpectedExpr toks = ExprIdent mempty (unexpectedQual (head toks))++unexpectedDecl :: Monoid a => [SourceToken] -> Declaration a+unexpectedDecl toks = DeclValue mempty (ValueBindingFields (unexpectedName (head toks)) [] (error "<unexpected"))++unexpectedBinder :: Monoid a => [SourceToken] -> Binder a+unexpectedBinder toks = BinderVar mempty (unexpectedName (head toks))++unexpectedLetBinding :: Monoid a => [SourceToken] -> LetBinding a+unexpectedLetBinding toks = LetBindingName mempty (ValueBindingFields (unexpectedName (head toks)) [] (error "<unexpected>"))++unexpectedInstBinding :: Monoid a => [SourceToken] -> InstanceBinding a+unexpectedInstBinding toks = InstanceBindingName mempty (ValueBindingFields (unexpectedName (head toks)) [] (error "<unexpected>"))++unexpectedRecordUpdate :: Monoid a => [SourceToken] -> RecordUpdate a+unexpectedRecordUpdate toks = RecordUpdateLeaf (unexpectedLabel (head toks)) (head toks) (unexpectedExpr toks)++unexpectedRecordLabeled :: [SourceToken] -> RecordLabeled a+unexpectedRecordLabeled toks = RecordPun (unexpectedName (head toks))++rangeToks :: TokenRange -> [SourceToken]+rangeToks (a, b) = [a, b]++unexpectedToks :: (a -> TokenRange) -> ([SourceToken] -> b) -> ParserErrorType -> (a -> Parser b)+unexpectedToks toRange toCst err old = do+  let toks = rangeToks $ toRange old+  addFailure toks err+  pure $ toCst toks++separated :: [(SourceToken, a)] -> Separated a+separated = go []+  where+  go accum ((_, a) : []) = Separated a accum+  go accum (x : xs) = go (x : accum) xs+  go _ [] = internalError "Separated should not be empty"++consSeparated :: a -> SourceToken -> Separated a -> Separated a+consSeparated x sep (Separated {..}) = Separated x ((sep, sepHead) : sepTail)++internalError :: String -> a+internalError = error . ("Internal parser error: " <>)++toModuleName :: SourceToken -> [Text] -> Parser (Maybe N.ModuleName)+toModuleName _ [] = pure Nothing+toModuleName tok ns = do+  when (not (all isValidModuleNamespace ns)) $ addFailure [tok] ErrModuleName+  pure . Just . N.ModuleName $ Text.intercalate "." ns++upperToModuleName :: SourceToken -> Parser (Name N.ModuleName)+upperToModuleName tok = case tokValue tok of+  TokUpperName q a -> do+    let ns = q <> [a]+    when (not (all isValidModuleNamespace ns)) $ addFailure [tok] ErrModuleName+    pure . Name tok . N.ModuleName $ Text.intercalate "." ns+  _ -> internalError $ "Invalid upper name: " <> show tok++toQualifiedName :: (Text -> a) -> SourceToken -> Parser (QualifiedName a)+toQualifiedName k tok = case tokValue tok of+  TokLowerName q a+    | not (Set.member a reservedNames) -> flip (QualifiedName tok) (k a) <$> toModuleName tok q+    | otherwise -> addFailure [tok] ErrKeywordVar $> QualifiedName tok Nothing (k "<unexpected>")+  TokUpperName q a  -> flip (QualifiedName tok) (k a) <$> toModuleName tok q+  TokSymbolName q a -> flip (QualifiedName tok) (k a) <$> toModuleName tok q+  TokOperator q a   -> flip (QualifiedName tok) (k a) <$> toModuleName tok q+  _                 -> internalError $ "Invalid qualified name: " <> show tok++toName :: (Text -> a) -> SourceToken -> Parser (Name a)+toName k tok = case tokValue tok of+  TokLowerName [] a+    | not (Set.member a reservedNames) -> pure $ Name tok (k a)+    | otherwise -> addFailure [tok] ErrKeywordVar $> Name tok (k "<unexpected>")+  TokString _ _ -> parseFail tok ErrQuotedPun+  TokRawString _ -> parseFail tok ErrQuotedPun+  TokUpperName [] a  -> pure $ Name tok (k a)+  TokSymbolName [] a -> pure $ Name tok (k a)+  TokOperator [] a   -> pure $ Name tok (k a)+  TokHole a          -> pure $ Name tok (k a)+  _                  -> internalError $ "Invalid name: " <> show tok++toLabel :: SourceToken -> Label+toLabel tok = case tokValue tok of+  TokLowerName [] a -> Label tok $ mkString a+  TokString _ a     -> Label tok a+  TokRawString a    -> Label tok $ mkString a+  TokForall ASCII   -> Label tok $ mkString "forall"+  _                 -> internalError $ "Invalid label: " <> show tok++labelToIdent :: Label -> Parser (Name Ident)+labelToIdent (Label tok _) = toName Ident tok++toString :: SourceToken -> (SourceToken, PSString)+toString tok = case tokValue tok of+  TokString _ a  -> (tok, a)+  TokRawString a -> (tok, mkString a)+  _              -> internalError $ "Invalid string literal: " <> show tok++toChar :: SourceToken -> (SourceToken, Char)+toChar tok = case tokValue tok of+  TokChar _ a -> (tok, a)+  _           -> internalError $ "Invalid char literal: " <> show tok++toNumber :: SourceToken -> (SourceToken, Either Integer Double)+toNumber tok = case tokValue tok of+  TokInt _ a    -> (tok, Left a)+  TokNumber _ a -> (tok, Right a)+  _             -> internalError $ "Invalid number literal: " <> show tok++toInt :: SourceToken -> (SourceToken, Integer)+toInt tok = case tokValue tok of+  TokInt _ a    -> (tok, a)+  _             -> internalError $ "Invalid integer literal: " <> show tok++toBoolean :: SourceToken -> (SourceToken, Bool)+toBoolean tok = case tokValue tok of+  TokLowerName [] "true"  -> (tok, True)+  TokLowerName [] "false" -> (tok, False)+  _                       -> internalError $ "Invalid boolean literal: " <> show tok++toConstraint :: forall a. Monoid a => Type a -> Parser (Constraint a)+toConstraint = convertParens+  where+  convertParens :: Type a -> Parser (Constraint a)+  convertParens = \case+    TypeParens a (Wrapped b c d) -> do+      c' <- convertParens c+      pure $ ConstraintParens a (Wrapped b c' d)+    ty -> convert mempty [] ty++  convert :: a -> [Type a] -> Type a -> Parser (Constraint a)+  convert ann acc = \case+    TypeApp a lhs rhs -> convert (a <> ann) (rhs : acc) lhs+    TypeConstructor a name -> do+      for_ acc checkNoForalls+      pure $ Constraint (a <> ann) (coerce name) acc+    ty -> do+      let (tok1, tok2) = typeRange ty+      addFailure [tok1, tok2] ErrTypeInConstraint+      pure $ Constraint mempty (QualifiedName tok1 Nothing (N.ProperName "<unexpected")) []++isConstrained :: Type a -> Bool+isConstrained = everythingOnTypes (||) $ \case+  TypeConstrained{} -> True+  _ -> False++toBinderConstructor :: Monoid a => NE.NonEmpty (Binder a) -> Parser (Binder a)+toBinderConstructor = \case+  BinderConstructor a name [] NE.:| bs ->+    pure $ BinderConstructor a name bs+  a NE.:| [] -> pure a+  a NE.:| _ -> unexpectedToks binderRange (unexpectedBinder) ErrExprInBinder a++toRecordFields+  :: Monoid a+  => Separated (Either (RecordLabeled (Expr a)) (RecordUpdate a))+  -> Parser (Either (Separated (RecordLabeled (Expr a))) (Separated (RecordUpdate a)))+toRecordFields = \case+  Separated (Left a) as ->+    Left . Separated a <$> traverse (traverse unLeft) as+  Separated (Right a) as ->+    Right . Separated a <$> traverse (traverse unRight) as+  where+  unLeft (Left tok) = pure tok+  unLeft (Right tok) =+    unexpectedToks recordUpdateRange unexpectedRecordLabeled ErrRecordUpdateInCtr tok++  unRight (Right tok) = pure tok+  unRight (Left (RecordPun (Name tok _))) = do+    addFailure [tok] ErrRecordPunInUpdate+    pure $ unexpectedRecordUpdate [tok]+  unRight (Left (RecordField _ tok _)) = do+    addFailure [tok] ErrRecordCtrInUpdate+    pure $ unexpectedRecordUpdate [tok]++checkFundeps :: ClassHead a -> Parser ()+checkFundeps (ClassHead _ _ _ _ Nothing) = pure ()+checkFundeps (ClassHead _ _ _ vars (Just (_, fundeps))) = do+  let+    k (TypeVarKinded (Wrapped _ (Labeled a _ _) _)) = getIdent $ nameValue a+    k (TypeVarName a) = getIdent $ nameValue a+    names = k <$> vars+    check a+      | getIdent (nameValue a) `elem` names = pure ()+      | otherwise = addFailure [nameTok a] ErrUnknownFundep+  for_ fundeps $ \case+    FundepDetermined _ bs -> for_ bs check+    FundepDetermines as _ bs -> do+      for_ as check+      for_ bs check++data TmpModuleDecl a+  = TmpImport (ImportDecl a)+  | TmpChain (Separated (Declaration a))+  deriving (Show)++toModuleDecls :: Monoid a => [TmpModuleDecl a] -> Parser ([ImportDecl a], [Declaration a])+toModuleDecls = goImport []+  where+  goImport acc (TmpImport x : xs) = goImport (x : acc) xs+  goImport acc xs = (reverse acc,) <$> goDecl [] xs++  goDecl acc [] = pure $ reverse acc+  goDecl acc (TmpChain (Separated x []) : xs) = goDecl (x : acc) xs+  goDecl acc (TmpChain (Separated (DeclInstanceChain a (Separated h t)) t') : xs) = do+    (a', instances) <- goChain (getName h) a [] t'+    goDecl (DeclInstanceChain a' (Separated h (t <> instances)) : acc) xs+  goDecl acc (TmpChain (Separated _ t) : xs) = do+    for_ t $ \(tok, _) -> addFailure [tok] ErrElseInDecl+    goDecl acc xs+  goDecl acc (TmpImport imp : xs) = do+    unexpectedToks importDeclRange (const ()) ErrImportInDecl imp+    goDecl acc xs++  goChain _ ann acc [] = pure (ann, reverse acc)+  goChain name ann acc ((tok, DeclInstanceChain a (Separated h t)) : xs)+    | eqName (getName h) name = goChain name (ann <> a) (reverse ((tok, h) : t) <> acc) xs+    | otherwise = do+        addFailure [qualTok $ getName h] ErrInstanceNameMismatch+        goChain name ann acc xs+  goChain name ann acc ((tok, _) : xs) = do+    addFailure [tok] ErrElseInDecl+    goChain name ann acc xs++  getName = instClass . instHead+  eqName (QualifiedName _ a b) (QualifiedName _ c d) = a == c && b == d++checkNoWildcards :: Type a -> Parser ()+checkNoWildcards ty = do+  let+    k = \case+      TypeWildcard _ a -> [addFailure [a] ErrWildcardInType]+      TypeHole _ a -> [addFailure [nameTok a] ErrHoleInType]+      _ -> []+  sequence_ $ everythingOnTypes (<>) k ty++checkNoForalls :: Type a -> Parser ()+checkNoForalls ty = do+  let+    k = \case+      TypeForall _ a _ _ _ -> [addFailure [a] ErrToken]+      _ -> []+  sequence_ $ everythingOnTypes (<>) k ty++revert :: Parser a -> SourceToken -> Parser a+revert p lk = pushBack lk *> p++reservedNames :: Set Text+reservedNames = Set.fromList+  [ "ado"+  , "case"+  , "class"+  , "data"+  , "derive"+  , "do"+  , "else"+  , "false"+  , "forall"+  , "foreign"+  , "import"+  , "if"+  , "in"+  , "infix"+  , "infixl"+  , "infixr"+  , "instance"+  , "let"+  , "module"+  , "newtype"+  , "of"+  , "true"+  , "type"+  , "where"+  ]++isValidModuleNamespace :: Text -> Bool+isValidModuleNamespace = Text.null . snd . Text.span (\c -> c /= '_' && c /= '\'')++-- | This is to keep the @Parser.y@ file ASCII, otherwise @happy@ will break+-- in non-unicode locales.+--+-- Related GHC issue: https://gitlab.haskell.org/ghc/ghc/issues/8167+isLeftFatArrow :: Text -> Bool+isLeftFatArrow str = str == "<=" || str == "⇐"
+ tests/Main.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE TupleSections #-}++module Main (main) where++import Prelude.Compat++import Test.Tasty++import qualified TestCst++import System.IO (hSetEncoding, stdout, stderr, utf8)++main :: IO ()+main = do+  hSetEncoding stdout utf8+  hSetEncoding stderr utf8++  cstTests <- TestCst.main++  defaultMain $+    testGroup+      "Tests"+      [ cstTests+      ]
+ tests/TestCst.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+module TestCst where++import Prelude++import Control.Monad (when)+import qualified Data.ByteString.Lazy as BS+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.Text.IO as Text+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Golden (goldenVsString, findByExtension)+import Test.Tasty.QuickCheck+import Text.Read (readMaybe)+import Language.PureScript.CST.Errors as CST+import Language.PureScript.CST.Lexer as CST+import Language.PureScript.CST.Print as CST+import Language.PureScript.CST.Types+import System.FilePath (takeBaseName, replaceExtension)++main :: IO TestTree+main = do+  lytTests <- layoutTests+  pure $ testGroup "cst"+    [ lytTests+    , litTests+    ]++layoutTests :: IO TestTree+layoutTests = do+  pursFiles <- findByExtension [".purs"] "./tests/purs/layout"+  return $ testGroup "Layout golden tests" $ do+    file <- pursFiles+    pure $ goldenVsString+      (takeBaseName file)+      (replaceExtension file ".out")+      (BS.fromStrict . Text.encodeUtf8 <$> runLexer file)+  where+  runLexer file = do+    src <- Text.readFile file+    case sequence $ CST.lex src of+      Left (_, err) ->+        pure $ Text.pack $ CST.prettyPrintError err+      Right toks -> do+        pure $ CST.printTokens toks++litTests :: TestTree+litTests = testGroup "Literals"+  [ testProperty "Integer" $+      checkTok checkReadNum (\case TokInt _ a -> Just a; _ -> Nothing) . unInt+  , testProperty "Hex" $+      checkTok checkReadNum (\case TokInt _ a -> Just a; _ -> Nothing) . unHex+  , testProperty "Number" $+      checkTok checkReadNum (\case TokNumber _ a -> Just a; _ -> Nothing) . unFloat+  , testProperty "Exponent" $+      checkTok checkReadNum (\case TokNumber _ a -> Just a; _ -> Nothing) . unExponent++  , testProperty "Integer (round trip)" $ roundTripTok . unInt+  , testProperty "Hex (round trip)" $ roundTripTok . unHex+  , testProperty "Number (round trip)" $ roundTripTok . unFloat+  , testProperty "Exponent (round trip)" $ roundTripTok . unExponent+  , testProperty "Char (round trip)" $ roundTripTok . unChar+  , testProperty "String (round trip)" $ roundTripTok . unString+  , testProperty "Raw String (round trip)" $ roundTripTok . unRawString+  ]++readTok' :: String -> Text -> Gen SourceToken+readTok' failMsg t = case CST.lex t of+  Right tok : _ ->+    pure tok+  Left (_, err) : _ ->+    fail $ failMsg <> ": " <> CST.prettyPrintError err+  [] ->+    fail "Empty token stream"++readTok :: Text -> Gen SourceToken+readTok = readTok' "Failed to parse"++checkTok+  :: (Text -> a -> Gen Bool)+  -> (Token -> Maybe a)+  -> Text+  -> Gen Bool+checkTok p f t = do+  SourceToken _ tok <- readTok t+  case f tok of+    Just a  -> p t a+    Nothing -> fail $ "Failed to lex correctly: " <> show tok++roundTripTok :: Text -> Gen Bool+roundTripTok t = do+  tok <- readTok t+  let t' = CST.printTokens [tok]+  tok' <- readTok' "Failed to re-parse" t'+  pure $ tok == tok'++checkReadNum :: (Eq a, Read a) => Text -> a -> Gen Bool+checkReadNum t a = do+  let+    chs = case Text.unpack $ Text.replace ".e" ".0e" $ Text.replace "_" "" t of+      chs' | last chs' == '.' -> chs' <> "0"+      chs' -> chs'+  case (== a) <$> readMaybe chs of+    Just a' -> pure a'+    Nothing -> fail "Failed to `read`"++newtype PSSourceInt = PSSourceInt { unInt :: Text }+  deriving (Show, Eq)++instance Arbitrary PSSourceInt where+  arbitrary = resize 16 genInt++newtype PSSourceFloat = PSSourceFloat { unFloat :: Text }+  deriving (Show, Eq)++instance Arbitrary PSSourceFloat where+  arbitrary = resize 16 genFloat++newtype PSSourceExponent = PSSourceExponent { unExponent :: Text }+  deriving (Show, Eq)++instance Arbitrary PSSourceExponent where+  arbitrary = PSSourceExponent <$> do+    floatPart <- unFloat <$> resize 5 genFloat+    signPart <- fromMaybe "" <$> elements [ Just "+", Just "-", Nothing ]+    expPart <- unInt <$> resize 1 genInt+    pure $ floatPart <> "e" <> signPart <> expPart++newtype PSSourceHex = PSSourceHex { unHex :: Text }+  deriving (Show, Eq)++instance Arbitrary PSSourceHex where+  arbitrary = resize 16 genHex++newtype PSSourceChar = PSSourceChar { unChar :: Text }+  deriving (Show, Eq)++instance Arbitrary PSSourceChar where+  arbitrary = genChar++newtype PSSourceString = PSSourceString { unString :: Text }+  deriving (Show, Eq)++instance Arbitrary PSSourceString where+  arbitrary = resize 256 genString++newtype PSSourceRawString = PSSourceRawString { unRawString :: Text }+  deriving (Show, Eq)++instance Arbitrary PSSourceRawString where+  arbitrary = resize 256 genRawString++genInt :: Gen PSSourceInt+genInt = PSSourceInt . Text.pack <$> do+  (:) <$> nonZeroChar+      <*> listOf numChar++genFloat :: Gen PSSourceFloat+genFloat = PSSourceFloat <$> do+  intPart <- unInt <$> genInt+  floatPart <- Text.pack <$> listOf1 numChar+  pure $ intPart <> "." <> floatPart++genHex :: Gen PSSourceHex+genHex = PSSourceHex <$> do+  nums <- listOf1 hexDigit+  pure $ "0x" <> Text.pack nums++genChar :: Gen PSSourceChar+genChar = PSSourceChar <$> do+  ch <- resize 0xFFFF arbitrarySizedNatural >>= (genStringChar '\'' . toEnum)+  pure $ "'" <> ch <> "'"++genString :: Gen PSSourceString+genString = PSSourceString <$> do+  chs <- listOf $ arbitraryUnicodeChar >>= genStringChar '"'+  pure $ "\"" <> Text.concat chs <> "\""++genStringChar :: Char -> Char -> Gen Text+genStringChar delimiter ch = frequency+  [ (1, genCharEscape)+  , (10, if ch `elem` [delimiter, '\n', '\r', '\\']+           then discard+           else pure $ Text.singleton ch+    )+  ]++genRawString :: Gen PSSourceRawString+genRawString = PSSourceRawString <$> do+  chs <- listOf $ arbitraryUnicodeChar+  let+    k1 acc qs cs = do+      let (cs', q) = span (/= '"') cs+      k2 (acc <> cs') qs q+    k2 acc qs [] = acc <> qs+    k2 acc qs cs = do+      let (q, cs') = span (== '"') cs+      k1 (acc <> take 2 q) (qs <> drop 2 q) cs'+    chs' = k1 [] [] chs+  when (all (== '"') chs') discard+  pure $ "\"\"\"" <> Text.pack chs' <> "\"\"\""++genCharEscape :: Gen Text+genCharEscape = oneof+  [ pure "\\t"+  , pure "\\r"+  , pure "\\n"+  , pure "\\\""+  , pure "\\'"+  , pure "\\\\"+  , do+      chs <- resize 4 $ listOf1 hexDigit+      pure $ "\\x" <> Text.pack chs+  ]++numChar :: Gen Char+numChar = elements "0123456789_"++nonZeroChar :: Gen Char+nonZeroChar = elements "123456789"++hexDigit :: Gen Char+hexDigit = elements $ ['a'..'f'] <> ['A'..'F'] <> ['0'..'9']
+ tests/purs/layout/AdoIn.out view
@@ -0,0 +1,20 @@+module Test where{++test = ado{+  baz;+  let {foo = bar}}+   in bar;++test = ado {}in foo;++test = ado{+  foo <- bar $ let {a = 42 }in a;+  baz <- b}+  in bar;++test = ado{+  foo;+  let {bar = let {a = 42 }in a};+  let {baz = 42}}+  in bar}+<eof>
+ tests/purs/layout/AdoIn.purs view
@@ -0,0 +1,19 @@+module Test where++test = ado+  baz+  let foo = bar+   in bar++test = ado in foo++test = ado+  foo <- bar $ let a = 42 in a+  baz <- b+  in bar++test = ado+  foo+  let bar = let a = 42 in a+  let baz = 42+  in bar
+ tests/purs/layout/CaseGuards.out view
@@ -0,0 +1,54 @@+module Test where{++-- Including data because of `|` masking+data Foo+ = Foo+ | Bar+ | Baz;++test =+  case foo of{+    a | b, c ->+      d;+    a | b, c -> d};++test = case a, b of{+  c, d+   | e ->+     case e of{+       f | true -> bar+         | false -> baz}+   | f -> g};++test a+  | false =+      case false of{+        true | a > 12 -> true}+  | otherwise = true;++test = case a of {foo | foo \a -> a -> true};++test = a `case _ of {x | unit # \_ -> true, true -> const}` b;++test = case a of{+  12 | do {that;+          that   }-> this+     | otherwise -> this};++test a b = [ case _ of{+  12 | case a, b of{+         _, 42 -> b;+         _, 12 -> false}, b -> true+     | case a, b of{+         _, 42 -> b;+         _, 12 -> false}, b -> true}, false ];++test a+  | case a, b of{+         _, 42 -> b;+         _, 12 -> false}, b = true+  | case a, b of{+         _, 42 -> b;+         _, 12 -> false}, b = true}++<eof>
+ tests/purs/layout/CaseGuards.purs view
@@ -0,0 +1,53 @@+module Test where++-- Including data because of `|` masking+data Foo+ = Foo+ | Bar+ | Baz++test =+  case foo of+    a | b, c ->+      d+    a | b, c -> d++test = case a, b of+  c, d+   | e ->+     case e of+       f | true -> bar+         | false -> baz+   | f -> g++test a+  | false =+      case false of+        true | a > 12 -> true+  | otherwise = true++test = case a of foo | foo \a -> a -> true++test = a `case _ of x | unit # \_ -> true, true -> const` b++test = case a of+  12 | do that+          that   -> this+     | otherwise -> this++test a b = [ case _ of+  12 | case a, b of+         _, 42 -> b+         _, 12 -> false, b -> true+     | case a, b of+         _, 42 -> b+         _, 12 -> false, b -> true, false ]++test a+  | case a, b of+         _, 42 -> b+         _, 12 -> false, b = true+  | case a, b of+         _, 42 -> b+         _, 12 -> false, b = true+
+ tests/purs/layout/CaseWhere.out view
@@ -0,0 +1,13 @@+module Test where{++test = case foo of{+  Nothing -> a+    where {a = 12};+  Just a -> do{+    what}}+  where{+    foo = bar};++test = case f of {Foo -> do {that}+                        where {foo = 12}}}+<eof>
+ tests/purs/layout/CaseWhere.purs view
@@ -0,0 +1,12 @@+module Test where++test = case foo of+  Nothing -> a+    where a = 12+  Just a -> do+    what+  where+    foo = bar++test = case f of Foo -> do that+                        where foo = 12
+ tests/purs/layout/ClassHead.out view
@@ -0,0 +1,11 @@+module Test where{++import Foo (class Foo);++class Foo a b c d | a -> b, c -> d where{+  foo :: Foo};++class Foo a b c d | a -> b, c -> d;++instance foo :: Foo}+<eof>
+ tests/purs/layout/ClassHead.purs view
@@ -0,0 +1,10 @@+module Test where++import Foo (class Foo)++class Foo a b c d | a -> b, c -> d where+  foo :: Foo++class Foo a b c d | a -> b, c -> d++instance foo :: Foo
+ tests/purs/layout/Commas.out view
@@ -0,0 +1,23 @@+module Test where{++test =+  [ case do {foo}, bar of{+      a | b, c -> d}, bar+    ];++test =+  [ case do {foo}, bar of {a | b, c -> d}, bar ];++test =+  [ do {do {do {foo}}}, bar ];++test =+  [ \foo -> foo, bar ];++test = foo where{+  bar =+    case a, b of{+      c, d | d == [case true, w of {1, a -> true}, false ] -> d;+      e, d | do {what}, do {that }-> d}}}++<eof>
+ tests/purs/layout/Commas.purs view
@@ -0,0 +1,22 @@+module Test where++test =+  [ case do foo, bar of+      a | b, c -> d, bar+    ]++test =+  [ case do foo, bar of a | b, c -> d, bar ]++test =+  [ do do do foo, bar ]++test =+  [ \foo -> foo, bar ]++test = foo where+  bar =+    case a, b of+      c, d | d == [case true, w of 1, a -> true, false ] -> d+      e, d | do what, do that -> d+
+ tests/purs/layout/Delimiter.out view
@@ -0,0 +1,14 @@+module Test where{++test1 = a;+test2 = {+  b+};+test3 = do{+  foo;+  bar (+    baz+  ) == 12;+  baz};+test4 = c}+<eof>
+ tests/purs/layout/Delimiter.purs view
@@ -0,0 +1,13 @@+module Test where++test1 = a+test2 = {+  b+}+test3 = do+  foo+  bar (+    baz+  ) == 12+  baz+test4 = c
+ tests/purs/layout/DoLet.out view
@@ -0,0 +1,16 @@+module Test where{++test = do{+  let {foo = bar};+  foo};++test = do{+  let {foo = bar};+  in baz;+  foo};++test = do{+  let {foo = bar}+    in baz;+  foo}}+<eof>
+ tests/purs/layout/DoLet.purs view
@@ -0,0 +1,15 @@+module Test where++test = do+  let foo = bar+  foo++test = do+  let foo = bar+  in baz+  foo++test = do+  let foo = bar+    in baz+  foo
+ tests/purs/layout/DoOperator.out view
@@ -0,0 +1,9 @@+module Test where{++test = do{+  foo;+  foo do{+    bar}}+  <|> bar}++<eof>
+ tests/purs/layout/DoOperator.purs view
@@ -0,0 +1,8 @@+module Test where++test = do+  foo+  foo do+    bar+  <|> bar+
+ tests/purs/layout/DoWhere.out view
@@ -0,0 +1,7 @@+module Test where{++test =+  do{+    do {do{+        foo }}}where {bar = baz}}+<eof>
+ tests/purs/layout/DoWhere.purs view
@@ -0,0 +1,6 @@+module Test where++test =+  do+    do do+        foo where bar = baz
+ tests/purs/layout/IfThenElseDo.out view
@@ -0,0 +1,11 @@+module Test where{++foo = do{+  if true then+    false+  else if false then do{+    that}+    else do{+     what};+  that}}+<eof>
+ tests/purs/layout/IfThenElseDo.purs view
@@ -0,0 +1,10 @@+module Test where++foo = do+  if true then+    false+  else if false then do+    that+    else do+     what+  that
+ tests/purs/layout/InstanceChainElse.out view
@@ -0,0 +1,5 @@+module Test where{++instance foo :: Foo Int else bar :: Foo String+else baz :: Foo Boolean}+<eof>
+ tests/purs/layout/InstanceChainElse.purs view
@@ -0,0 +1,4 @@+module Test where++instance foo :: Foo Int else bar :: Foo String+else baz :: Foo Boolean
+ tests/purs/layout/LetGuards.out view
@@ -0,0 +1,30 @@+module Test where{++test =+  let{+    foo+      | bar+      , baz =+        42+      | otherwise = 100}+  in+    foo;++test = do{+  let{+    foo+      | bar+      , baz =+        42+      | otherwise = 100};+  foo};++test = ado{+  let{+    foo+      | bar+      , baz =+        42+      | otherwise = 100};+  foo}}+<eof>
+ tests/purs/layout/LetGuards.purs view
@@ -0,0 +1,29 @@+module Test where++test =+  let+    foo+      | bar+      , baz =+        42+      | otherwise = 100+  in+    foo++test = do+  let+    foo+      | bar+      , baz =+        42+      | otherwise = 100+  foo++test = ado+  let+    foo+      | bar+      , baz =+        42+      | otherwise = 100+  foo