diff --git a/bench/src/BenchFile.purs b/bench/src/BenchFile.purs index 2cc6726..b2ea484 100644 --- a/bench/src/BenchFile.purs +++ b/bench/src/BenchFile.purs @@ -13,7 +13,7 @@ import Node.Encoding (Encoding(..)) import Node.FS.Aff (readFile) import Node.Process as Process import Performance.Minibench (benchWith) -import PureScript.CST (parseModule) +import PureScript.CST.Recovered (parseModule) main :: Effect Unit main = launchAff_ do diff --git a/bench/src/ParseFile.purs b/bench/src/ParseFile.purs index cfee4c1..08366d9 100644 --- a/bench/src/ParseFile.purs +++ b/bench/src/ParseFile.purs @@ -15,13 +15,13 @@ import Node.Buffer as Buffer import Node.Encoding (Encoding(..)) import Node.FS.Aff (readFile) import Node.Process as Process -import PureScript.CST (RecoveredParserResult(..), parseModule) -import PureScript.CST.Errors (ParseError, printParseError) +import PureScript.CST.Errors (ParseError) import PureScript.CST.Lexer (lexModule) -import PureScript.CST.Parser.Monad (PositionedError) -import PureScript.CST.Print (TokenOption(..), printSourceTokenWithOption) +import PureScript.CST.Parser (PositionedError) +import PureScript.CST.Print (TokenOption(..), printParseError, printSourceTokenWithOption) +import PureScript.CST.Recovered (RecoveredParserResult(..), parseModule) import PureScript.CST.TokenStream (TokenStep(..), TokenStream, step) -import PureScript.CST.Types (SourceToken) +import PureScript.CST (SourceToken) main :: Effect Unit main = launchAff_ do diff --git a/parse-package-set/src/Main.purs b/parse-package-set/src/Main.purs index 37235e1..453c7bb 100644 --- a/parse-package-set/src/Main.purs +++ b/parse-package-set/src/Main.purs @@ -40,11 +40,11 @@ import Node.Path as Path import Node.Process (stderr) import Node.Process as Process import Node.Stream as Stream -import PureScript.CST (RecoveredParserResult(..), parseModule, printModule) -import PureScript.CST.Errors (printParseError) +import PureScript.CST.Recovered (RecoveredParserResult(..), parseModule) +import PureScript.CST.Print (printModule, printParseError) import PureScript.CST.ModuleGraph (sortModules, ModuleSort(..)) -import PureScript.CST.Parser.Monad (PositionedError) -import PureScript.CST.Types (Module(..), ModuleHeader) +import PureScript.CST.Parser (PositionedError) +import PureScript.CST (Module(..), ModuleHeader) foreign import tmpdir :: String -> Effect String diff --git a/src/PureScript/CST.purs b/src/PureScript/CST.purs index 1c9ca1a..f5fb3b0 100644 --- a/src/PureScript/CST.purs +++ b/src/PureScript/CST.purs @@ -1,103 +1,489 @@ -module PureScript.CST - ( RecoveredParserResult(..) - , PartialModule(..) - , parseModule - , parsePartialModule - , parseImportDecl - , parseDecl - , parseExpr - , parseType - , parseBinder - , printModule - , toRecovered - ) where +module PureScript.CST where import Prelude -import Prim hiding (Type) import Data.Array.NonEmpty (NonEmptyArray) -import Data.Array.NonEmpty as NonEmptyArray -import Data.Either (Either(..)) -import Data.Foldable (foldMap) -import Data.Lazy as Z -import Data.Maybe (Maybe(..)) -import Data.Newtype (unwrap) -import Data.Tuple (Tuple(..)) -import PureScript.CST.Lexer (lex, lexModule) -import PureScript.CST.Parser (Recovered, parseModuleBody, parseModuleHeader) -import PureScript.CST.Parser as Parser -import PureScript.CST.Parser.Monad (Parser, ParserResult(..), PositionedError, fromParserResult, initialParserState, runParser, runParser') -import PureScript.CST.Print as Print -import PureScript.CST.Range (class TokensOf, tokensOf) -import PureScript.CST.Range.TokenList as TokenList -import PureScript.CST.TokenStream (TokenStream) -import PureScript.CST.Types (Binder, Declaration, Expr, ImportDecl, Module(..), ModuleHeader, Type) -import Unsafe.Coerce (unsafeCoerce) - -data RecoveredParserResult f - = ParseSucceeded (f Void) - | ParseSucceededWithErrors (Recovered f) (NonEmptyArray PositionedError) - | ParseFailed PositionedError - -toRecoveredParserResult - :: forall f - . Either PositionedError (Tuple (Recovered f) (Array PositionedError)) - -> RecoveredParserResult f -toRecoveredParserResult = case _ of - Right (Tuple res errors) - | Just nea <- NonEmptyArray.fromArray errors -> - ParseSucceededWithErrors res nea - | otherwise -> - ParseSucceeded ((unsafeCoerce :: Recovered f -> f Void) res) - Left err -> - ParseFailed err - -toRecovered :: forall f. f Void -> Recovered f -toRecovered = unsafeCoerce - -runRecoveredParser :: forall a. Parser (Recovered a) -> TokenStream -> RecoveredParserResult a -runRecoveredParser p = toRecoveredParserResult <<< flip runParser p - -parseModule :: String -> RecoveredParserResult Module -parseModule = runRecoveredParser Parser.parseModule <<< lexModule - -parseImportDecl :: String -> RecoveredParserResult ImportDecl -parseImportDecl = runRecoveredParser Parser.parseImportDecl <<< lex - -parseDecl :: String -> RecoveredParserResult Declaration -parseDecl = runRecoveredParser Parser.parseDecl <<< lex - -parseExpr :: String -> RecoveredParserResult Expr -parseExpr = runRecoveredParser Parser.parseExpr <<< lex - -parseType :: String -> RecoveredParserResult Type -parseType = runRecoveredParser Parser.parseType <<< lex - -parseBinder :: String -> RecoveredParserResult Binder -parseBinder = runRecoveredParser Parser.parseBinder <<< lex - -newtype PartialModule e = PartialModule +import Data.Either (Either) +import Data.Maybe (Maybe) +import Data.Newtype (class Newtype) +import Data.Tuple (Tuple) +import Prim hiding (Row, Type) + +newtype ModuleName = ModuleName String + +derive newtype instance eqModuleName :: Eq ModuleName +derive newtype instance ordModuleName :: Ord ModuleName +derive instance newtypeModuleName :: Newtype ModuleName _ + +type SourcePos = + { line :: Int + , column :: Int + } + +type SourceRange = + { start :: SourcePos + , end :: SourcePos + } + +data Comment l + = Comment String + | Space Int + | Line l Int + +data LineFeed + = LF + | CRLF + +data SourceStyle + = ASCII + | Unicode + +derive instance eqSourceStyle :: Eq SourceStyle + +data IntValue + = SmallInt Int + | BigInt String + | BigHex String + +derive instance eqIntValue :: Eq IntValue + +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 + | TokAt + | TokLowerName (Maybe ModuleName) String + | TokUpperName (Maybe ModuleName) String + | TokOperator (Maybe ModuleName) String + | TokSymbolName (Maybe ModuleName) String + | TokSymbolArrow SourceStyle + | TokHole String + | TokChar String Char + | TokString String String + | TokRawString String + | TokInt String IntValue + | TokNumber String Number + | TokLayoutStart Int + | TokLayoutSep Int + | TokLayoutEnd Int + +derive instance eqToken :: Eq Token + +type SourceToken = + { range :: SourceRange + , leadingComments :: Array (Comment LineFeed) + , trailingComments :: Array (Comment Void) + , value :: Token + } + +newtype Ident = Ident String + +derive newtype instance eqIdent :: Eq Ident +derive newtype instance ordIdent :: Ord Ident +derive instance newtypeIdent :: Newtype Ident _ + +newtype Proper = Proper String + +derive newtype instance eqProper :: Eq Proper +derive newtype instance ordProper :: Ord Proper +derive instance newtypeProper :: Newtype Proper _ + +newtype Label = Label String + +derive newtype instance eqLabel :: Eq Label +derive newtype instance ordLabel :: Ord Label +derive instance newtypeLabel :: Newtype Label _ + +newtype Operator = Operator String + +derive newtype instance eqOperator :: Eq Operator +derive newtype instance ordOperator :: Ord Operator +derive instance newtypeOperator :: Newtype Operator _ + +newtype Name a = Name + { token :: SourceToken + , name :: a + } + +derive instance newtypeName :: Newtype (Name a) _ + +newtype QualifiedName a = QualifiedName + { token :: SourceToken + , module :: Maybe ModuleName + , name :: a + } + +derive instance newtypeQualifiedName :: Newtype (QualifiedName a) _ + +newtype Wrapped a = Wrapped + { open :: SourceToken + , value :: a + , close :: SourceToken + } + +derive instance newtypeWrapped :: Newtype (Wrapped a) _ + +newtype Separated a = Separated + { head :: a + , tail :: Array (Tuple SourceToken a) + } + +derive instance newtypeSeparated :: Newtype (Separated a) _ + +newtype Labeled a b = Labeled + { label :: a + , separator :: SourceToken + , value :: b + } + +derive instance newtypeLabeled :: Newtype (Labeled a b) _ + +newtype Prefixed a = Prefixed + { prefix :: Maybe SourceToken + , value :: a + } + +derive instance newtypePrefixed :: Newtype (Prefixed a) _ + +type Delimited a = Wrapped (Maybe (Separated a)) +type DelimitedNonEmpty a = Wrapped (Separated a) + +data OneOrDelimited a + = One a + | Many (DelimitedNonEmpty a) + +data Type e + = TypeVar (Name Ident) + | TypeConstructor (QualifiedName Proper) + | TypeWildcard SourceToken + | TypeHole (Name Ident) + | TypeString SourceToken String + | TypeInt (Maybe SourceToken) SourceToken IntValue + | TypeRow (Wrapped (Row e)) + | TypeRecord (Wrapped (Row e)) + | TypeForall SourceToken (NonEmptyArray (TypeVarBinding (Prefixed (Name Ident)) e)) SourceToken (Type e) + | TypeKinded (Type e) SourceToken (Type e) + | TypeApp (Type e) (NonEmptyArray (Type e)) + | TypeOp (Type e) (NonEmptyArray (Tuple (QualifiedName Operator) (Type e))) + | TypeOpName (QualifiedName Operator) + | TypeArrow (Type e) SourceToken (Type e) + | TypeArrowName SourceToken + | TypeConstrained (Type e) SourceToken (Type e) + | TypeParens (Wrapped (Type e)) + | TypeError e + +data TypeVarBinding a e + = TypeVarKinded (Wrapped (Labeled a (Type e))) + | TypeVarName a + +newtype Row e = Row + { labels :: Maybe (Separated (Labeled (Name Label) (Type e))) + , tail :: Maybe (Tuple SourceToken (Type e)) + } + +derive instance newtypeRow :: Newtype (Row e) _ + +newtype Module e = Module { header :: ModuleHeader e - , full :: Z.Lazy (RecoveredParserResult Module) - } - -parsePartialModule :: String -> RecoveredParserResult PartialModule -parsePartialModule src = - toRecoveredParserResult $ case runParser' (initialParserState (lexModule src)) parseModuleHeader of - ParseSucc header state -> do - let - res = PartialModule - { header - , full: Z.defer \_ -> - toRecoveredParserResult $ fromParserResult $ runParser' state do - body <- parseModuleBody - pure $ Module { header, body } - } - Right $ Tuple res state.errors - ParseFail error _ -> - Left error - -printModule :: forall e. TokensOf e => Module e -> String -printModule mod = - foldMap Print.printSourceToken (TokenList.toArray (tokensOf mod)) - <> foldMap (Print.printComment Print.printLineFeed) (unwrap (unwrap mod).body).trailingComments + , body :: ModuleBody e + } + +derive instance newtypeModule :: Newtype (Module e) _ + +newtype ModuleHeader e = ModuleHeader + { keyword :: SourceToken + , name :: Name ModuleName + , exports :: Maybe (DelimitedNonEmpty (Export e)) + , where :: SourceToken + , imports :: Array (ImportDecl e) + } + +derive instance newtypeModuleHeader :: Newtype (ModuleHeader e) _ + +newtype ModuleBody e = ModuleBody + { decls :: Array (Declaration e) + , trailingComments :: Array (Comment LineFeed) + , end :: SourcePos + } + +derive instance newtypeModuleBody :: Newtype (ModuleBody e) _ + +data Export e + = ExportValue (Name Ident) + | ExportOp (Name Operator) + | ExportType (Name Proper) (Maybe DataMembers) + | ExportTypeOp SourceToken (Name Operator) + | ExportClass SourceToken (Name Proper) + | ExportModule SourceToken (Name ModuleName) + | ExportError e + +data DataMembers + = DataAll SourceToken + | DataEnumerated (Delimited (Name Proper)) + +data Declaration e + = DeclData (DataHead e) (Maybe (Tuple SourceToken (Separated (DataCtor e)))) + | DeclType (DataHead e) SourceToken (Type e) + | DeclNewtype (DataHead e) SourceToken (Name Proper) (Type e) + | DeclClass (ClassHead e) (Maybe (Tuple SourceToken (NonEmptyArray (Labeled (Name Ident) (Type e))))) + | DeclInstanceChain (Separated (Instance e)) + | DeclDerive SourceToken (Maybe SourceToken) (InstanceHead e) + | DeclKindSignature SourceToken (Labeled (Name Proper) (Type e)) + | DeclSignature (Labeled (Name Ident) (Type e)) + | DeclValue (ValueBindingFields e) + | DeclFixity FixityFields + | DeclForeign SourceToken SourceToken (Foreign e) + | DeclRole SourceToken SourceToken (Name Proper) (NonEmptyArray (Tuple SourceToken Role)) + | DeclError e + +newtype Instance e = Instance + { head :: InstanceHead e + , body :: Maybe (Tuple SourceToken (NonEmptyArray (InstanceBinding e))) + } + +derive instance newtypeInstance :: Newtype (Instance e) _ + +data InstanceBinding e + = InstanceBindingSignature (Labeled (Name Ident) (Type e)) + | InstanceBindingName (ValueBindingFields e) + +newtype ImportDecl e = ImportDecl + { keyword :: SourceToken + , module :: Name ModuleName + , names :: Maybe (Tuple (Maybe SourceToken) (DelimitedNonEmpty (Import e))) + , qualified :: Maybe (Tuple SourceToken (Name ModuleName)) + } + +derive instance newtypeImportDecl :: Newtype (ImportDecl e) _ + +data Import e + = ImportValue (Name Ident) + | ImportOp (Name Operator) + | ImportType (Name Proper) (Maybe DataMembers) + | ImportTypeOp SourceToken (Name Operator) + | ImportClass SourceToken (Name Proper) + | ImportError e + +type DataHead e = + { keyword :: SourceToken + , name :: Name Proper + , vars :: Array (TypeVarBinding (Name Ident) e) + } + +newtype DataCtor e = DataCtor + { name :: Name Proper + , fields :: Array (Type e) + } + +derive instance newtypeDataCtor :: Newtype (DataCtor e) _ + +type ClassHead e = + { keyword :: SourceToken + , super :: Maybe (Tuple (OneOrDelimited (Type e)) SourceToken) + , name :: Name Proper + , vars :: Array (TypeVarBinding (Name Ident) e) + , fundeps :: Maybe (Tuple SourceToken (Separated ClassFundep)) + } + +data ClassFundep + = FundepDetermined SourceToken (NonEmptyArray (Name Ident)) + | FundepDetermines (NonEmptyArray (Name Ident)) SourceToken (NonEmptyArray (Name Ident)) + +type InstanceHead e = + { keyword :: SourceToken + , name :: Maybe (Tuple (Name Ident) SourceToken) + , constraints :: Maybe (Tuple (OneOrDelimited (Type e)) SourceToken) + , className :: QualifiedName Proper + , types :: Array (Type e) + } + +data Fixity + = Infix + | Infixl + | Infixr + +data FixityOp + = FixityValue (QualifiedName (Either Ident Proper)) SourceToken (Name Operator) + | FixityType SourceToken (QualifiedName Proper) SourceToken (Name Operator) + +type FixityFields = + { keyword :: Tuple SourceToken Fixity + , prec :: Tuple SourceToken Int + , operator :: FixityOp + } + +type ValueBindingFields e = + { name :: Name Ident + , binders :: Array (Binder e) + , guarded :: Guarded e + } + +data Guarded e + = Unconditional SourceToken (Where e) + | Guarded (NonEmptyArray (GuardedExpr e)) + +newtype GuardedExpr e = GuardedExpr + { bar :: SourceToken + , patterns :: Separated (PatternGuard e) + , separator :: SourceToken + , where :: Where e + } + +derive instance newtypeGuardedExpr :: Newtype (GuardedExpr e) _ + +newtype PatternGuard e = PatternGuard + { binder :: Maybe (Tuple (Binder e) SourceToken) + , expr :: Expr e + } + +derive instance newtypePatternGuard :: Newtype (PatternGuard e) _ + +data Foreign e + = ForeignValue (Labeled (Name Ident) (Type e)) + | ForeignData SourceToken (Labeled (Name Proper) (Type e)) + | ForeignKind SourceToken (Name Proper) + +data Role + = Nominal + | Representational + | Phantom + +data Expr e + = ExprHole (Name Ident) + | ExprSection SourceToken + | ExprIdent (QualifiedName Ident) + | ExprConstructor (QualifiedName Proper) + | ExprBoolean SourceToken Boolean + | ExprChar SourceToken Char + | ExprString SourceToken String + | ExprInt SourceToken IntValue + | ExprNumber SourceToken Number + | ExprArray (Delimited (Expr e)) + | ExprRecord (Delimited (RecordLabeled (Expr e))) + | ExprParens (Wrapped (Expr e)) + | ExprTyped (Expr e) SourceToken (Type e) + | ExprInfix (Expr e) (NonEmptyArray (Tuple (Wrapped (Expr e)) (Expr e))) + | ExprOp (Expr e) (NonEmptyArray (Tuple (QualifiedName Operator) (Expr e))) + | ExprOpName (QualifiedName Operator) + | ExprNegate SourceToken (Expr e) + | ExprRecordAccessor (RecordAccessor e) + | ExprRecordUpdate (Expr e) (DelimitedNonEmpty (RecordUpdate e)) + | ExprApp (Expr e) (NonEmptyArray (AppSpine Expr e)) + | ExprLambda (Lambda e) + | ExprIf (IfThenElse e) + | ExprCase (CaseOf e) + | ExprLet (LetIn e) + | ExprDo (DoBlock e) + | ExprAdo (AdoBlock e) + | ExprError e + +data AppSpine f e + = AppType SourceToken (Type e) + | AppTerm (f e) + +data RecordLabeled a + = RecordPun (Name Ident) + | RecordField (Name Label) SourceToken a + +data RecordUpdate e + = RecordUpdateLeaf (Name Label) SourceToken (Expr e) + | RecordUpdateBranch (Name Label) (DelimitedNonEmpty (RecordUpdate e)) + +type RecordAccessor e = + { expr :: Expr e + , dot :: SourceToken + , path :: Separated (Name Label) + } + +type Lambda e = + { symbol :: SourceToken + , binders :: NonEmptyArray (Binder e) + , arrow :: SourceToken + , body :: Expr e + } + +type IfThenElse e = + { keyword :: SourceToken + , cond :: Expr e + , then :: SourceToken + , true :: Expr e + , else :: SourceToken + , false :: Expr e + } + +type CaseOf e = + { keyword :: SourceToken + , head :: Separated (Expr e) + , of :: SourceToken + , branches :: NonEmptyArray (Tuple (Separated (Binder e)) (Guarded e)) + } + +type LetIn e = + { keyword :: SourceToken + , bindings :: NonEmptyArray (LetBinding e) + , in :: SourceToken + , body :: Expr e + } + +newtype Where e = Where + { expr :: Expr e + , bindings :: Maybe (Tuple SourceToken (NonEmptyArray (LetBinding e))) + } + +derive instance newtypeWhere :: Newtype (Where e) _ + +data LetBinding e + = LetBindingSignature (Labeled (Name Ident) (Type e)) + | LetBindingName (ValueBindingFields e) + | LetBindingPattern (Binder e) SourceToken (Where e) + | LetBindingError e + +type DoBlock e = + { keyword :: SourceToken + , statements :: NonEmptyArray (DoStatement e) + } + +data DoStatement e + = DoLet SourceToken (NonEmptyArray (LetBinding e)) + | DoDiscard (Expr e) + | DoBind (Binder e) SourceToken (Expr e) + | DoError e + +type AdoBlock e = + { keyword :: SourceToken + , statements :: Array (DoStatement e) + , in :: SourceToken + , result :: Expr e + } + +data Binder e + = BinderWildcard SourceToken + | BinderVar (Name Ident) + | BinderNamed (Name Ident) SourceToken (Binder e) + | BinderConstructor (QualifiedName Proper) (Array (Binder e)) + | BinderBoolean SourceToken Boolean + | BinderChar SourceToken Char + | BinderString SourceToken String + | BinderInt (Maybe SourceToken) SourceToken IntValue + | BinderNumber (Maybe SourceToken) SourceToken Number + | BinderArray (Delimited (Binder e)) + | BinderRecord (Delimited (RecordLabeled (Binder e))) + | BinderParens (Wrapped (Binder e)) + | BinderTyped (Binder e) SourceToken (Type e) + | BinderOp (Binder e) (NonEmptyArray (Tuple (QualifiedName Operator) (Binder e))) + | BinderError e diff --git a/src/PureScript/CST/Errors.purs b/src/PureScript/CST/Errors.purs index 8f8264d..aafca48 100644 --- a/src/PureScript/CST/Errors.purs +++ b/src/PureScript/CST/Errors.purs @@ -1,14 +1,9 @@ module PureScript.CST.Errors ( RecoveredError(..) , ParseError(..) - , printParseError - , printTokenError ) where -import Prelude - -import PureScript.CST.Print (printQualified) -import PureScript.CST.Types (SourcePos, SourceStyle(..), Token(..), SourceToken) +import PureScript.CST (SourcePos, SourceToken, Token) newtype RecoveredError = RecoveredError { error :: ParseError @@ -28,109 +23,3 @@ data ParseError | LexHexOutOfRange String | LexIntOutOfRange String | LexNumberOutOfRange String - -printParseError :: ParseError -> String -printParseError = case _ of - UnexpectedEof -> - "Unexpected end of file" - ExpectedEof tok -> - "Expected end of file, saw " <> printTokenError tok - UnexpectedToken tok -> - "Unexpected " <> printTokenError tok - ExpectedToken tok saw -> - "Expected " <> printTokenError tok <> ", saw " <> printTokenError saw - ExpectedClass cls saw -> - "Expected " <> cls <> ", saw " <> printTokenError saw - LexExpected str saw -> - "Expected " <> str <> ", saw " <> saw - LexInvalidCharEscape str -> - "Invalid character escape \\" <> str - LexCharEscapeOutOfRange str -> - "Character escape out of range \\" <> str - LexHexOutOfRange str -> - "Hex integer out of range 0x" <> str - LexIntOutOfRange str -> - "Int out of range " <> str - LexNumberOutOfRange str -> - "Number out of range " <> str - -printTokenError :: Token -> String -printTokenError = case _ of - TokLeftParen -> - "'('" - TokRightParen -> - "')'" - TokLeftBrace -> - "'{'" - TokRightBrace -> - "'}'" - TokLeftSquare -> - "'['" - TokRightSquare -> - "']'" - TokLeftArrow style -> - case style of - ASCII -> "'<-'" - Unicode -> "'←'" - TokRightArrow style -> - case style of - ASCII -> "'->'" - Unicode -> "'→'" - TokRightFatArrow style -> - case style of - ASCII -> "'=>'" - Unicode -> "'⇒'" - TokDoubleColon style -> - case style of - ASCII -> "'::'" - Unicode -> "'∷'" - TokForall style -> - case style of - ASCII -> "forall" - Unicode -> "'∀'" - TokEquals -> - "'='" - TokPipe -> - "'|'" - TokTick -> - "`" - TokDot -> - "." - TokComma -> - "','" - TokUnderscore -> - "'_'" - TokBackslash -> - "'\\'" - TokAt -> - "'@'" - TokLowerName moduleName name -> - "identifier " <> printQualified moduleName name - TokUpperName moduleName name -> - "proper identifier " <> printQualified moduleName name - TokOperator moduleName name -> - "operator " <> printQualified moduleName name - TokSymbolName moduleName name -> - "symbol " <> printQualified moduleName name - TokSymbolArrow style -> - case style of - ASCII -> "(->)" - Unicode -> "(→)" - TokHole name -> - "hole ?" <> name - TokChar raw _ -> - "char literal '" <> raw <> "'" - TokString _ _ -> - "string literal" - TokRawString _ -> - "raw string literal" - TokInt raw _ -> - "int literal " <> raw - TokNumber raw _ -> - "number literal " <> raw - TokLayoutStart _ -> - "start of indented block" - TokLayoutSep _ -> - "new indented block item" - TokLayoutEnd _ -> - "end of indented block" diff --git a/src/PureScript/CST/Layout.purs b/src/PureScript/CST/Layout.purs index 7f9856d..82d38e5 100644 --- a/src/PureScript/CST/Layout.purs +++ b/src/PureScript/CST/Layout.purs @@ -14,7 +14,7 @@ import Data.Foldable (find) import Data.List (List(..), (:)) import Data.Maybe (Maybe(..)) import Data.Tuple (Tuple(..), snd, uncurry) -import PureScript.CST.Types (SourcePos, SourceToken, Token(..)) +import PureScript.CST (SourcePos, SourceToken, Token(..)) type LayoutStack = List (Tuple SourcePos LayoutDelim) diff --git a/src/PureScript/CST/Lexer.purs b/src/PureScript/CST/Lexer.purs index 2567837..a704306 100644 --- a/src/PureScript/CST/Lexer.purs +++ b/src/PureScript/CST/Lexer.purs @@ -37,7 +37,7 @@ import Partial.Unsafe (unsafeCrashWith) import PureScript.CST.Errors (ParseError(..)) import PureScript.CST.Layout (LayoutDelim(..), LayoutStack, insertLayout) import PureScript.CST.TokenStream (TokenStep(..), TokenStream(..), consTokens, step, unwindLayout) -import PureScript.CST.Types (Comment(..), IntValue(..), LineFeed(..), ModuleName(..), SourcePos, SourceStyle(..), Token(..)) +import PureScript.CST (Comment(..), IntValue(..), LineFeed(..), ModuleName(..), SourcePos, SourceStyle(..), Token(..)) infixr 3 alt as <|> diff --git a/src/PureScript/CST/ModuleGraph.purs b/src/PureScript/CST/ModuleGraph.purs index 825c0ab..b18a669 100644 --- a/src/PureScript/CST/ModuleGraph.purs +++ b/src/PureScript/CST/ModuleGraph.purs @@ -17,7 +17,7 @@ import Data.Maybe (Maybe(..), fromMaybe, isJust, maybe) import Data.Set (Set) import Data.Set as Set import Data.Tuple (Tuple(..)) -import PureScript.CST.Types (ImportDecl(..), ModuleHeader(..), ModuleName, Name(..)) +import PureScript.CST (ImportDecl(..), ModuleHeader(..), ModuleName, Name(..)) type Graph a = Map a (Set a) diff --git a/src/PureScript/CST/Parser.purs b/src/PureScript/CST/Parser.purs index bbe90b0..35ca2ea 100644 --- a/src/PureScript/CST/Parser.purs +++ b/src/PureScript/CST/Parser.purs @@ -1,1210 +1,262 @@ module PureScript.CST.Parser - ( Recovered - , parseModule - , parseModuleHeader - , parseModuleBody - , parseImportDecl - , parseDecl - , parseType - , parseExpr - , parseBinder + ( Parser(..) + , ParserState + , ParserResult(..) + , PositionedError + , initialParserState + , fromParserResult + , runParser + , runParser' + , take + , fail + , try + , lookAhead + , many + , optional + , eof + , recover ) where import Prelude -import Prim hiding (Type, Row) -import Control.Alt (alt) -import Control.Lazy (defer) +import Control.Alt (class Alt, (<|>)) +import Control.Lazy (class Lazy) import Data.Array as Array -import Data.Array.NonEmpty (NonEmptyArray) -import Data.Array.NonEmpty as NonEmptyArray import Data.Either (Either(..)) +import Data.Function.Uncurried (Fn2, Fn4, mkFn2, mkFn4, runFn2, runFn4) +import Data.Lazy as Lazy +import Data.List as List import Data.Maybe (Maybe(..)) -import Data.Set (Set) -import Data.Set as Set -import Data.Tuple (Tuple(..), uncurry) -import Prim as P -import PureScript.CST.Errors (ParseError(..), RecoveredError(..)) -import PureScript.CST.Parser.Monad (Parser, eof, lookAhead, many, optional, recover, take, try) -import PureScript.CST.TokenStream (TokenStep(..), TokenStream, currentIndentColumn) +import Data.Tuple (Tuple(..)) +import PureScript.CST.Errors (ParseError(..)) +import PureScript.CST.TokenStream (TokenStep(..), TokenStream) import PureScript.CST.TokenStream as TokenStream -import PureScript.CST.Types (AppSpine(..), Binder(..), ClassFundep(..), DataCtor(..), DataMembers(..), Declaration(..), Delimited, DoStatement(..), Export(..), Expr(..), Fixity(..), FixityOp(..), Foreign(..), Guarded(..), GuardedExpr(..), Ident(..), Import(..), ImportDecl(..), Instance(..), InstanceBinding(..), IntValue(..), Label(..), Labeled(..), LetBinding(..), Module(..), ModuleBody(..), ModuleHeader(..), ModuleName(..), Name(..), OneOrDelimited(..), Operator(..), PatternGuard(..), Prefixed(..), Proper(..), QualifiedName(..), RecordLabeled(..), RecordUpdate(..), Role(..), Row(..), Separated(..), SourceToken, Token(..), Type(..), TypeVarBinding(..), Where(..), Wrapped(..)) - -type Recovered :: (P.Type -> P.Type) -> P.Type -type Recovered f = f RecoveredError - -type RecoveryStrategy f = Parser (Recovered f) -> Parser (Recovered f) - --- Right associated alts are more efficient for the parser interpreter since --- it doesn't have to build and walk a stack for each chain greedily, but it --- can expand them on demand. -infixr 3 alt as <|> - -expectMap :: forall a. (SourceToken -> Maybe a) -> Parser a -expectMap k = take \tok -> - case k tok of - Just a -> - Right a - Nothing -> - Left $ UnexpectedToken tok.value - -expect :: (Token -> Boolean) -> Parser SourceToken -expect pred = expectMap \tok -> - if pred tok.value then Just tok else Nothing - -wrapped :: forall a. Parser SourceToken -> Parser SourceToken -> Parser a -> Parser (Wrapped a) -wrapped openTok closeTok valueParser = do - open <- openTok - value <- valueParser - close <- closeTok - pure $ Wrapped { open, value, close } - -delimited :: forall a. Parser SourceToken -> Parser SourceToken -> Parser SourceToken -> Parser a -> Parser (Delimited a) -delimited openTok closeTok sepTok valueParser = do - open <- openTok - parseEmpty open - <|> parseNonEmpty open - where - parseEmpty :: SourceToken -> Parser (Delimited a) - parseEmpty open = ado - close <- closeTok - in Wrapped { open, value: Nothing, close } - - parseNonEmpty :: SourceToken -> Parser (Delimited a) - parseNonEmpty open = ado - value <- separated sepTok valueParser - close <- closeTok - in Wrapped { open, value: Just value, close } - -separated :: forall a. Parser SourceToken -> Parser a -> Parser (Separated a) -separated sepParser valueParser = ado - head <- valueParser - tail <- many (Tuple <$> sepParser <*> valueParser) - in Separated { head, tail } - -parens :: forall a. Parser a -> Parser (Wrapped a) -parens = wrapped tokLeftParen tokRightParen - -braces :: forall a. Parser a -> Parser (Wrapped a) -braces = wrapped tokLeftBrace tokRightBrace - -layoutStatements :: forall f a. (a -> Array a -> f a) -> Parser a -> Parser (f a) -layoutStatements f statementParser = ado - head <- statementParser - tail <- many (tokLayoutSep *> statementParser) - in f head tail - -layoutNonEmpty :: forall a. Parser a -> Parser (NonEmptyArray a) -layoutNonEmpty statementParser = - tokLayoutStart *> layoutStatements NonEmptyArray.cons' statementParser <* tokLayoutEnd - -layout :: forall a. Parser a -> Parser (Array a) -layout statementParser = - tokLayoutStart *> statements <* tokLayoutEnd - where - statements = - layoutStatements Array.cons statementParser - <|> pure [] - -parseModule :: Parser (Recovered Module) -parseModule = do - header <- parseModuleHeader - body <- parseModuleBody - pure $ Module { header, body } - -parseModuleHeader :: Parser (Recovered ModuleHeader) -parseModuleHeader = do - keyword <- tokKeyword "module" - name <- parseModuleName - exports <- optional $ parens $ separated tokComma parseExport - where_ <- tokKeyword "where" - imports <- tokLayoutStart *> parseModuleImportDecls - pure $ ModuleHeader { keyword, name, exports, where: where_, imports } - -parseModuleBody :: Parser (Recovered ModuleBody) -parseModuleBody = do - decls <- parseModuleDecls <* tokLayoutEnd - Tuple end trailingComments <- eof - pure $ ModuleBody { decls, trailingComments, end } - -parseModuleImportDecls :: Parser (Array (Recovered ImportDecl)) -parseModuleImportDecls = many (parseImportDecl <* (tokLayoutSep <|> lookAhead tokLayoutEnd)) - -parseModuleDecls :: Parser (Array (Recovered Declaration)) -parseModuleDecls = many (recoverDecl parseDecl <* (tokLayoutSep <|> lookAhead tokLayoutEnd)) - -parseExport :: Parser (Recovered Export) -parseExport = - ExportTypeOp <$> tokKeyword "type" <*> parseSymbol - <|> ExportClass <$> tokKeyword "class" <*> parseProper - <|> ExportModule <$> tokKeyword "module" <*> parseModuleName - <|> ExportOp <$> parseSymbol - <|> ExportValue <$> parseIdent - <|> ExportType <$> parseProper <*> optional parseDataMembers - -parseImportDecl :: Parser (Recovered ImportDecl) -parseImportDecl = do - keyword <- tokKeyword "import" - module_ <- parseModuleName - names <- optional $ Tuple <$> optional (tokKeyword "hiding") <*> parens (separated tokComma parseImport) - qualified <- optional $ Tuple <$> tokKeyword "as" <*> parseModuleName - pure $ ImportDecl { keyword, "module": module_, names, qualified } - -parseImport :: Parser (Recovered Import) -parseImport = - ImportOp <$> parseSymbol - <|> ImportType <$> parseProper <*> optional parseDataMembers - <|> ImportTypeOp <$> tokKeyword "type" <*> parseSymbol - <|> ImportClass <$> tokKeyword "class" <*> parseProper - <|> ImportValue <$> parseIdent - -parseDataMembers :: Parser DataMembers -parseDataMembers = - DataAll <$> tokKeySymbol ".." - <|> DataEnumerated <$> delimited tokLeftParen tokRightParen tokComma parseProper - -parseDecl :: Parser (Recovered Declaration) -parseDecl = do - parseDeclData - <|> parseDeclNewtype - <|> parseDeclType - <|> parseDeclClass - <|> parseDeclInstanceChain - <|> parseDeclDerive - <|> parseDeclValue - <|> parseDeclForeign - <|> parseDeclFixity - -parseDeclKindSignature :: SourceToken -> Name Proper -> Parser (Recovered Declaration) -parseDeclKindSignature keyword label = do - separator <- tokDoubleColon - value <- parseType - pure $ DeclKindSignature keyword $ Labeled { label, separator, value } - -parseDeclData :: Parser (Recovered Declaration) -parseDeclData = do - keyword <- tokKeyword "data" - name <- parseProper - parseDeclKindSignature keyword name - <|> parseDeclData1 keyword name - -parseDeclData1 :: SourceToken -> Name Proper -> Parser (Recovered Declaration) -parseDeclData1 keyword name = do - vars <- many parseTypeVarBindingPlain - ctors <- optional (Tuple <$> tokEquals <*> separated tokPipe parseDataCtor) - pure $ DeclData { keyword, name, vars } ctors - -parseDataCtor :: Parser (Recovered DataCtor) -parseDataCtor = ado - name <- parseProper - fields <- many parseTypeAtom - in DataCtor { name, fields } - -parseDeclNewtype :: Parser (Recovered Declaration) -parseDeclNewtype = do - keyword <- tokKeyword "newtype" - name <- parseProper - parseDeclKindSignature keyword name - <|> parseDeclNewtype1 keyword name - -parseDeclNewtype1 :: SourceToken -> Name Proper -> Parser (Recovered Declaration) -parseDeclNewtype1 keyword name = do - vars <- many parseTypeVarBindingPlain - tok <- tokEquals - wrapper <- parseProper - body <- parseTypeAtom - pure $ DeclNewtype { keyword, name, vars } tok wrapper body - -parseDeclType :: Parser (Recovered Declaration) -parseDeclType = do - keyword <- tokKeyword "type" - parseDeclRole keyword - <|> parseDeclType1 keyword - -parseDeclType1 :: SourceToken -> Parser (Recovered Declaration) -parseDeclType1 keyword = do - name <- parseProper - parseDeclKindSignature keyword name - <|> parseDeclType2 keyword name - -parseDeclType2 :: SourceToken -> Name Proper -> Parser (Recovered Declaration) -parseDeclType2 keyword name = do - vars <- many parseTypeVarBindingPlain - tok <- tokEquals - body <- parseType - pure $ DeclType { keyword, name, vars } tok body - -parseDeclRole :: SourceToken -> Parser (Recovered Declaration) -parseDeclRole keyword1 = do - keyword2 <- tokKeyword "role" - name <- parseProper - roles <- many1 parseRole - pure $ DeclRole keyword1 keyword2 name roles - -parseRole :: Parser (Tuple SourceToken Role) -parseRole = - flip Tuple Representational <$> tokKeyword "representational" - <|> flip Tuple Nominal <$> tokKeyword "nominal" - <|> flip Tuple Phantom <$> tokKeyword "phantom" - -parseDeclClass :: Parser (Recovered Declaration) -parseDeclClass = do - keyword <- tokKeyword "class" - parseDeclClassSignature keyword - <|> parseDeclClass1 keyword - -parseDeclClassSignature :: SourceToken -> Parser (Recovered Declaration) -parseDeclClassSignature keyword = do - Tuple label separator <- try $ Tuple <$> parseProper <*> tokDoubleColon - value <- parseType - pure $ DeclKindSignature keyword $ Labeled { label, separator, value } - -parseDeclClass1 :: SourceToken -> Parser (Recovered Declaration) -parseDeclClass1 keyword = do - super <- optional $ try $ Tuple <$> parseClassConstraints parseType5 <*> tokLeftFatArrow - name <- parseProper - vars <- many parseTypeVarBindingPlain - fundeps <- optional $ Tuple <$> tokPipe <*> separated tokComma parseFundep - members <- optional $ Tuple <$> tokKeyword "where" <*> layoutNonEmpty parseClassMember - pure $ DeclClass { keyword, super, name, vars, fundeps } members - -parseClassConstraints :: Parser (Recovered Type) -> Parser (OneOrDelimited (Recovered Type)) -parseClassConstraints parseOneConstraint = do - Many <$> parens (separated tokComma parseType) - <|> One <$> parseOneConstraint - -parseClassMember :: Parser (Labeled (Name Ident) (Recovered Type)) -parseClassMember = do - label <- parseIdent - separator <- tokDoubleColon - value <- parseType - pure $ Labeled { label, separator, value } - -parseFundep :: Parser ClassFundep -parseFundep = - FundepDetermined <$> tokRightArrow <*> many1 parseIdent - <|> FundepDetermines <$> many1 parseIdent <*> tokRightArrow <*> many1 parseIdent - -parseDeclInstanceChain :: Parser (Recovered Declaration) -parseDeclInstanceChain = DeclInstanceChain <$> separated parseInstanceChainSeparator parseInstance - -parseInstanceChainSeparator :: Parser SourceToken -parseInstanceChainSeparator = - tokKeyword "else" - <* optional tokLayoutSep - -parseInstance :: Parser (Recovered Instance) -parseInstance = do - keyword <- tokKeyword "instance" - name <- optional parseInstanceName - constraints <- optional $ try $ Tuple <$> parseClassConstraints parseType3 <*> tokRightFatArrow - className <- parseQualifiedProper - types <- many parseTypeAtom - body <- optional $ Tuple <$> tokKeyword "where" <*> layoutNonEmpty parseInstanceBinding - pure $ Instance - { head: { keyword, name, constraints, className, types } - , body - } - -parseInstanceName :: Parser (Tuple (Name Ident) SourceToken) -parseInstanceName = Tuple <$> parseIdent <*> tokDoubleColon - -parseInstanceBinding :: Parser (Recovered InstanceBinding) -parseInstanceBinding = do - ident <- parseIdent - parseInstanceBindingSignature ident - <|> parseInstanceBindingName ident - -parseInstanceBindingSignature :: Name Ident -> Parser (Recovered InstanceBinding) -parseInstanceBindingSignature label = do - separator <- tokDoubleColon - value <- parseType - pure $ InstanceBindingSignature $ Labeled { label, separator, value } - -parseInstanceBindingName :: Name Ident -> Parser (Recovered InstanceBinding) -parseInstanceBindingName name = do - binders <- many parseBinderAtom - guarded <- parseGuarded (tokEquals) - pure $ InstanceBindingName { name, binders, guarded } - -parseDeclDerive :: Parser (Recovered Declaration) -parseDeclDerive = do - derive_ <- tokKeyword "derive" - newtype_ <- optional $ tokKeyword "newtype" - keyword <- tokKeyword "instance" - name <- optional parseInstanceName - constraints <- optional $ try $ Tuple <$> parseClassConstraints parseType3 <*> tokRightFatArrow - className <- parseQualifiedProper - types <- many parseTypeAtom - pure $ DeclDerive derive_ newtype_ { keyword, name, constraints, className, types } - -parseDeclValue :: Parser (Recovered Declaration) -parseDeclValue = do - ident <- parseIdent - parseDeclSignature ident - <|> parseDeclValue1 ident - -parseDeclSignature :: Name Ident -> Parser (Recovered Declaration) -parseDeclSignature label = do - separator <- tokDoubleColon - value <- parseType - pure $ DeclSignature $ Labeled { label, separator, value } - -parseDeclValue1 :: Name Ident -> Parser (Recovered Declaration) -parseDeclValue1 name = do - binders <- many parseBinderAtom - guarded <- parseGuarded tokEquals - pure $ DeclValue { name, binders, guarded } - -parseDeclForeign :: Parser (Recovered Declaration) -parseDeclForeign = do - keyword1 <- tokKeyword "foreign" - keyword2 <- tokKeyword "import" - foreign_ <- parseForeignData <|> parseForeignKind <|> parseForeignValue - pure $ DeclForeign keyword1 keyword2 foreign_ - -parseForeignData :: Parser (Recovered Foreign) -parseForeignData = do - keyword <- tokKeyword "data" - label <- parseProper - separator <- tokDoubleColon - value <- parseType - pure $ ForeignData keyword $ Labeled { label, separator, value } - -parseForeignKind :: Parser (Recovered Foreign) -parseForeignKind = try $ ForeignKind <$> tokKeyword "kind" <*> parseProper - -parseForeignValue :: Parser (Recovered Foreign) -parseForeignValue = do - label <- parseIdent - separator <- tokDoubleColon - value <- parseType - pure $ ForeignValue $ Labeled { label, separator, value } - -parseDeclFixity :: Parser (Recovered Declaration) -parseDeclFixity = do - keyword <- parseFixityKeyword - prec <- parseSmallInt - operator <- parseFixityOp - pure $ DeclFixity { keyword, prec, operator } - -parseFixityKeyword :: Parser (Tuple SourceToken Fixity) -parseFixityKeyword = - flip Tuple Infix <$> tokKeyword "infix" - <|> flip Tuple Infixl <$> tokKeyword "infixl" - <|> flip Tuple Infixr <$> tokKeyword "infixr" - -parseFixityOp :: Parser FixityOp -parseFixityOp = - FixityType <$> tokKeyword "type" <*> parseQualifiedProper <*> tokKeyword "as" <*> parseOperator - <|> FixityValue <$> parseQualifiedIdentOrProper <*> tokKeyword "as" <*> parseOperator - -parseType :: Parser (Recovered Type) -parseType = defer \_ -> do - ty <- parseType1 - TypeKinded ty <$> tokDoubleColon <*> parseType - <|> pure ty - -parseType1 :: Parser (Recovered Type) -parseType1 = defer \_ -> do - parseForall - <|> parseType2 - -parseType2 :: Parser (Recovered Type) -parseType2 = defer \_ -> do - ty <- parseType3 - TypeArrow ty <$> tokRightArrow <*> parseType1 - <|> TypeConstrained ty <$> tokRightFatArrow <*> parseType1 - <|> pure ty - -parseType3 :: Parser (Recovered Type) -parseType3 = defer \_ -> do - ty <- parseType4 - ops <- many (Tuple <$> parseQualifiedOperator <*> parseType4) - pure case NonEmptyArray.fromArray ops of - Nothing -> ty - Just os -> TypeOp ty os - -parseType4 :: Parser (Recovered Type) -parseType4 = defer \_ -> do - parseTypeNegative <|> parseType5 - -parseType5 :: Parser (Recovered Type) -parseType5 = defer \_ -> do - ty <- parseTypeAtom - args <- many parseTypeAtom - pure case NonEmptyArray.fromArray args of - Nothing -> ty - Just as -> TypeApp ty as - -parseTypeAtom :: Parser (Recovered Type) -parseTypeAtom = defer \_ -> - TypeVar <$> parseIdent - <|> TypeConstructor <$> parseQualifiedProper - <|> uncurry TypeString <$> parseString - <|> uncurry (TypeInt Nothing) <$> parseInt - <|> parseTypeParens - <|> TypeRecord <$> braces parseRow - <|> TypeOpName <$> parseQualifiedSymbol - <|> TypeHole <$> parseHole - <|> TypeWildcard <$> tokUnderscore - <|> TypeArrowName <$> tokSymbolArrow - -parseTypeParens :: Parser (Recovered Type) -parseTypeParens = do - open <- tokLeftParen - parseRowParen open - <|> parseRowTailParen open - <|> parseKindedVar open - <|> parseTypeParen open - <|> parseEmptyRow open - -parseTypeNegative :: Parser (Recovered Type) -parseTypeNegative = do - negative <- tokKeyOperator "-" - uncurry (TypeInt (Just negative)) <$> parseInt - -parseRowParen :: SourceToken -> Parser (Recovered Type) -parseRowParen open = do - Tuple label separator <- try $ Tuple <$> parseLabel <*> tokDoubleColon - value <- parseType - rest <- many (Tuple <$> tokComma <*> parseRowLabel) - tail <- optional $ Tuple <$> tokPipe <*> parseType - close <- tokRightParen - pure $ TypeRow $ Wrapped - { open - , value: Row - { labels: Just $ Separated - { head: Labeled { label, separator, value } - , tail: rest +import PureScript.CST (Comment, LineFeed, SourcePos, SourceToken) + +type PositionedError = + { position :: SourcePos + , error :: ParseError + } + +type ParserState = + { consumed :: Boolean + , errors :: Array PositionedError + , stream :: TokenStream + } + +initialParserState :: TokenStream -> ParserState +initialParserState stream = + { consumed: false + , errors: [] + , stream + } + +appendConsumed :: ParserState -> ParserState -> ParserState +appendConsumed { consumed } state = case consumed, state.consumed of + true, false -> state { consumed = true } + _, _ -> state + +newtype Parser a = Parser + ( forall r + . Fn4 + ParserState + ((Unit -> r) -> r) + (Fn2 ParserState PositionedError r) + (Fn2 ParserState a r) + r + ) + +instance Functor Parser where + map f (Parser p) = Parser + ( mkFn4 \state1 more resume done -> + runFn4 p state1 more resume + ( mkFn2 \state2 a -> + runFn2 done state2 (f a) + ) + ) + +instance Apply Parser where + apply (Parser p1) (Parser p2) = Parser + ( mkFn4 \state1 more resume done -> + runFn4 p1 state1 more resume + ( mkFn2 \state2 f -> + more \_ -> + runFn4 p2 state2 more resume + ( mkFn2 \state3 a -> + runFn2 done (state2 `appendConsumed` state3) (f a) + ) + ) + ) + +instance Applicative Parser where + pure a = Parser + ( mkFn4 \state1 _ _ done -> + runFn2 done state1 a + ) + +instance Bind Parser where + bind (Parser p1) k = Parser + ( mkFn4 \state1 more resume done -> + runFn4 p1 state1 more resume + ( mkFn2 \state2 a -> + more \_ -> do + let (Parser p2) = k a + runFn4 p2 (state1 `appendConsumed` state2) more resume done + ) + ) + +instance Monad Parser + +instance Alt Parser where + alt (Parser k1) (Parser k2) = Parser + ( mkFn4 \state1 more resume done -> do + let + state2 = + if state1.consumed then state1 { consumed = false } + else state1 + runFn4 k1 state2 more + ( mkFn2 \state3 error -> + if state3.consumed then + runFn2 resume state3 error + else + runFn4 k2 state1 more resume done + ) + done + ) + +instance Lazy (Parser a) where + defer k = Parser + ( mkFn4 \state more resume done -> do + let (Parser k) = Lazy.force parser + runFn4 k state more resume done + ) + where + parser = Lazy.defer k + +fail :: forall a. PositionedError -> Parser a +fail error = Parser (mkFn4 \state _ resume _ -> runFn2 resume state error) + +try :: forall a. Parser a -> Parser a +try (Parser p) = Parser + ( mkFn4 \state1 more resume done -> + runFn4 p state1 more + ( mkFn2 \state2 error -> + runFn2 resume (state2 { consumed = state1.consumed }) error + ) + done + ) + +recover :: forall a. (PositionedError -> TokenStream -> Maybe (Tuple a TokenStream)) -> Parser a -> Parser a +recover k (Parser p) = Parser + ( mkFn4 \state1 more resume done -> do + runFn4 p (state1 { consumed = false }) more + ( mkFn2 \state2 error -> + case k error state1.stream of + Nothing -> + runFn2 resume (state2 { consumed = state1.consumed }) error + Just (Tuple a stream) -> + runFn2 done + { consumed: true + , errors: Array.snoc state2.errors error + , stream + } + a + ) + done + ) + +take :: forall a. (SourceToken -> Either ParseError a) -> Parser a +take k = Parser + ( mkFn4 \state _ resume done -> + case TokenStream.step state.stream of + TokenError position error _ _ -> + runFn2 resume state { error, position } + TokenEOF position _ -> + runFn2 resume state { error: UnexpectedEof, position } + TokenCons tok _ nextStream _ -> + case k tok of + Left error -> + runFn2 resume state { error, position: tok.range.start } + Right a -> + runFn2 done + ( state + { consumed = true + , stream = nextStream + } + ) + a + ) + +eof :: Parser (Tuple SourcePos (Array (Comment LineFeed))) +eof = Parser + ( mkFn4 \state _ resume done -> + case TokenStream.step state.stream of + TokenError position error _ _ -> + runFn2 resume state { error, position } + TokenEOF position comments -> + runFn2 done (state { consumed = true }) (Tuple position comments) + TokenCons tok _ _ _ -> + runFn2 resume state + { error: ExpectedEof tok.value + , position: tok.range.start } - , tail - } - , close - } - -parseRowTailParen :: SourceToken -> Parser (Recovered Type) -parseRowTailParen open = do - tail <- Tuple <$> tokPipe <*> parseType - close <- tokRightParen - pure $ TypeRow $ Wrapped - { open - , value: Row { labels: Nothing, tail: Just tail } - , close - } - -parseEmptyRow :: SourceToken -> Parser (Recovered Type) -parseEmptyRow open = do - close <- tokRightParen - pure $ TypeRow $ Wrapped - { open - , value: Row { labels: Nothing, tail: Nothing } - , close - } - -parseKindedVar :: SourceToken -> Parser (Recovered Type) -parseKindedVar open = do - Tuple var separator <- try $ Tuple <$> parens (TypeVar <$> parseIdent) <*> tokDoubleColon - kind <- parseType - close <- tokRightParen - pure $ TypeParens $ Wrapped - { open - , value: TypeKinded (TypeParens var) separator kind - , close - } - -parseTypeParen :: SourceToken -> Parser (Recovered Type) -parseTypeParen open = do - value <- parseType - close <- tokRightParen - pure $ TypeParens $ Wrapped { open, value, close } - -parseRow :: Parser (Recovered Row) -parseRow = defer \_ -> do - labels <- optional $ separated tokComma parseRowLabel - tail <- optional $ Tuple <$> tokPipe <*> parseType - pure $ Row { labels, tail } - -parseRowLabel :: Parser (Labeled (Name Label) (Recovered Type)) -parseRowLabel = do - label <- parseLabel - separator <- tokDoubleColon - value <- parseType - pure $ Labeled { label, separator, value } - -parseForall :: Parser (Recovered Type) -parseForall = defer \_ -> - TypeForall - <$> tokForall - <*> many1 parseTypeVarBindingWithVisibility - <*> tokDot - <*> parseType1 - -parseTypeVarBindingWithVisibility :: Parser (Recovered (TypeVarBinding (Prefixed (Name Ident)))) -parseTypeVarBindingWithVisibility = defer \_ -> parseTypeVarBinding ado - prefix <- optional tokAt - value <- parseIdent - in Prefixed { prefix, value } - -parseTypeVarBindingPlain :: Parser (Recovered (TypeVarBinding (Name Ident))) -parseTypeVarBindingPlain = parseTypeVarBinding parseIdent - -parseTypeVarBinding :: forall a. Parser a -> Parser (Recovered (TypeVarBinding a)) -parseTypeVarBinding parseBindingName = - parseTypeVarKinded parseBindingName - <|> TypeVarName <$> parseBindingName - -parseTypeVarKinded :: forall a. Parser a -> Parser (Recovered (TypeVarBinding a)) -parseTypeVarKinded parseBindingName = TypeVarKinded <$> parens do - label <- parseBindingName - separator <- tokDoubleColon - value <- parseType - pure $ Labeled { label, separator, value } - -parseExpr :: Parser (Recovered Expr) -parseExpr = defer \_ -> do - expr <- parseExpr1 - ExprTyped expr <$> tokDoubleColon <*> parseType - <|> pure expr - -parseExpr1 :: Parser (Recovered Expr) -parseExpr1 = defer \_ -> do - expr <- parseExpr2 - ops <- many (Tuple <$> parseQualifiedOperator <*> parseExpr2) - pure case NonEmptyArray.fromArray ops of - Nothing -> expr - Just os -> ExprOp expr os - -parseExpr2 :: Parser (Recovered Expr) -parseExpr2 = defer \_ -> do - expr <- parseExpr3 - ops <- many (Tuple <$> parseTickExpr <*> parseExpr3) - pure case NonEmptyArray.fromArray ops of - Nothing -> expr - Just os -> ExprInfix expr os - -parseTickExpr :: Parser (Wrapped (Recovered Expr)) -parseTickExpr = do - open <- tokTick - value <- parseTickExpr1 - close <- tokTick - pure $ Wrapped { open, value, close } - -parseTickExpr1 :: Parser (Recovered Expr) -parseTickExpr1 = defer \_ -> do - expr <- parseExpr3 - ops <- many (Tuple <$> parseQualifiedOperator <*> parseExpr3) - pure case NonEmptyArray.fromArray ops of - Nothing -> expr - Just os -> ExprOp expr os - -parseExpr3 :: Parser (Recovered Expr) -parseExpr3 = defer \_ -> do - ExprNegate <$> tokKeyOperator "-" <*> parseExpr3 - <|> parseExpr4 - -parseExpr4 :: Parser (Recovered Expr) -parseExpr4 = defer \_ -> do - expr <- parseExpr5 - args <- many parseExprAppSpine - pure case NonEmptyArray.fromArray args of - Nothing -> expr - Just as -> ExprApp expr as - -parseExpr5 :: Parser (Recovered Expr) -parseExpr5 = defer \_ -> - parseIf - <|> parseLetIn - <|> parseLambda - <|> parseCase - <|> parseDo - <|> parseAdo - <|> parseExpr6 - -parseExprAppSpine :: Parser (Recovered (AppSpine Expr)) -parseExprAppSpine = defer \_ -> - AppType <$> tokAt <*> parseTypeAtom - <|> AppTerm <$> parseExpr5 - -parseIf :: Parser (Recovered Expr) -parseIf = do - keyword <- tokKeyword "if" - cond <- parseExpr - then_ <- tokKeyword "then" - true_ <- parseExpr - else_ <- tokKeyword "else" - false_ <- parseExpr - pure $ ExprIf { keyword, cond, then: then_, true: true_, else: else_, false: false_ } - -parseLetIn :: Parser (Recovered Expr) -parseLetIn = do - keyword <- tokKeyword "let" - bindings <- layoutNonEmpty (recoverLetBinding parseLetBinding) - in_ <- tokKeyword "in" - body <- parseExpr - pure $ ExprLet { keyword, bindings, in: in_, body } - -parseLambda :: Parser (Recovered Expr) -parseLambda = do - symbol <- tokBackslash - binders <- many1 parseBinderAtom - arrow <- tokRightArrow - body <- parseExpr - pure $ ExprLambda { symbol, binders, arrow, body } - -parseCase :: Parser (Recovered Expr) -parseCase = do - keyword <- tokKeyword "case" - head <- separated tokComma parseExpr - of_ <- tokKeyword "of" - branches <- try parseBadSingleCaseBranch <|> parseCaseBranches - pure $ ExprCase { keyword, head, of: of_, branches } - -parseCaseBranches :: Parser (NonEmptyArray (Tuple (Separated (Recovered Binder)) (Recovered Guarded))) -parseCaseBranches = defer \_ -> - layoutNonEmpty $ Tuple <$> separated tokComma parseBinder1 <*> parseGuarded tokRightArrow - -parseBadSingleCaseBranch :: Parser (NonEmptyArray (Tuple (Separated (Recovered Binder)) (Recovered Guarded))) -parseBadSingleCaseBranch = do - binder <- tokLayoutStart *> parseBinder1 - parseBadSingleCaseWhere binder - <|> parseBadSingleCaseGuarded binder - -parseBadSingleCaseWhere :: Recovered Binder -> Parser (NonEmptyArray (Tuple (Separated (Recovered Binder)) (Recovered Guarded))) -parseBadSingleCaseWhere binder = do - arrow <- tokRightArrow - body <- tokLayoutEnd *> parseWhere - pure $ NonEmptyArray.singleton $ Tuple (Separated { head: binder, tail: [] }) $ Unconditional arrow body - -parseBadSingleCaseGuarded :: Recovered Binder -> Parser (NonEmptyArray (Tuple (Separated (Recovered Binder)) (Recovered Guarded))) -parseBadSingleCaseGuarded binder = do - body <- tokLayoutEnd *> parseGuarded tokRightArrow - pure $ NonEmptyArray.singleton $ Tuple (Separated { head: binder, tail: [] }) body - -parseDo :: Parser (Recovered Expr) -parseDo = do - keyword <- tokQualifiedKeyword "do" - statements <- layoutNonEmpty (recoverDoStatement parseDoStatement) - pure $ ExprDo { keyword, statements } - -parseAdo :: Parser (Recovered Expr) -parseAdo = do - keyword <- tokQualifiedKeyword "ado" - statements <- layout (recoverDoStatement parseDoStatement) - in_ <- tokKeyword "in" - result <- parseExpr - pure $ ExprAdo { keyword, statements, in: in_, result } - -parseExpr6 :: Parser (Recovered Expr) -parseExpr6 = defer \_ -> do - expr <- parseExpr7 - parseRecordUpdates expr - <|> pure expr - -parseRecordUpdates :: Recovered Expr -> Parser (Recovered Expr) -parseRecordUpdates expr = do - open <- try $ tokLeftBrace <* lookAhead (parseLabel *> (tokEquals <|> tokLeftBrace)) - value <- separated tokComma parseRecordUpdate - close <- tokRightBrace - pure $ ExprRecordUpdate expr $ Wrapped { open, value, close } - -parseRecordUpdate :: Parser (Recovered RecordUpdate) -parseRecordUpdate = do - label <- parseLabel - parseRecordUpdateLeaf label - <|> parseRecordUpdateBranch label - -parseRecordUpdateLeaf :: Name Label -> Parser (Recovered RecordUpdate) -parseRecordUpdateLeaf label = - RecordUpdateLeaf label - <$> tokEquals - <*> parseExpr - -parseRecordUpdateBranch :: Name Label -> Parser (Recovered RecordUpdate) -parseRecordUpdateBranch label = - RecordUpdateBranch label - <$> braces (separated tokComma parseRecordUpdate) - -parseExpr7 :: Parser (Recovered Expr) -parseExpr7 = defer \_ -> do - expr <- parseExprAtom - parseRecordAccessor expr - <|> pure expr - -parseRecordAccessor :: Recovered Expr -> Parser (Recovered Expr) -parseRecordAccessor expr = do - dot <- tokDot - path <- separated tokDot parseLabel - pure $ ExprRecordAccessor { expr, dot, path } - -parseExprAtom :: Parser (Recovered Expr) -parseExprAtom = defer \_ -> - ExprIdent <$> parseQualifiedIdent - <|> ExprConstructor <$> parseQualifiedProper - <|> ExprOpName <$> parseQualifiedSymbol - <|> ExprSection <$> tokUnderscore - <|> ExprHole <$> parseHole - <|> uncurry ExprString <$> parseString - <|> uncurry ExprChar <$> parseChar - <|> uncurry ExprBoolean <$> parseBoolean - <|> uncurry ExprInt <$> parseInt - <|> uncurry ExprNumber <$> parseNumber - <|> ExprArray <$> delimited tokLeftSquare tokRightSquare tokComma parseExpr - <|> ExprRecord <$> delimited tokLeftBrace tokRightBrace tokComma (parseRecordLabeled parseExpr) - <|> ExprParens <$> parens parseExpr - -parseRecordLabeled :: forall a. Parser a -> Parser (RecordLabeled a) -parseRecordLabeled valueParser = - parseRecordField - <|> RecordPun <$> parseIdent - where - parseRecordField :: Parser (RecordLabeled a) - parseRecordField = - uncurry RecordField - <$> try (Tuple <$> parseLabel <*> tokKeyOperator ":") - <*> valueParser - -parseDoStatement :: Parser (Recovered DoStatement) -parseDoStatement = defer \_ -> - DoLet <$> tokKeyword "let" <*> layoutNonEmpty (recoverLetBinding parseLetBinding) - <|> uncurry DoBind <$> try (Tuple <$> parseBinder <*> tokLeftArrow) <*> parseExpr - <|> DoDiscard <$> parseExpr - -parseLetBinding :: Parser (Recovered LetBinding) -parseLetBinding = defer \_ -> - try parseIdentBinding - <|> LetBindingPattern <$> parseBinder1 <*> tokEquals <*> parseWhere - -parseIdentBinding :: Parser (Recovered LetBinding) -parseIdentBinding = do - ident <- parseIdent - parseLetBindingSignature ident - <|> parseLetBindingName ident - -parseLetBindingSignature :: Name Ident -> Parser (Recovered LetBinding) -parseLetBindingSignature label = do - separator <- tokDoubleColon - value <- parseType - pure $ LetBindingSignature $ Labeled { label, separator, value } - -parseLetBindingName :: Name Ident -> Parser (Recovered LetBinding) -parseLetBindingName name = do - binders <- many parseBinderAtom - guarded <- parseGuarded tokEquals - pure $ LetBindingName { name, binders, guarded } - -parseGuarded :: Parser SourceToken -> Parser (Recovered Guarded) -parseGuarded sepParser = - Unconditional <$> sepParser <*> parseWhere - <|> Guarded <$> many1 parseGuardedExpr - where - parseGuardedExpr :: Parser (Recovered GuardedExpr) - parseGuardedExpr = ado - bar <- tokPipe - patterns <- separated tokComma parsePatternGuard - separator <- sepParser - where_ <- parseWhere - in GuardedExpr { bar, patterns, separator, where: where_ } - - parsePatternGuard :: Parser (Recovered PatternGuard) - parsePatternGuard = ado - binder <- optional (try (Tuple <$> parseBinder <*> tokLeftArrow)) - expr <- parseExpr - in PatternGuard { binder, expr } - -parseWhere :: Parser (Recovered Where) -parseWhere = defer \_ -> do - expr <- parseExpr - bindings <- optional (Tuple <$> tokKeyword "where" <*> layoutNonEmpty (recoverLetBinding parseLetBinding)) - pure $ Where { expr, bindings } - -parseBinder :: Parser (Recovered Binder) -parseBinder = defer \_ -> do - binder <- parseBinder1 - BinderTyped binder <$> tokDoubleColon <*> parseType - <|> pure binder - -parseBinder1 :: Parser (Recovered Binder) -parseBinder1 = defer \_ -> do - binder <- parseBinder2 - ops <- many (Tuple <$> parseQualifiedOperator <*> parseBinder2) - pure case NonEmptyArray.fromArray ops of - Nothing -> binder - Just os -> BinderOp binder os - -parseBinder2 :: Parser (Recovered Binder) -parseBinder2 = defer \_ -> - parseBinderNegative - <|> parseBinderConstructor - <|> parseBinderAtom - -parseBinderNegative :: Parser (Recovered Binder) -parseBinderNegative = do - negative <- tokKeyOperator "-" - uncurry (BinderInt (Just negative)) <$> parseInt - <|> uncurry (BinderNumber (Just negative)) <$> parseNumber - -parseBinderConstructor :: Parser (Recovered Binder) -parseBinderConstructor = defer \_ -> do - name <- parseQualifiedProper - apps <- many parseBinderAtom - pure $ BinderConstructor name apps - -parseBinderAtom :: Parser (Recovered Binder) -parseBinderAtom = defer \_ -> - parseIdentBinder - <|> flip BinderConstructor [] <$> parseQualifiedProper - <|> BinderWildcard <$> tokUnderscore - <|> uncurry BinderString <$> parseString - <|> uncurry BinderChar <$> parseChar - <|> uncurry BinderBoolean <$> parseBoolean - <|> uncurry (BinderInt Nothing) <$> parseInt - <|> uncurry (BinderNumber Nothing) <$> parseNumber - <|> BinderArray <$> delimited tokLeftSquare tokRightSquare tokComma parseBinder - <|> BinderRecord <$> delimited tokLeftBrace tokRightBrace tokComma (parseRecordLabeled parseBinder) - <|> BinderParens <$> parens parseBinder - -parseIdentBinder :: Parser (Recovered Binder) -parseIdentBinder = do - ident <- parseIdent - BinderNamed ident <$> tokAt <*> parseBinderAtom - <|> pure (BinderVar ident) - -parseLabel :: Parser (Name Label) -parseLabel = expectMap case _ of - tok@{ value: TokRawString label } -> - Just $ Name { token: tok, name: Label label } - tok@{ value: TokString _ label } -> - Just $ Name { token: tok, name: Label label } - tok@{ value: TokLowerName Nothing label } -> - Just $ Name { token: tok, name: Label label } - _ -> Nothing - -parseIdent :: Parser (Name Ident) -parseIdent = expectMap case _ of - tok@{ value: TokLowerName Nothing ident } | not $ Set.member ident reservedKeywords -> - Just $ Name { token: tok, name: Ident ident } - _ -> Nothing - -parseQualifiedIdent :: Parser (QualifiedName Ident) -parseQualifiedIdent = expectMap case _ of - tok@{ value: TokLowerName mn ident } | not $ Set.member ident reservedKeywords -> - Just $ QualifiedName { token: tok, "module": mn, name: Ident ident } - _ -> Nothing - -parseProper :: Parser (Name Proper) -parseProper = expectMap case _ of - tok@{ value: TokUpperName Nothing proper } -> - Just $ Name { token: tok, name: Proper proper } - _ -> Nothing - -parseQualifiedProper :: Parser (QualifiedName Proper) -parseQualifiedProper = expectMap case _ of - tok@{ value: TokUpperName mn proper } -> - Just $ QualifiedName { token: tok, "module": mn, name: Proper proper } - _ -> Nothing - -parseQualifiedIdentOrProper :: Parser (QualifiedName (Either Ident Proper)) -parseQualifiedIdentOrProper = expectMap case _ of - tok@{ value: TokLowerName mn ident } -> - Just $ QualifiedName { token: tok, "module": mn, name: Left $ Ident ident } - tok@{ value: TokUpperName mn proper } -> - Just $ QualifiedName { token: tok, "module": mn, name: Right $ Proper proper } - _ -> Nothing - -parseModuleName :: Parser (Name ModuleName) -parseModuleName = expectMap case _ of - tok@{ value: TokUpperName (Just (ModuleName mn)) proper } -> - Just $ Name { token: tok, name: ModuleName $ mn <> "." <> proper } - tok@{ value: TokUpperName Nothing proper } -> - Just $ Name { token: tok, name: ModuleName proper } - _ -> Nothing - -parseOperator :: Parser (Name Operator) -parseOperator = expectMap case _ of - tok@{ value: TokOperator Nothing operator } -> - Just $ Name { token: tok, name: Operator operator } - _ -> Nothing - -parseQualifiedOperator :: Parser (QualifiedName Operator) -parseQualifiedOperator = expectMap case _ of - tok@{ value: TokOperator mn operator } -> - Just $ QualifiedName { token: tok, "module": mn, name: Operator operator } - _ -> Nothing - -parseSymbol :: Parser (Name Operator) -parseSymbol = expectMap case _ of - tok@{ value: TokSymbolName Nothing operator } -> - Just $ Name { token: tok, name: Operator operator } - _ -> Nothing - -parseQualifiedSymbol :: Parser (QualifiedName Operator) -parseQualifiedSymbol = expectMap case _ of - tok@{ value: TokSymbolName mn operator } -> - Just $ QualifiedName { token: tok, "module": mn, name: Operator operator } - _ -> Nothing - -parseHole :: Parser (Name Ident) -parseHole = expectMap case _ of - tok@{ value: TokHole hole } -> - Just $ Name { token: tok, name: Ident hole } - _ -> Nothing - -parseString :: Parser (Tuple SourceToken String) -parseString = expectMap case _ of - tok@{ value: TokString _ str } -> - Just $ Tuple tok str - tok@{ value: TokRawString str } -> - Just $ Tuple tok str - _ -> Nothing - -parseChar :: Parser (Tuple SourceToken Char) -parseChar = expectMap case _ of - tok@{ value: TokChar _ ch } -> - Just $ Tuple tok ch - _ -> Nothing - -parseInt :: Parser (Tuple SourceToken IntValue) -parseInt = expectMap case _ of - tok@{ value: TokInt _ int } -> - Just $ Tuple tok int - _ -> Nothing - -parseSmallInt :: Parser (Tuple SourceToken Int) -parseSmallInt = take case _ of - tok@{ value: TokInt _ (SmallInt val) } -> - Right $ Tuple tok val - { value: TokInt raw _ } -> - Left $ LexIntOutOfRange raw - tok -> - Left $ UnexpectedToken tok.value - -parseNumber :: Parser (Tuple SourceToken Number) -parseNumber = expectMap case _ of - tok@{ value: TokNumber _ number } -> - Just $ Tuple tok number - _ -> Nothing - -parseBoolean :: Parser (Tuple SourceToken Boolean) -parseBoolean = expectMap case _ of - tok@{ value: TokLowerName Nothing "true" } -> - Just $ Tuple tok true - tok@{ value: TokLowerName Nothing "false" } -> - Just $ Tuple tok false - _ -> Nothing - -many1 :: forall a. Parser a -> Parser (NonEmptyArray a) -many1 parser = - NonEmptyArray.cons' - <$> parser - <*> many parser - -tokDoubleColon :: Parser SourceToken -tokDoubleColon = expect case _ of - TokDoubleColon _ -> true - _ -> false - -tokForall :: Parser SourceToken -tokForall = expect case _ of - TokForall _ -> true - _ -> false - -tokRightFatArrow :: Parser SourceToken -tokRightFatArrow = expect case _ of - TokRightFatArrow _ -> true - _ -> false - -tokLeftFatArrow :: Parser SourceToken -tokLeftFatArrow = expect case _ of - TokOperator Nothing name -> name == "<=" || name == "⇐" - _ -> false - -tokRightArrow :: Parser SourceToken -tokRightArrow = expect case _ of - TokRightArrow _ -> true - _ -> false - -tokLeftArrow :: Parser SourceToken -tokLeftArrow = expect case _ of - TokLeftArrow _ -> true - _ -> false - -tokSymbolArrow :: Parser SourceToken -tokSymbolArrow = expect case _ of - TokSymbolArrow _ -> true - _ -> false - -tokKeyword :: String -> Parser SourceToken -tokKeyword kw = expect case _ of - TokLowerName Nothing name -> kw == name - _ -> false - -tokQualifiedKeyword :: String -> Parser SourceToken -tokQualifiedKeyword kw = expect case _ of - TokLowerName _ name -> kw == name - _ -> false - -tokKeyOperator :: String -> Parser SourceToken -tokKeyOperator sym = expect case _ of - TokOperator Nothing name -> sym == name - _ -> false - -tokKeySymbol :: String -> Parser SourceToken -tokKeySymbol sym = expect case _ of - TokSymbolName Nothing name -> sym == name - _ -> false - -tokLayoutStart :: Parser SourceToken -tokLayoutStart = expect case _ of - TokLayoutStart _ -> true - _ -> false - -tokLayoutEnd :: Parser SourceToken -tokLayoutEnd = expect case _ of - TokLayoutEnd _ -> true - _ -> false - -tokLayoutSep :: Parser SourceToken -tokLayoutSep = expect case _ of - TokLayoutSep _ -> true - _ -> false - -tokLeftParen :: Parser SourceToken -tokLeftParen = expect case _ of - TokLeftParen -> true - _ -> false - -tokRightParen :: Parser SourceToken -tokRightParen = expect case _ of - TokRightParen -> true - _ -> false - -tokLeftBrace :: Parser SourceToken -tokLeftBrace = expect case _ of - TokLeftBrace -> true - _ -> false - -tokRightBrace :: Parser SourceToken -tokRightBrace = expect case _ of - TokRightBrace -> true - _ -> false - -tokLeftSquare :: Parser SourceToken -tokLeftSquare = expect case _ of - TokLeftSquare -> true - _ -> false - -tokRightSquare :: Parser SourceToken -tokRightSquare = expect case _ of - TokRightSquare -> true - _ -> false - -tokEquals :: Parser SourceToken -tokEquals = expect case _ of - TokEquals -> true - _ -> false - -tokPipe :: Parser SourceToken -tokPipe = expect case _ of - TokPipe -> true - _ -> false - -tokTick :: Parser SourceToken -tokTick = expect case _ of - TokTick -> true - _ -> false - -tokDot :: Parser SourceToken -tokDot = expect case _ of - TokDot -> true - _ -> false - -tokComma :: Parser SourceToken -tokComma = expect case _ of - TokComma -> true - _ -> false - -tokUnderscore :: Parser SourceToken -tokUnderscore = expect case _ of - TokUnderscore -> true - _ -> false - -tokBackslash :: Parser SourceToken -tokBackslash = expect case _ of - TokBackslash -> true - _ -> false - -tokAt :: Parser SourceToken -tokAt = expect case _ of - TokAt -> true - _ -> false - -reservedKeywords :: Set String -reservedKeywords = Set.fromFoldable - [ "ado" - , "case" - , "class" - , "data" - , "derive" - , "do" - , "else" - , "false" - , "foreign" - , "if" - , "import" - , "in" - , "infix" - , "infixl" - , "infixr" - , "instance" - , "let" - , "module" - , "newtype" - , "of" - , "then" - , "true" - , "type" - , "where" - ] - -recoverIndent :: forall a. (RecoveredError -> a) -> Parser a -> Parser a -recoverIndent mkNode = recover \{ position, error } stream -> do - let - Tuple tokens newStream = recoverTokensWhile - ( \tok indent -> case tok.value of - TokLayoutEnd col -> col > indent - TokLayoutSep col -> col > indent - _ -> true - ) - stream - if Array.null tokens then - Nothing - else - Just (Tuple (mkNode (RecoveredError { position, error, tokens })) newStream) - -recoverTokensWhile :: (SourceToken -> Int -> Boolean) -> TokenStream -> Tuple (Array SourceToken) TokenStream -recoverTokensWhile p initStream = go [] initStream + ) + +lookAhead :: forall a. Parser a -> Parser a +lookAhead (Parser p) = Parser + ( mkFn4 \state1 more resume done -> + runFn4 p state1 more + (mkFn2 \_ error -> runFn2 resume state1 error) + (mkFn2 \_ value -> runFn2 done state1 value) + ) + +many :: forall a. Parser a -> Parser (Array a) +many (Parser p) = Parser + ( mkFn4 \state1 more resume done -> do + let + go = mkFn2 \acc state2 -> do + let + state2' = + if state2.consumed then state2 { consumed = false } + else state2 + runFn4 p state2' more + ( mkFn2 \state3 error -> + if state3.consumed then + runFn2 resume state3 error + else + runFn2 done state2 (Array.reverse (List.toUnfoldable acc)) + ) + ( mkFn2 \state3 value -> + runFn2 go (List.Cons value acc) (state2 `appendConsumed` state3) + ) + runFn2 go List.Nil state1 + ) + +optional :: forall a. Parser a -> Parser (Maybe a) +optional p = Just <$> p <|> pure Nothing + +data Trampoline a = More (Unit -> Trampoline a) | Done a + +runParser' :: forall a. ParserState -> Parser a -> ParserResult a +runParser' state1 (Parser p) = + run $ runFn4 p state1 More + (mkFn2 \state2 error -> Done (ParseFail error state2)) + (mkFn2 \state2 value -> Done (ParseSucc value state2)) where - indent :: Int - indent = currentIndentColumn initStream - - go :: Array SourceToken -> TokenStream -> Tuple (Array SourceToken) TokenStream - go acc stream = case TokenStream.step stream of - TokenError _ _ _ _ -> - Tuple acc stream - TokenEOF _ _ -> - Tuple acc stream - TokenCons tok _ nextStream _ -> - if p tok indent then - go (Array.snoc acc tok) nextStream - else - Tuple acc stream - -recoverDecl :: RecoveryStrategy Declaration -recoverDecl = recoverIndent DeclError - -recoverLetBinding :: RecoveryStrategy LetBinding -recoverLetBinding = recoverIndent LetBindingError - -recoverDoStatement :: RecoveryStrategy DoStatement -recoverDoStatement = recoverIndent DoError + run = case _ of + More k -> run (k unit) + Done a -> a + +runParser :: forall a. TokenStream -> Parser a -> Either PositionedError (Tuple a (Array PositionedError)) +runParser stream = fromParserResult <<< runParser' (initialParserState stream) + +data ParserResult a + = ParseFail PositionedError ParserState + | ParseSucc a ParserState + +fromParserResult :: forall a. ParserResult a -> Either PositionedError (Tuple a (Array PositionedError)) +fromParserResult = case _ of + ParseFail error _ -> + Left error + ParseSucc res { errors } -> + Right (Tuple res errors) diff --git a/src/PureScript/CST/Parser/Monad.purs b/src/PureScript/CST/Parser/Monad.purs deleted file mode 100644 index 48cc336..0000000 --- a/src/PureScript/CST/Parser/Monad.purs +++ /dev/null @@ -1,262 +0,0 @@ -module PureScript.CST.Parser.Monad - ( Parser(..) - , ParserState - , ParserResult(..) - , PositionedError - , initialParserState - , fromParserResult - , runParser - , runParser' - , take - , fail - , try - , lookAhead - , many - , optional - , eof - , recover - ) where - -import Prelude - -import Control.Alt (class Alt, (<|>)) -import Control.Lazy (class Lazy) -import Data.Array as Array -import Data.Either (Either(..)) -import Data.Function.Uncurried (Fn2, Fn4, mkFn2, mkFn4, runFn2, runFn4) -import Data.Lazy as Lazy -import Data.List as List -import Data.Maybe (Maybe(..)) -import Data.Tuple (Tuple(..)) -import PureScript.CST.Errors (ParseError(..)) -import PureScript.CST.TokenStream (TokenStep(..), TokenStream) -import PureScript.CST.TokenStream as TokenStream -import PureScript.CST.Types (Comment, LineFeed, SourcePos, SourceToken) - -type PositionedError = - { position :: SourcePos - , error :: ParseError - } - -type ParserState = - { consumed :: Boolean - , errors :: Array PositionedError - , stream :: TokenStream - } - -initialParserState :: TokenStream -> ParserState -initialParserState stream = - { consumed: false - , errors: [] - , stream - } - -appendConsumed :: ParserState -> ParserState -> ParserState -appendConsumed { consumed } state = case consumed, state.consumed of - true, false -> state { consumed = true } - _, _ -> state - -newtype Parser a = Parser - ( forall r - . Fn4 - ParserState - ((Unit -> r) -> r) - (Fn2 ParserState PositionedError r) - (Fn2 ParserState a r) - r - ) - -instance Functor Parser where - map f (Parser p) = Parser - ( mkFn4 \state1 more resume done -> - runFn4 p state1 more resume - ( mkFn2 \state2 a -> - runFn2 done state2 (f a) - ) - ) - -instance Apply Parser where - apply (Parser p1) (Parser p2) = Parser - ( mkFn4 \state1 more resume done -> - runFn4 p1 state1 more resume - ( mkFn2 \state2 f -> - more \_ -> - runFn4 p2 state2 more resume - ( mkFn2 \state3 a -> - runFn2 done (state2 `appendConsumed` state3) (f a) - ) - ) - ) - -instance Applicative Parser where - pure a = Parser - ( mkFn4 \state1 _ _ done -> - runFn2 done state1 a - ) - -instance Bind Parser where - bind (Parser p1) k = Parser - ( mkFn4 \state1 more resume done -> - runFn4 p1 state1 more resume - ( mkFn2 \state2 a -> - more \_ -> do - let (Parser p2) = k a - runFn4 p2 (state1 `appendConsumed` state2) more resume done - ) - ) - -instance Monad Parser - -instance Alt Parser where - alt (Parser k1) (Parser k2) = Parser - ( mkFn4 \state1 more resume done -> do - let - state2 = - if state1.consumed then state1 { consumed = false } - else state1 - runFn4 k1 state2 more - ( mkFn2 \state3 error -> - if state3.consumed then - runFn2 resume state3 error - else - runFn4 k2 state1 more resume done - ) - done - ) - -instance Lazy (Parser a) where - defer k = Parser - ( mkFn4 \state more resume done -> do - let (Parser k) = Lazy.force parser - runFn4 k state more resume done - ) - where - parser = Lazy.defer k - -fail :: forall a. PositionedError -> Parser a -fail error = Parser (mkFn4 \state _ resume _ -> runFn2 resume state error) - -try :: forall a. Parser a -> Parser a -try (Parser p) = Parser - ( mkFn4 \state1 more resume done -> - runFn4 p state1 more - ( mkFn2 \state2 error -> - runFn2 resume (state2 { consumed = state1.consumed }) error - ) - done - ) - -recover :: forall a. (PositionedError -> TokenStream -> Maybe (Tuple a TokenStream)) -> Parser a -> Parser a -recover k (Parser p) = Parser - ( mkFn4 \state1 more resume done -> do - runFn4 p (state1 { consumed = false }) more - ( mkFn2 \state2 error -> - case k error state1.stream of - Nothing -> - runFn2 resume (state2 { consumed = state1.consumed }) error - Just (Tuple a stream) -> - runFn2 done - { consumed: true - , errors: Array.snoc state2.errors error - , stream - } - a - ) - done - ) - -take :: forall a. (SourceToken -> Either ParseError a) -> Parser a -take k = Parser - ( mkFn4 \state _ resume done -> - case TokenStream.step state.stream of - TokenError position error _ _ -> - runFn2 resume state { error, position } - TokenEOF position _ -> - runFn2 resume state { error: UnexpectedEof, position } - TokenCons tok _ nextStream _ -> - case k tok of - Left error -> - runFn2 resume state { error, position: tok.range.start } - Right a -> - runFn2 done - ( state - { consumed = true - , stream = nextStream - } - ) - a - ) - -eof :: Parser (Tuple SourcePos (Array (Comment LineFeed))) -eof = Parser - ( mkFn4 \state _ resume done -> - case TokenStream.step state.stream of - TokenError position error _ _ -> - runFn2 resume state { error, position } - TokenEOF position comments -> - runFn2 done (state { consumed = true }) (Tuple position comments) - TokenCons tok _ _ _ -> - runFn2 resume state - { error: ExpectedEof tok.value - , position: tok.range.start - } - ) - -lookAhead :: forall a. Parser a -> Parser a -lookAhead (Parser p) = Parser - ( mkFn4 \state1 more resume done -> - runFn4 p state1 more - (mkFn2 \_ error -> runFn2 resume state1 error) - (mkFn2 \_ value -> runFn2 done state1 value) - ) - -many :: forall a. Parser a -> Parser (Array a) -many (Parser p) = Parser - ( mkFn4 \state1 more resume done -> do - let - go = mkFn2 \acc state2 -> do - let - state2' = - if state2.consumed then state2 { consumed = false } - else state2 - runFn4 p state2' more - ( mkFn2 \state3 error -> - if state3.consumed then - runFn2 resume state3 error - else - runFn2 done state2 (Array.reverse (List.toUnfoldable acc)) - ) - ( mkFn2 \state3 value -> - runFn2 go (List.Cons value acc) (state2 `appendConsumed` state3) - ) - runFn2 go List.Nil state1 - ) - -optional :: forall a. Parser a -> Parser (Maybe a) -optional p = Just <$> p <|> pure Nothing - -data Trampoline a = More (Unit -> Trampoline a) | Done a - -runParser' :: forall a. ParserState -> Parser a -> ParserResult a -runParser' state1 (Parser p) = - run $ runFn4 p state1 More - (mkFn2 \state2 error -> Done (ParseFail error state2)) - (mkFn2 \state2 value -> Done (ParseSucc value state2)) - where - run = case _ of - More k -> run (k unit) - Done a -> a - -runParser :: forall a. TokenStream -> Parser a -> Either PositionedError (Tuple a (Array PositionedError)) -runParser stream = fromParserResult <<< runParser' (initialParserState stream) - -data ParserResult a - = ParseFail PositionedError ParserState - | ParseSucc a ParserState - -fromParserResult :: forall a. ParserResult a -> Either PositionedError (Tuple a (Array PositionedError)) -fromParserResult = case _ of - ParseFail error _ -> - Left error - ParseSucc res { errors } -> - Right (Tuple res errors) diff --git a/src/PureScript/CST/Parser/Recovered.purs b/src/PureScript/CST/Parser/Recovered.purs new file mode 100644 index 0000000..7e0f5d8 --- /dev/null +++ b/src/PureScript/CST/Parser/Recovered.purs @@ -0,0 +1,1210 @@ +module PureScript.CST.Parser.Recovered + ( Recovered + , parseModule + , parseModuleHeader + , parseModuleBody + , parseImportDecl + , parseDecl + , parseType + , parseExpr + , parseBinder + ) where + +import Prelude +import Prim hiding (Type, Row) + +import Control.Alt (alt) +import Control.Lazy (defer) +import Data.Array as Array +import Data.Array.NonEmpty (NonEmptyArray) +import Data.Array.NonEmpty as NonEmptyArray +import Data.Either (Either(..)) +import Data.Maybe (Maybe(..)) +import Data.Set (Set) +import Data.Set as Set +import Data.Tuple (Tuple(..), uncurry) +import Prim as P +import PureScript.CST.Errors (ParseError(..), RecoveredError(..)) +import PureScript.CST.Parser (Parser, eof, lookAhead, many, optional, recover, take, try) +import PureScript.CST.TokenStream (TokenStep(..), TokenStream, currentIndentColumn) +import PureScript.CST.TokenStream as TokenStream +import PureScript.CST (AppSpine(..), Binder(..), ClassFundep(..), DataCtor(..), DataMembers(..), Declaration(..), Delimited, DoStatement(..), Export(..), Expr(..), Fixity(..), FixityOp(..), Foreign(..), Guarded(..), GuardedExpr(..), Ident(..), Import(..), ImportDecl(..), Instance(..), InstanceBinding(..), IntValue(..), Label(..), Labeled(..), LetBinding(..), Module(..), ModuleBody(..), ModuleHeader(..), ModuleName(..), Name(..), OneOrDelimited(..), Operator(..), PatternGuard(..), Prefixed(..), Proper(..), QualifiedName(..), RecordLabeled(..), RecordUpdate(..), Role(..), Row(..), Separated(..), SourceToken, Token(..), Type(..), TypeVarBinding(..), Where(..), Wrapped(..)) + +type Recovered :: (P.Type -> P.Type) -> P.Type +type Recovered f = f RecoveredError + +type RecoveryStrategy f = Parser (Recovered f) -> Parser (Recovered f) + +-- Right associated alts are more efficient for the parser interpreter since +-- it doesn't have to build and walk a stack for each chain greedily, but it +-- can expand them on demand. +infixr 3 alt as <|> + +expectMap :: forall a. (SourceToken -> Maybe a) -> Parser a +expectMap k = take \tok -> + case k tok of + Just a -> + Right a + Nothing -> + Left $ UnexpectedToken tok.value + +expect :: (Token -> Boolean) -> Parser SourceToken +expect pred = expectMap \tok -> + if pred tok.value then Just tok else Nothing + +wrapped :: forall a. Parser SourceToken -> Parser SourceToken -> Parser a -> Parser (Wrapped a) +wrapped openTok closeTok valueParser = do + open <- openTok + value <- valueParser + close <- closeTok + pure $ Wrapped { open, value, close } + +delimited :: forall a. Parser SourceToken -> Parser SourceToken -> Parser SourceToken -> Parser a -> Parser (Delimited a) +delimited openTok closeTok sepTok valueParser = do + open <- openTok + parseEmpty open + <|> parseNonEmpty open + where + parseEmpty :: SourceToken -> Parser (Delimited a) + parseEmpty open = ado + close <- closeTok + in Wrapped { open, value: Nothing, close } + + parseNonEmpty :: SourceToken -> Parser (Delimited a) + parseNonEmpty open = ado + value <- separated sepTok valueParser + close <- closeTok + in Wrapped { open, value: Just value, close } + +separated :: forall a. Parser SourceToken -> Parser a -> Parser (Separated a) +separated sepParser valueParser = ado + head <- valueParser + tail <- many (Tuple <$> sepParser <*> valueParser) + in Separated { head, tail } + +parens :: forall a. Parser a -> Parser (Wrapped a) +parens = wrapped tokLeftParen tokRightParen + +braces :: forall a. Parser a -> Parser (Wrapped a) +braces = wrapped tokLeftBrace tokRightBrace + +layoutStatements :: forall f a. (a -> Array a -> f a) -> Parser a -> Parser (f a) +layoutStatements f statementParser = ado + head <- statementParser + tail <- many (tokLayoutSep *> statementParser) + in f head tail + +layoutNonEmpty :: forall a. Parser a -> Parser (NonEmptyArray a) +layoutNonEmpty statementParser = + tokLayoutStart *> layoutStatements NonEmptyArray.cons' statementParser <* tokLayoutEnd + +layout :: forall a. Parser a -> Parser (Array a) +layout statementParser = + tokLayoutStart *> statements <* tokLayoutEnd + where + statements = + layoutStatements Array.cons statementParser + <|> pure [] + +parseModule :: Parser (Recovered Module) +parseModule = do + header <- parseModuleHeader + body <- parseModuleBody + pure $ Module { header, body } + +parseModuleHeader :: Parser (Recovered ModuleHeader) +parseModuleHeader = do + keyword <- tokKeyword "module" + name <- parseModuleName + exports <- optional $ parens $ separated tokComma parseExport + where_ <- tokKeyword "where" + imports <- tokLayoutStart *> parseModuleImportDecls + pure $ ModuleHeader { keyword, name, exports, where: where_, imports } + +parseModuleBody :: Parser (Recovered ModuleBody) +parseModuleBody = do + decls <- parseModuleDecls <* tokLayoutEnd + Tuple end trailingComments <- eof + pure $ ModuleBody { decls, trailingComments, end } + +parseModuleImportDecls :: Parser (Array (Recovered ImportDecl)) +parseModuleImportDecls = many (parseImportDecl <* (tokLayoutSep <|> lookAhead tokLayoutEnd)) + +parseModuleDecls :: Parser (Array (Recovered Declaration)) +parseModuleDecls = many (recoverDecl parseDecl <* (tokLayoutSep <|> lookAhead tokLayoutEnd)) + +parseExport :: Parser (Recovered Export) +parseExport = + ExportTypeOp <$> tokKeyword "type" <*> parseSymbol + <|> ExportClass <$> tokKeyword "class" <*> parseProper + <|> ExportModule <$> tokKeyword "module" <*> parseModuleName + <|> ExportOp <$> parseSymbol + <|> ExportValue <$> parseIdent + <|> ExportType <$> parseProper <*> optional parseDataMembers + +parseImportDecl :: Parser (Recovered ImportDecl) +parseImportDecl = do + keyword <- tokKeyword "import" + module_ <- parseModuleName + names <- optional $ Tuple <$> optional (tokKeyword "hiding") <*> parens (separated tokComma parseImport) + qualified <- optional $ Tuple <$> tokKeyword "as" <*> parseModuleName + pure $ ImportDecl { keyword, "module": module_, names, qualified } + +parseImport :: Parser (Recovered Import) +parseImport = + ImportOp <$> parseSymbol + <|> ImportType <$> parseProper <*> optional parseDataMembers + <|> ImportTypeOp <$> tokKeyword "type" <*> parseSymbol + <|> ImportClass <$> tokKeyword "class" <*> parseProper + <|> ImportValue <$> parseIdent + +parseDataMembers :: Parser DataMembers +parseDataMembers = + DataAll <$> tokKeySymbol ".." + <|> DataEnumerated <$> delimited tokLeftParen tokRightParen tokComma parseProper + +parseDecl :: Parser (Recovered Declaration) +parseDecl = do + parseDeclData + <|> parseDeclNewtype + <|> parseDeclType + <|> parseDeclClass + <|> parseDeclInstanceChain + <|> parseDeclDerive + <|> parseDeclValue + <|> parseDeclForeign + <|> parseDeclFixity + +parseDeclKindSignature :: SourceToken -> Name Proper -> Parser (Recovered Declaration) +parseDeclKindSignature keyword label = do + separator <- tokDoubleColon + value <- parseType + pure $ DeclKindSignature keyword $ Labeled { label, separator, value } + +parseDeclData :: Parser (Recovered Declaration) +parseDeclData = do + keyword <- tokKeyword "data" + name <- parseProper + parseDeclKindSignature keyword name + <|> parseDeclData1 keyword name + +parseDeclData1 :: SourceToken -> Name Proper -> Parser (Recovered Declaration) +parseDeclData1 keyword name = do + vars <- many parseTypeVarBindingPlain + ctors <- optional (Tuple <$> tokEquals <*> separated tokPipe parseDataCtor) + pure $ DeclData { keyword, name, vars } ctors + +parseDataCtor :: Parser (Recovered DataCtor) +parseDataCtor = ado + name <- parseProper + fields <- many parseTypeAtom + in DataCtor { name, fields } + +parseDeclNewtype :: Parser (Recovered Declaration) +parseDeclNewtype = do + keyword <- tokKeyword "newtype" + name <- parseProper + parseDeclKindSignature keyword name + <|> parseDeclNewtype1 keyword name + +parseDeclNewtype1 :: SourceToken -> Name Proper -> Parser (Recovered Declaration) +parseDeclNewtype1 keyword name = do + vars <- many parseTypeVarBindingPlain + tok <- tokEquals + wrapper <- parseProper + body <- parseTypeAtom + pure $ DeclNewtype { keyword, name, vars } tok wrapper body + +parseDeclType :: Parser (Recovered Declaration) +parseDeclType = do + keyword <- tokKeyword "type" + parseDeclRole keyword + <|> parseDeclType1 keyword + +parseDeclType1 :: SourceToken -> Parser (Recovered Declaration) +parseDeclType1 keyword = do + name <- parseProper + parseDeclKindSignature keyword name + <|> parseDeclType2 keyword name + +parseDeclType2 :: SourceToken -> Name Proper -> Parser (Recovered Declaration) +parseDeclType2 keyword name = do + vars <- many parseTypeVarBindingPlain + tok <- tokEquals + body <- parseType + pure $ DeclType { keyword, name, vars } tok body + +parseDeclRole :: SourceToken -> Parser (Recovered Declaration) +parseDeclRole keyword1 = do + keyword2 <- tokKeyword "role" + name <- parseProper + roles <- many1 parseRole + pure $ DeclRole keyword1 keyword2 name roles + +parseRole :: Parser (Tuple SourceToken Role) +parseRole = + flip Tuple Representational <$> tokKeyword "representational" + <|> flip Tuple Nominal <$> tokKeyword "nominal" + <|> flip Tuple Phantom <$> tokKeyword "phantom" + +parseDeclClass :: Parser (Recovered Declaration) +parseDeclClass = do + keyword <- tokKeyword "class" + parseDeclClassSignature keyword + <|> parseDeclClass1 keyword + +parseDeclClassSignature :: SourceToken -> Parser (Recovered Declaration) +parseDeclClassSignature keyword = do + Tuple label separator <- try $ Tuple <$> parseProper <*> tokDoubleColon + value <- parseType + pure $ DeclKindSignature keyword $ Labeled { label, separator, value } + +parseDeclClass1 :: SourceToken -> Parser (Recovered Declaration) +parseDeclClass1 keyword = do + super <- optional $ try $ Tuple <$> parseClassConstraints parseType5 <*> tokLeftFatArrow + name <- parseProper + vars <- many parseTypeVarBindingPlain + fundeps <- optional $ Tuple <$> tokPipe <*> separated tokComma parseFundep + members <- optional $ Tuple <$> tokKeyword "where" <*> layoutNonEmpty parseClassMember + pure $ DeclClass { keyword, super, name, vars, fundeps } members + +parseClassConstraints :: Parser (Recovered Type) -> Parser (OneOrDelimited (Recovered Type)) +parseClassConstraints parseOneConstraint = do + Many <$> parens (separated tokComma parseType) + <|> One <$> parseOneConstraint + +parseClassMember :: Parser (Labeled (Name Ident) (Recovered Type)) +parseClassMember = do + label <- parseIdent + separator <- tokDoubleColon + value <- parseType + pure $ Labeled { label, separator, value } + +parseFundep :: Parser ClassFundep +parseFundep = + FundepDetermined <$> tokRightArrow <*> many1 parseIdent + <|> FundepDetermines <$> many1 parseIdent <*> tokRightArrow <*> many1 parseIdent + +parseDeclInstanceChain :: Parser (Recovered Declaration) +parseDeclInstanceChain = DeclInstanceChain <$> separated parseInstanceChainSeparator parseInstance + +parseInstanceChainSeparator :: Parser SourceToken +parseInstanceChainSeparator = + tokKeyword "else" + <* optional tokLayoutSep + +parseInstance :: Parser (Recovered Instance) +parseInstance = do + keyword <- tokKeyword "instance" + name <- optional parseInstanceName + constraints <- optional $ try $ Tuple <$> parseClassConstraints parseType3 <*> tokRightFatArrow + className <- parseQualifiedProper + types <- many parseTypeAtom + body <- optional $ Tuple <$> tokKeyword "where" <*> layoutNonEmpty parseInstanceBinding + pure $ Instance + { head: { keyword, name, constraints, className, types } + , body + } + +parseInstanceName :: Parser (Tuple (Name Ident) SourceToken) +parseInstanceName = Tuple <$> parseIdent <*> tokDoubleColon + +parseInstanceBinding :: Parser (Recovered InstanceBinding) +parseInstanceBinding = do + ident <- parseIdent + parseInstanceBindingSignature ident + <|> parseInstanceBindingName ident + +parseInstanceBindingSignature :: Name Ident -> Parser (Recovered InstanceBinding) +parseInstanceBindingSignature label = do + separator <- tokDoubleColon + value <- parseType + pure $ InstanceBindingSignature $ Labeled { label, separator, value } + +parseInstanceBindingName :: Name Ident -> Parser (Recovered InstanceBinding) +parseInstanceBindingName name = do + binders <- many parseBinderAtom + guarded <- parseGuarded (tokEquals) + pure $ InstanceBindingName { name, binders, guarded } + +parseDeclDerive :: Parser (Recovered Declaration) +parseDeclDerive = do + derive_ <- tokKeyword "derive" + newtype_ <- optional $ tokKeyword "newtype" + keyword <- tokKeyword "instance" + name <- optional parseInstanceName + constraints <- optional $ try $ Tuple <$> parseClassConstraints parseType3 <*> tokRightFatArrow + className <- parseQualifiedProper + types <- many parseTypeAtom + pure $ DeclDerive derive_ newtype_ { keyword, name, constraints, className, types } + +parseDeclValue :: Parser (Recovered Declaration) +parseDeclValue = do + ident <- parseIdent + parseDeclSignature ident + <|> parseDeclValue1 ident + +parseDeclSignature :: Name Ident -> Parser (Recovered Declaration) +parseDeclSignature label = do + separator <- tokDoubleColon + value <- parseType + pure $ DeclSignature $ Labeled { label, separator, value } + +parseDeclValue1 :: Name Ident -> Parser (Recovered Declaration) +parseDeclValue1 name = do + binders <- many parseBinderAtom + guarded <- parseGuarded tokEquals + pure $ DeclValue { name, binders, guarded } + +parseDeclForeign :: Parser (Recovered Declaration) +parseDeclForeign = do + keyword1 <- tokKeyword "foreign" + keyword2 <- tokKeyword "import" + foreign_ <- parseForeignData <|> parseForeignKind <|> parseForeignValue + pure $ DeclForeign keyword1 keyword2 foreign_ + +parseForeignData :: Parser (Recovered Foreign) +parseForeignData = do + keyword <- tokKeyword "data" + label <- parseProper + separator <- tokDoubleColon + value <- parseType + pure $ ForeignData keyword $ Labeled { label, separator, value } + +parseForeignKind :: Parser (Recovered Foreign) +parseForeignKind = try $ ForeignKind <$> tokKeyword "kind" <*> parseProper + +parseForeignValue :: Parser (Recovered Foreign) +parseForeignValue = do + label <- parseIdent + separator <- tokDoubleColon + value <- parseType + pure $ ForeignValue $ Labeled { label, separator, value } + +parseDeclFixity :: Parser (Recovered Declaration) +parseDeclFixity = do + keyword <- parseFixityKeyword + prec <- parseSmallInt + operator <- parseFixityOp + pure $ DeclFixity { keyword, prec, operator } + +parseFixityKeyword :: Parser (Tuple SourceToken Fixity) +parseFixityKeyword = + flip Tuple Infix <$> tokKeyword "infix" + <|> flip Tuple Infixl <$> tokKeyword "infixl" + <|> flip Tuple Infixr <$> tokKeyword "infixr" + +parseFixityOp :: Parser FixityOp +parseFixityOp = + FixityType <$> tokKeyword "type" <*> parseQualifiedProper <*> tokKeyword "as" <*> parseOperator + <|> FixityValue <$> parseQualifiedIdentOrProper <*> tokKeyword "as" <*> parseOperator + +parseType :: Parser (Recovered Type) +parseType = defer \_ -> do + ty <- parseType1 + TypeKinded ty <$> tokDoubleColon <*> parseType + <|> pure ty + +parseType1 :: Parser (Recovered Type) +parseType1 = defer \_ -> do + parseForall + <|> parseType2 + +parseType2 :: Parser (Recovered Type) +parseType2 = defer \_ -> do + ty <- parseType3 + TypeArrow ty <$> tokRightArrow <*> parseType1 + <|> TypeConstrained ty <$> tokRightFatArrow <*> parseType1 + <|> pure ty + +parseType3 :: Parser (Recovered Type) +parseType3 = defer \_ -> do + ty <- parseType4 + ops <- many (Tuple <$> parseQualifiedOperator <*> parseType4) + pure case NonEmptyArray.fromArray ops of + Nothing -> ty + Just os -> TypeOp ty os + +parseType4 :: Parser (Recovered Type) +parseType4 = defer \_ -> do + parseTypeNegative <|> parseType5 + +parseType5 :: Parser (Recovered Type) +parseType5 = defer \_ -> do + ty <- parseTypeAtom + args <- many parseTypeAtom + pure case NonEmptyArray.fromArray args of + Nothing -> ty + Just as -> TypeApp ty as + +parseTypeAtom :: Parser (Recovered Type) +parseTypeAtom = defer \_ -> + TypeVar <$> parseIdent + <|> TypeConstructor <$> parseQualifiedProper + <|> uncurry TypeString <$> parseString + <|> uncurry (TypeInt Nothing) <$> parseInt + <|> parseTypeParens + <|> TypeRecord <$> braces parseRow + <|> TypeOpName <$> parseQualifiedSymbol + <|> TypeHole <$> parseHole + <|> TypeWildcard <$> tokUnderscore + <|> TypeArrowName <$> tokSymbolArrow + +parseTypeParens :: Parser (Recovered Type) +parseTypeParens = do + open <- tokLeftParen + parseRowParen open + <|> parseRowTailParen open + <|> parseKindedVar open + <|> parseTypeParen open + <|> parseEmptyRow open + +parseTypeNegative :: Parser (Recovered Type) +parseTypeNegative = do + negative <- tokKeyOperator "-" + uncurry (TypeInt (Just negative)) <$> parseInt + +parseRowParen :: SourceToken -> Parser (Recovered Type) +parseRowParen open = do + Tuple label separator <- try $ Tuple <$> parseLabel <*> tokDoubleColon + value <- parseType + rest <- many (Tuple <$> tokComma <*> parseRowLabel) + tail <- optional $ Tuple <$> tokPipe <*> parseType + close <- tokRightParen + pure $ TypeRow $ Wrapped + { open + , value: Row + { labels: Just $ Separated + { head: Labeled { label, separator, value } + , tail: rest + } + , tail + } + , close + } + +parseRowTailParen :: SourceToken -> Parser (Recovered Type) +parseRowTailParen open = do + tail <- Tuple <$> tokPipe <*> parseType + close <- tokRightParen + pure $ TypeRow $ Wrapped + { open + , value: Row { labels: Nothing, tail: Just tail } + , close + } + +parseEmptyRow :: SourceToken -> Parser (Recovered Type) +parseEmptyRow open = do + close <- tokRightParen + pure $ TypeRow $ Wrapped + { open + , value: Row { labels: Nothing, tail: Nothing } + , close + } + +parseKindedVar :: SourceToken -> Parser (Recovered Type) +parseKindedVar open = do + Tuple var separator <- try $ Tuple <$> parens (TypeVar <$> parseIdent) <*> tokDoubleColon + kind <- parseType + close <- tokRightParen + pure $ TypeParens $ Wrapped + { open + , value: TypeKinded (TypeParens var) separator kind + , close + } + +parseTypeParen :: SourceToken -> Parser (Recovered Type) +parseTypeParen open = do + value <- parseType + close <- tokRightParen + pure $ TypeParens $ Wrapped { open, value, close } + +parseRow :: Parser (Recovered Row) +parseRow = defer \_ -> do + labels <- optional $ separated tokComma parseRowLabel + tail <- optional $ Tuple <$> tokPipe <*> parseType + pure $ Row { labels, tail } + +parseRowLabel :: Parser (Labeled (Name Label) (Recovered Type)) +parseRowLabel = do + label <- parseLabel + separator <- tokDoubleColon + value <- parseType + pure $ Labeled { label, separator, value } + +parseForall :: Parser (Recovered Type) +parseForall = defer \_ -> + TypeForall + <$> tokForall + <*> many1 parseTypeVarBindingWithVisibility + <*> tokDot + <*> parseType1 + +parseTypeVarBindingWithVisibility :: Parser (Recovered (TypeVarBinding (Prefixed (Name Ident)))) +parseTypeVarBindingWithVisibility = defer \_ -> parseTypeVarBinding ado + prefix <- optional tokAt + value <- parseIdent + in Prefixed { prefix, value } + +parseTypeVarBindingPlain :: Parser (Recovered (TypeVarBinding (Name Ident))) +parseTypeVarBindingPlain = parseTypeVarBinding parseIdent + +parseTypeVarBinding :: forall a. Parser a -> Parser (Recovered (TypeVarBinding a)) +parseTypeVarBinding parseBindingName = + parseTypeVarKinded parseBindingName + <|> TypeVarName <$> parseBindingName + +parseTypeVarKinded :: forall a. Parser a -> Parser (Recovered (TypeVarBinding a)) +parseTypeVarKinded parseBindingName = TypeVarKinded <$> parens do + label <- parseBindingName + separator <- tokDoubleColon + value <- parseType + pure $ Labeled { label, separator, value } + +parseExpr :: Parser (Recovered Expr) +parseExpr = defer \_ -> do + expr <- parseExpr1 + ExprTyped expr <$> tokDoubleColon <*> parseType + <|> pure expr + +parseExpr1 :: Parser (Recovered Expr) +parseExpr1 = defer \_ -> do + expr <- parseExpr2 + ops <- many (Tuple <$> parseQualifiedOperator <*> parseExpr2) + pure case NonEmptyArray.fromArray ops of + Nothing -> expr + Just os -> ExprOp expr os + +parseExpr2 :: Parser (Recovered Expr) +parseExpr2 = defer \_ -> do + expr <- parseExpr3 + ops <- many (Tuple <$> parseTickExpr <*> parseExpr3) + pure case NonEmptyArray.fromArray ops of + Nothing -> expr + Just os -> ExprInfix expr os + +parseTickExpr :: Parser (Wrapped (Recovered Expr)) +parseTickExpr = do + open <- tokTick + value <- parseTickExpr1 + close <- tokTick + pure $ Wrapped { open, value, close } + +parseTickExpr1 :: Parser (Recovered Expr) +parseTickExpr1 = defer \_ -> do + expr <- parseExpr3 + ops <- many (Tuple <$> parseQualifiedOperator <*> parseExpr3) + pure case NonEmptyArray.fromArray ops of + Nothing -> expr + Just os -> ExprOp expr os + +parseExpr3 :: Parser (Recovered Expr) +parseExpr3 = defer \_ -> do + ExprNegate <$> tokKeyOperator "-" <*> parseExpr3 + <|> parseExpr4 + +parseExpr4 :: Parser (Recovered Expr) +parseExpr4 = defer \_ -> do + expr <- parseExpr5 + args <- many parseExprAppSpine + pure case NonEmptyArray.fromArray args of + Nothing -> expr + Just as -> ExprApp expr as + +parseExpr5 :: Parser (Recovered Expr) +parseExpr5 = defer \_ -> + parseIf + <|> parseLetIn + <|> parseLambda + <|> parseCase + <|> parseDo + <|> parseAdo + <|> parseExpr6 + +parseExprAppSpine :: Parser (Recovered (AppSpine Expr)) +parseExprAppSpine = defer \_ -> + AppType <$> tokAt <*> parseTypeAtom + <|> AppTerm <$> parseExpr5 + +parseIf :: Parser (Recovered Expr) +parseIf = do + keyword <- tokKeyword "if" + cond <- parseExpr + then_ <- tokKeyword "then" + true_ <- parseExpr + else_ <- tokKeyword "else" + false_ <- parseExpr + pure $ ExprIf { keyword, cond, then: then_, true: true_, else: else_, false: false_ } + +parseLetIn :: Parser (Recovered Expr) +parseLetIn = do + keyword <- tokKeyword "let" + bindings <- layoutNonEmpty (recoverLetBinding parseLetBinding) + in_ <- tokKeyword "in" + body <- parseExpr + pure $ ExprLet { keyword, bindings, in: in_, body } + +parseLambda :: Parser (Recovered Expr) +parseLambda = do + symbol <- tokBackslash + binders <- many1 parseBinderAtom + arrow <- tokRightArrow + body <- parseExpr + pure $ ExprLambda { symbol, binders, arrow, body } + +parseCase :: Parser (Recovered Expr) +parseCase = do + keyword <- tokKeyword "case" + head <- separated tokComma parseExpr + of_ <- tokKeyword "of" + branches <- try parseBadSingleCaseBranch <|> parseCaseBranches + pure $ ExprCase { keyword, head, of: of_, branches } + +parseCaseBranches :: Parser (NonEmptyArray (Tuple (Separated (Recovered Binder)) (Recovered Guarded))) +parseCaseBranches = defer \_ -> + layoutNonEmpty $ Tuple <$> separated tokComma parseBinder1 <*> parseGuarded tokRightArrow + +parseBadSingleCaseBranch :: Parser (NonEmptyArray (Tuple (Separated (Recovered Binder)) (Recovered Guarded))) +parseBadSingleCaseBranch = do + binder <- tokLayoutStart *> parseBinder1 + parseBadSingleCaseWhere binder + <|> parseBadSingleCaseGuarded binder + +parseBadSingleCaseWhere :: Recovered Binder -> Parser (NonEmptyArray (Tuple (Separated (Recovered Binder)) (Recovered Guarded))) +parseBadSingleCaseWhere binder = do + arrow <- tokRightArrow + body <- tokLayoutEnd *> parseWhere + pure $ NonEmptyArray.singleton $ Tuple (Separated { head: binder, tail: [] }) $ Unconditional arrow body + +parseBadSingleCaseGuarded :: Recovered Binder -> Parser (NonEmptyArray (Tuple (Separated (Recovered Binder)) (Recovered Guarded))) +parseBadSingleCaseGuarded binder = do + body <- tokLayoutEnd *> parseGuarded tokRightArrow + pure $ NonEmptyArray.singleton $ Tuple (Separated { head: binder, tail: [] }) body + +parseDo :: Parser (Recovered Expr) +parseDo = do + keyword <- tokQualifiedKeyword "do" + statements <- layoutNonEmpty (recoverDoStatement parseDoStatement) + pure $ ExprDo { keyword, statements } + +parseAdo :: Parser (Recovered Expr) +parseAdo = do + keyword <- tokQualifiedKeyword "ado" + statements <- layout (recoverDoStatement parseDoStatement) + in_ <- tokKeyword "in" + result <- parseExpr + pure $ ExprAdo { keyword, statements, in: in_, result } + +parseExpr6 :: Parser (Recovered Expr) +parseExpr6 = defer \_ -> do + expr <- parseExpr7 + parseRecordUpdates expr + <|> pure expr + +parseRecordUpdates :: Recovered Expr -> Parser (Recovered Expr) +parseRecordUpdates expr = do + open <- try $ tokLeftBrace <* lookAhead (parseLabel *> (tokEquals <|> tokLeftBrace)) + value <- separated tokComma parseRecordUpdate + close <- tokRightBrace + pure $ ExprRecordUpdate expr $ Wrapped { open, value, close } + +parseRecordUpdate :: Parser (Recovered RecordUpdate) +parseRecordUpdate = do + label <- parseLabel + parseRecordUpdateLeaf label + <|> parseRecordUpdateBranch label + +parseRecordUpdateLeaf :: Name Label -> Parser (Recovered RecordUpdate) +parseRecordUpdateLeaf label = + RecordUpdateLeaf label + <$> tokEquals + <*> parseExpr + +parseRecordUpdateBranch :: Name Label -> Parser (Recovered RecordUpdate) +parseRecordUpdateBranch label = + RecordUpdateBranch label + <$> braces (separated tokComma parseRecordUpdate) + +parseExpr7 :: Parser (Recovered Expr) +parseExpr7 = defer \_ -> do + expr <- parseExprAtom + parseRecordAccessor expr + <|> pure expr + +parseRecordAccessor :: Recovered Expr -> Parser (Recovered Expr) +parseRecordAccessor expr = do + dot <- tokDot + path <- separated tokDot parseLabel + pure $ ExprRecordAccessor { expr, dot, path } + +parseExprAtom :: Parser (Recovered Expr) +parseExprAtom = defer \_ -> + ExprIdent <$> parseQualifiedIdent + <|> ExprConstructor <$> parseQualifiedProper + <|> ExprOpName <$> parseQualifiedSymbol + <|> ExprSection <$> tokUnderscore + <|> ExprHole <$> parseHole + <|> uncurry ExprString <$> parseString + <|> uncurry ExprChar <$> parseChar + <|> uncurry ExprBoolean <$> parseBoolean + <|> uncurry ExprInt <$> parseInt + <|> uncurry ExprNumber <$> parseNumber + <|> ExprArray <$> delimited tokLeftSquare tokRightSquare tokComma parseExpr + <|> ExprRecord <$> delimited tokLeftBrace tokRightBrace tokComma (parseRecordLabeled parseExpr) + <|> ExprParens <$> parens parseExpr + +parseRecordLabeled :: forall a. Parser a -> Parser (RecordLabeled a) +parseRecordLabeled valueParser = + parseRecordField + <|> RecordPun <$> parseIdent + where + parseRecordField :: Parser (RecordLabeled a) + parseRecordField = + uncurry RecordField + <$> try (Tuple <$> parseLabel <*> tokKeyOperator ":") + <*> valueParser + +parseDoStatement :: Parser (Recovered DoStatement) +parseDoStatement = defer \_ -> + DoLet <$> tokKeyword "let" <*> layoutNonEmpty (recoverLetBinding parseLetBinding) + <|> uncurry DoBind <$> try (Tuple <$> parseBinder <*> tokLeftArrow) <*> parseExpr + <|> DoDiscard <$> parseExpr + +parseLetBinding :: Parser (Recovered LetBinding) +parseLetBinding = defer \_ -> + try parseIdentBinding + <|> LetBindingPattern <$> parseBinder1 <*> tokEquals <*> parseWhere + +parseIdentBinding :: Parser (Recovered LetBinding) +parseIdentBinding = do + ident <- parseIdent + parseLetBindingSignature ident + <|> parseLetBindingName ident + +parseLetBindingSignature :: Name Ident -> Parser (Recovered LetBinding) +parseLetBindingSignature label = do + separator <- tokDoubleColon + value <- parseType + pure $ LetBindingSignature $ Labeled { label, separator, value } + +parseLetBindingName :: Name Ident -> Parser (Recovered LetBinding) +parseLetBindingName name = do + binders <- many parseBinderAtom + guarded <- parseGuarded tokEquals + pure $ LetBindingName { name, binders, guarded } + +parseGuarded :: Parser SourceToken -> Parser (Recovered Guarded) +parseGuarded sepParser = + Unconditional <$> sepParser <*> parseWhere + <|> Guarded <$> many1 parseGuardedExpr + where + parseGuardedExpr :: Parser (Recovered GuardedExpr) + parseGuardedExpr = ado + bar <- tokPipe + patterns <- separated tokComma parsePatternGuard + separator <- sepParser + where_ <- parseWhere + in GuardedExpr { bar, patterns, separator, where: where_ } + + parsePatternGuard :: Parser (Recovered PatternGuard) + parsePatternGuard = ado + binder <- optional (try (Tuple <$> parseBinder <*> tokLeftArrow)) + expr <- parseExpr + in PatternGuard { binder, expr } + +parseWhere :: Parser (Recovered Where) +parseWhere = defer \_ -> do + expr <- parseExpr + bindings <- optional (Tuple <$> tokKeyword "where" <*> layoutNonEmpty (recoverLetBinding parseLetBinding)) + pure $ Where { expr, bindings } + +parseBinder :: Parser (Recovered Binder) +parseBinder = defer \_ -> do + binder <- parseBinder1 + BinderTyped binder <$> tokDoubleColon <*> parseType + <|> pure binder + +parseBinder1 :: Parser (Recovered Binder) +parseBinder1 = defer \_ -> do + binder <- parseBinder2 + ops <- many (Tuple <$> parseQualifiedOperator <*> parseBinder2) + pure case NonEmptyArray.fromArray ops of + Nothing -> binder + Just os -> BinderOp binder os + +parseBinder2 :: Parser (Recovered Binder) +parseBinder2 = defer \_ -> + parseBinderNegative + <|> parseBinderConstructor + <|> parseBinderAtom + +parseBinderNegative :: Parser (Recovered Binder) +parseBinderNegative = do + negative <- tokKeyOperator "-" + uncurry (BinderInt (Just negative)) <$> parseInt + <|> uncurry (BinderNumber (Just negative)) <$> parseNumber + +parseBinderConstructor :: Parser (Recovered Binder) +parseBinderConstructor = defer \_ -> do + name <- parseQualifiedProper + apps <- many parseBinderAtom + pure $ BinderConstructor name apps + +parseBinderAtom :: Parser (Recovered Binder) +parseBinderAtom = defer \_ -> + parseIdentBinder + <|> flip BinderConstructor [] <$> parseQualifiedProper + <|> BinderWildcard <$> tokUnderscore + <|> uncurry BinderString <$> parseString + <|> uncurry BinderChar <$> parseChar + <|> uncurry BinderBoolean <$> parseBoolean + <|> uncurry (BinderInt Nothing) <$> parseInt + <|> uncurry (BinderNumber Nothing) <$> parseNumber + <|> BinderArray <$> delimited tokLeftSquare tokRightSquare tokComma parseBinder + <|> BinderRecord <$> delimited tokLeftBrace tokRightBrace tokComma (parseRecordLabeled parseBinder) + <|> BinderParens <$> parens parseBinder + +parseIdentBinder :: Parser (Recovered Binder) +parseIdentBinder = do + ident <- parseIdent + BinderNamed ident <$> tokAt <*> parseBinderAtom + <|> pure (BinderVar ident) + +parseLabel :: Parser (Name Label) +parseLabel = expectMap case _ of + tok@{ value: TokRawString label } -> + Just $ Name { token: tok, name: Label label } + tok@{ value: TokString _ label } -> + Just $ Name { token: tok, name: Label label } + tok@{ value: TokLowerName Nothing label } -> + Just $ Name { token: tok, name: Label label } + _ -> Nothing + +parseIdent :: Parser (Name Ident) +parseIdent = expectMap case _ of + tok@{ value: TokLowerName Nothing ident } | not $ Set.member ident reservedKeywords -> + Just $ Name { token: tok, name: Ident ident } + _ -> Nothing + +parseQualifiedIdent :: Parser (QualifiedName Ident) +parseQualifiedIdent = expectMap case _ of + tok@{ value: TokLowerName mn ident } | not $ Set.member ident reservedKeywords -> + Just $ QualifiedName { token: tok, "module": mn, name: Ident ident } + _ -> Nothing + +parseProper :: Parser (Name Proper) +parseProper = expectMap case _ of + tok@{ value: TokUpperName Nothing proper } -> + Just $ Name { token: tok, name: Proper proper } + _ -> Nothing + +parseQualifiedProper :: Parser (QualifiedName Proper) +parseQualifiedProper = expectMap case _ of + tok@{ value: TokUpperName mn proper } -> + Just $ QualifiedName { token: tok, "module": mn, name: Proper proper } + _ -> Nothing + +parseQualifiedIdentOrProper :: Parser (QualifiedName (Either Ident Proper)) +parseQualifiedIdentOrProper = expectMap case _ of + tok@{ value: TokLowerName mn ident } -> + Just $ QualifiedName { token: tok, "module": mn, name: Left $ Ident ident } + tok@{ value: TokUpperName mn proper } -> + Just $ QualifiedName { token: tok, "module": mn, name: Right $ Proper proper } + _ -> Nothing + +parseModuleName :: Parser (Name ModuleName) +parseModuleName = expectMap case _ of + tok@{ value: TokUpperName (Just (ModuleName mn)) proper } -> + Just $ Name { token: tok, name: ModuleName $ mn <> "." <> proper } + tok@{ value: TokUpperName Nothing proper } -> + Just $ Name { token: tok, name: ModuleName proper } + _ -> Nothing + +parseOperator :: Parser (Name Operator) +parseOperator = expectMap case _ of + tok@{ value: TokOperator Nothing operator } -> + Just $ Name { token: tok, name: Operator operator } + _ -> Nothing + +parseQualifiedOperator :: Parser (QualifiedName Operator) +parseQualifiedOperator = expectMap case _ of + tok@{ value: TokOperator mn operator } -> + Just $ QualifiedName { token: tok, "module": mn, name: Operator operator } + _ -> Nothing + +parseSymbol :: Parser (Name Operator) +parseSymbol = expectMap case _ of + tok@{ value: TokSymbolName Nothing operator } -> + Just $ Name { token: tok, name: Operator operator } + _ -> Nothing + +parseQualifiedSymbol :: Parser (QualifiedName Operator) +parseQualifiedSymbol = expectMap case _ of + tok@{ value: TokSymbolName mn operator } -> + Just $ QualifiedName { token: tok, "module": mn, name: Operator operator } + _ -> Nothing + +parseHole :: Parser (Name Ident) +parseHole = expectMap case _ of + tok@{ value: TokHole hole } -> + Just $ Name { token: tok, name: Ident hole } + _ -> Nothing + +parseString :: Parser (Tuple SourceToken String) +parseString = expectMap case _ of + tok@{ value: TokString _ str } -> + Just $ Tuple tok str + tok@{ value: TokRawString str } -> + Just $ Tuple tok str + _ -> Nothing + +parseChar :: Parser (Tuple SourceToken Char) +parseChar = expectMap case _ of + tok@{ value: TokChar _ ch } -> + Just $ Tuple tok ch + _ -> Nothing + +parseInt :: Parser (Tuple SourceToken IntValue) +parseInt = expectMap case _ of + tok@{ value: TokInt _ int } -> + Just $ Tuple tok int + _ -> Nothing + +parseSmallInt :: Parser (Tuple SourceToken Int) +parseSmallInt = take case _ of + tok@{ value: TokInt _ (SmallInt val) } -> + Right $ Tuple tok val + { value: TokInt raw _ } -> + Left $ LexIntOutOfRange raw + tok -> + Left $ UnexpectedToken tok.value + +parseNumber :: Parser (Tuple SourceToken Number) +parseNumber = expectMap case _ of + tok@{ value: TokNumber _ number } -> + Just $ Tuple tok number + _ -> Nothing + +parseBoolean :: Parser (Tuple SourceToken Boolean) +parseBoolean = expectMap case _ of + tok@{ value: TokLowerName Nothing "true" } -> + Just $ Tuple tok true + tok@{ value: TokLowerName Nothing "false" } -> + Just $ Tuple tok false + _ -> Nothing + +many1 :: forall a. Parser a -> Parser (NonEmptyArray a) +many1 parser = + NonEmptyArray.cons' + <$> parser + <*> many parser + +tokDoubleColon :: Parser SourceToken +tokDoubleColon = expect case _ of + TokDoubleColon _ -> true + _ -> false + +tokForall :: Parser SourceToken +tokForall = expect case _ of + TokForall _ -> true + _ -> false + +tokRightFatArrow :: Parser SourceToken +tokRightFatArrow = expect case _ of + TokRightFatArrow _ -> true + _ -> false + +tokLeftFatArrow :: Parser SourceToken +tokLeftFatArrow = expect case _ of + TokOperator Nothing name -> name == "<=" || name == "⇐" + _ -> false + +tokRightArrow :: Parser SourceToken +tokRightArrow = expect case _ of + TokRightArrow _ -> true + _ -> false + +tokLeftArrow :: Parser SourceToken +tokLeftArrow = expect case _ of + TokLeftArrow _ -> true + _ -> false + +tokSymbolArrow :: Parser SourceToken +tokSymbolArrow = expect case _ of + TokSymbolArrow _ -> true + _ -> false + +tokKeyword :: String -> Parser SourceToken +tokKeyword kw = expect case _ of + TokLowerName Nothing name -> kw == name + _ -> false + +tokQualifiedKeyword :: String -> Parser SourceToken +tokQualifiedKeyword kw = expect case _ of + TokLowerName _ name -> kw == name + _ -> false + +tokKeyOperator :: String -> Parser SourceToken +tokKeyOperator sym = expect case _ of + TokOperator Nothing name -> sym == name + _ -> false + +tokKeySymbol :: String -> Parser SourceToken +tokKeySymbol sym = expect case _ of + TokSymbolName Nothing name -> sym == name + _ -> false + +tokLayoutStart :: Parser SourceToken +tokLayoutStart = expect case _ of + TokLayoutStart _ -> true + _ -> false + +tokLayoutEnd :: Parser SourceToken +tokLayoutEnd = expect case _ of + TokLayoutEnd _ -> true + _ -> false + +tokLayoutSep :: Parser SourceToken +tokLayoutSep = expect case _ of + TokLayoutSep _ -> true + _ -> false + +tokLeftParen :: Parser SourceToken +tokLeftParen = expect case _ of + TokLeftParen -> true + _ -> false + +tokRightParen :: Parser SourceToken +tokRightParen = expect case _ of + TokRightParen -> true + _ -> false + +tokLeftBrace :: Parser SourceToken +tokLeftBrace = expect case _ of + TokLeftBrace -> true + _ -> false + +tokRightBrace :: Parser SourceToken +tokRightBrace = expect case _ of + TokRightBrace -> true + _ -> false + +tokLeftSquare :: Parser SourceToken +tokLeftSquare = expect case _ of + TokLeftSquare -> true + _ -> false + +tokRightSquare :: Parser SourceToken +tokRightSquare = expect case _ of + TokRightSquare -> true + _ -> false + +tokEquals :: Parser SourceToken +tokEquals = expect case _ of + TokEquals -> true + _ -> false + +tokPipe :: Parser SourceToken +tokPipe = expect case _ of + TokPipe -> true + _ -> false + +tokTick :: Parser SourceToken +tokTick = expect case _ of + TokTick -> true + _ -> false + +tokDot :: Parser SourceToken +tokDot = expect case _ of + TokDot -> true + _ -> false + +tokComma :: Parser SourceToken +tokComma = expect case _ of + TokComma -> true + _ -> false + +tokUnderscore :: Parser SourceToken +tokUnderscore = expect case _ of + TokUnderscore -> true + _ -> false + +tokBackslash :: Parser SourceToken +tokBackslash = expect case _ of + TokBackslash -> true + _ -> false + +tokAt :: Parser SourceToken +tokAt = expect case _ of + TokAt -> true + _ -> false + +reservedKeywords :: Set String +reservedKeywords = Set.fromFoldable + [ "ado" + , "case" + , "class" + , "data" + , "derive" + , "do" + , "else" + , "false" + , "foreign" + , "if" + , "import" + , "in" + , "infix" + , "infixl" + , "infixr" + , "instance" + , "let" + , "module" + , "newtype" + , "of" + , "then" + , "true" + , "type" + , "where" + ] + +recoverIndent :: forall a. (RecoveredError -> a) -> Parser a -> Parser a +recoverIndent mkNode = recover \{ position, error } stream -> do + let + Tuple tokens newStream = recoverTokensWhile + ( \tok indent -> case tok.value of + TokLayoutEnd col -> col > indent + TokLayoutSep col -> col > indent + _ -> true + ) + stream + if Array.null tokens then + Nothing + else + Just (Tuple (mkNode (RecoveredError { position, error, tokens })) newStream) + +recoverTokensWhile :: (SourceToken -> Int -> Boolean) -> TokenStream -> Tuple (Array SourceToken) TokenStream +recoverTokensWhile p initStream = go [] initStream + where + indent :: Int + indent = currentIndentColumn initStream + + go :: Array SourceToken -> TokenStream -> Tuple (Array SourceToken) TokenStream + go acc stream = case TokenStream.step stream of + TokenError _ _ _ _ -> + Tuple acc stream + TokenEOF _ _ -> + Tuple acc stream + TokenCons tok _ nextStream _ -> + if p tok indent then + go (Array.snoc acc tok) nextStream + else + Tuple acc stream + +recoverDecl :: RecoveryStrategy Declaration +recoverDecl = recoverIndent DeclError + +recoverLetBinding :: RecoveryStrategy LetBinding +recoverLetBinding = recoverIndent LetBindingError + +recoverDoStatement :: RecoveryStrategy DoStatement +recoverDoStatement = recoverIndent DoError diff --git a/src/PureScript/CST/Print.purs b/src/PureScript/CST/Print.purs index 8dd5831..4a0387b 100644 --- a/src/PureScript/CST/Print.purs +++ b/src/PureScript/CST/Print.purs @@ -7,6 +7,8 @@ module PureScript.CST.Print , printComment , printLineFeed , printQualified + , printModule + , printParseError ) where import Prelude @@ -15,7 +17,10 @@ import Data.Foldable (foldMap) import Data.Maybe (Maybe(..)) import Data.Monoid (power) import Data.Newtype (unwrap) -import PureScript.CST.Types (Comment(..), LineFeed(..), ModuleName, SourceStyle(..), Token(..), SourceToken) +import PureScript.CST (Comment(..), LineFeed(..), Module, ModuleName, SourceStyle(..), SourceToken, Token(..)) +import PureScript.CST.Errors (ParseError(..)) +import PureScript.CST.TokenList as TokenList +import PureScript.CST.Tokens (class TokensOf, tokensOf) data TokenOption = ShowLayout @@ -135,3 +140,114 @@ printLineFeed :: LineFeed -> String printLineFeed = case _ of LF -> "\n" CRLF -> "\r\n" + +printModule :: forall e. TokensOf e => Module e -> String +printModule mod = + foldMap printSourceToken (TokenList.toArray (tokensOf mod)) + <> foldMap (printComment printLineFeed) (unwrap (unwrap mod).body).trailingComments + +printParseError :: ParseError -> String +printParseError = case _ of + UnexpectedEof -> + "Unexpected end of file" + ExpectedEof tok -> + "Expected end of file, saw " <> printTokenError tok + UnexpectedToken tok -> + "Unexpected " <> printTokenError tok + ExpectedToken tok saw -> + "Expected " <> printTokenError tok <> ", saw " <> printTokenError saw + ExpectedClass cls saw -> + "Expected " <> cls <> ", saw " <> printTokenError saw + LexExpected str saw -> + "Expected " <> str <> ", saw " <> saw + LexInvalidCharEscape str -> + "Invalid character escape \\" <> str + LexCharEscapeOutOfRange str -> + "Character escape out of range \\" <> str + LexHexOutOfRange str -> + "Hex integer out of range 0x" <> str + LexIntOutOfRange str -> + "Int out of range " <> str + LexNumberOutOfRange str -> + "Number out of range " <> str + +printTokenError :: Token -> String +printTokenError = case _ of + TokLeftParen -> + "'('" + TokRightParen -> + "')'" + TokLeftBrace -> + "'{'" + TokRightBrace -> + "'}'" + TokLeftSquare -> + "'['" + TokRightSquare -> + "']'" + TokLeftArrow style -> + case style of + ASCII -> "'<-'" + Unicode -> "'←'" + TokRightArrow style -> + case style of + ASCII -> "'->'" + Unicode -> "'→'" + TokRightFatArrow style -> + case style of + ASCII -> "'=>'" + Unicode -> "'⇒'" + TokDoubleColon style -> + case style of + ASCII -> "'::'" + Unicode -> "'∷'" + TokForall style -> + case style of + ASCII -> "forall" + Unicode -> "'∀'" + TokEquals -> + "'='" + TokPipe -> + "'|'" + TokTick -> + "`" + TokDot -> + "." + TokComma -> + "','" + TokUnderscore -> + "'_'" + TokBackslash -> + "'\\'" + TokAt -> + "'@'" + TokLowerName moduleName name -> + "identifier " <> printQualified moduleName name + TokUpperName moduleName name -> + "proper identifier " <> printQualified moduleName name + TokOperator moduleName name -> + "operator " <> printQualified moduleName name + TokSymbolName moduleName name -> + "symbol " <> printQualified moduleName name + TokSymbolArrow style -> + case style of + ASCII -> "(->)" + Unicode -> "(→)" + TokHole name -> + "hole ?" <> name + TokChar raw _ -> + "char literal '" <> raw <> "'" + TokString _ _ -> + "string literal" + TokRawString _ -> + "raw string literal" + TokInt raw _ -> + "int literal " <> raw + TokNumber raw _ -> + "number literal " <> raw + TokLayoutStart _ -> + "start of indented block" + TokLayoutSep _ -> + "new indented block item" + TokLayoutEnd _ -> + "end of indented block" diff --git a/src/PureScript/CST/Range.purs b/src/PureScript/CST/Range.purs index c0d1129..61cc0bc 100644 --- a/src/PureScript/CST/Range.purs +++ b/src/PureScript/CST/Range.purs @@ -1,49 +1,24 @@ module PureScript.CST.Range ( class RangeOf , rangeOf - , class TokensOf - , tokensOf ) where import Prelude import Prim hiding (Row, Type) -import Control.Lazy (defer) import Data.Array as Array -import Data.Array.NonEmpty (NonEmptyArray) import Data.Array.NonEmpty as NonEmptyArray -import Data.Foldable (foldMap) import Data.Maybe (Maybe(..), maybe) import Data.Tuple (Tuple(..), fst, snd) import PureScript.CST.Errors (RecoveredError(..)) -import PureScript.CST.Range.TokenList (TokenList, cons, singleton) -import PureScript.CST.Range.TokenList as TokenList -import PureScript.CST.Types (AppSpine(..), Binder(..), ClassFundep(..), DataCtor(..), DataMembers(..), Declaration(..), DoStatement(..), Export(..), Expr(..), FixityOp(..), Foreign(..), Guarded(..), GuardedExpr(..), Import(..), ImportDecl(..), Instance(..), InstanceBinding(..), Labeled(..), LetBinding(..), Module(..), ModuleBody(..), ModuleHeader(..), Name(..), OneOrDelimited(..), PatternGuard(..), Prefixed(..), QualifiedName(..), RecordLabeled(..), RecordUpdate(..), Row(..), Separated(..), SourceRange, Type(..), TypeVarBinding(..), Where(..), Wrapped(..)) +import PureScript.CST (AppSpine(..), Binder(..), ClassFundep(..), DataCtor(..), DataMembers(..), Declaration(..), DoStatement(..), Export(..), Expr(..), FixityOp(..), Foreign(..), Guarded(..), GuardedExpr(..), Import(..), ImportDecl(..), Instance(..), InstanceBinding(..), Labeled(..), LetBinding(..), Name(..), OneOrDelimited(..), Prefixed(..), QualifiedName(..), Separated(..), SourceRange, Type(..), TypeVarBinding(..), Where(..), Wrapped(..)) class RangeOf a where rangeOf :: a -> SourceRange -class TokensOf a where - tokensOf :: a -> TokenList - -instance tokensOfTuple :: (TokensOf a, TokensOf b) => TokensOf (Tuple a b) where - tokensOf (Tuple a b) = tokensOf a <> tokensOf b - -instance tokensOfMaybe :: TokensOf a => TokensOf (Maybe a) where - tokensOf = foldMap tokensOf - -instance tokensOfArray :: TokensOf a => TokensOf (Array a) where - tokensOf = foldMap (\a -> defer \_ -> tokensOf a) - -instance tokensOfNonEmptyArray :: TokensOf a => TokensOf (NonEmptyArray a) where - tokensOf = foldMap (\a -> defer \_ -> tokensOf a) - instance rangeOfVoid :: RangeOf Void where rangeOf = absurd -instance tokensOfVoid :: TokensOf Void where - tokensOf = absurd - instance rangeOfRecoveredError :: RangeOf RecoveredError where rangeOf (RecoveredError { position, tokens }) = case NonEmptyArray.fromArray tokens of @@ -56,46 +31,18 @@ instance rangeOfRecoveredError :: RangeOf RecoveredError where , end: position } -instance tokensOfRecoveredError :: TokensOf RecoveredError where - tokensOf (RecoveredError { tokens }) = TokenList.fromArray tokens - -instance rangeOfModule :: RangeOf (Module e) where - rangeOf (Module { header: ModuleHeader header, body: ModuleBody body }) = - { start: header.keyword.range.start - , end: body.end - } - -instance tokensOfModule :: TokensOf e => TokensOf (Module e) where - tokensOf (Module { header: ModuleHeader header, body: ModuleBody body }) = - cons header.keyword - $ tokensOf header.name - <> defer (\_ -> foldMap tokensOf header.exports) - <> singleton header.where - <> defer (\_ -> foldMap tokensOf header.imports) - <> defer (\_ -> foldMap tokensOf body.decls) - instance rangeOfName :: RangeOf (Name a) where rangeOf (Name { token }) = token.range -instance tokensOfName :: TokensOf (Name a) where - tokensOf (Name { token }) = singleton token - instance rangeOfQualifiedName :: RangeOf (QualifiedName a) where rangeOf (QualifiedName { token }) = token.range -instance tokensOfQualifiedName :: TokensOf (QualifiedName a) where - tokensOf (QualifiedName { token }) = singleton token - instance rangeOfWrapped :: RangeOf (Wrapped a) where rangeOf (Wrapped { open, close }) = { start: open.range.start , end: close.range.end } -instance tokensOfWrapped :: TokensOf a => TokensOf (Wrapped a) where - tokensOf (Wrapped { open, value, close }) = - TokenList.wrap open (defer \_ -> tokensOf value) close - instance rangeOfSeparated :: RangeOf a => RangeOf (Separated a) where rangeOf (Separated { head, tail }) = case Array.last tail of @@ -106,21 +53,12 @@ instance rangeOfSeparated :: RangeOf a => RangeOf (Separated a) where Nothing -> rangeOf head -instance tokensOfSeparated :: TokensOf a => TokensOf (Separated a) where - tokensOf (Separated { head, tail }) = - tokensOf head - <> defer \_ -> foldMap (\(Tuple a b) -> cons a $ defer (\_ -> tokensOf b)) tail - instance rangeOfLabeled :: (RangeOf a, RangeOf b) => RangeOf (Labeled a b) where rangeOf (Labeled { label, value }) = { start: (rangeOf label).start , end: (rangeOf value).end } -instance tokensOfLabeled :: (TokensOf a, TokensOf b) => TokensOf (Labeled a b) where - tokensOf (Labeled { label, separator, value }) = - tokensOf label <> singleton separator <> tokensOf value - instance rangeOfPrefixed :: RangeOf a => RangeOf (Prefixed a) where rangeOf (Prefixed { prefix, value }) = case prefix of @@ -131,24 +69,11 @@ instance rangeOfPrefixed :: RangeOf a => RangeOf (Prefixed a) where Nothing -> rangeOf value -instance tokensOfPrefixed :: TokensOf a => TokensOf (Prefixed a) where - tokensOf (Prefixed { prefix, value }) = - case prefix of - Just tok -> - cons tok $ defer \_ -> tokensOf value - Nothing -> - tokensOf value - instance rangeOfOneOrDelimited :: RangeOf a => RangeOf (OneOrDelimited a) where rangeOf = case _ of One a -> rangeOf a Many as -> rangeOf as -instance tokensOfOneOrDelimited :: TokensOf a => TokensOf (OneOrDelimited a) where - tokensOf = case _ of - One a -> tokensOf a - Many as -> tokensOf as - instance rangeOfType :: RangeOf e => RangeOf (Type e) where rangeOf = case _ of TypeVar n -> @@ -206,58 +131,6 @@ instance rangeOfType :: RangeOf e => RangeOf (Type e) where TypeError e -> rangeOf e -instance tokensOfType :: TokensOf e => TokensOf (Type e) where - tokensOf = case _ of - TypeVar n -> - tokensOf n - TypeConstructor n -> - tokensOf n - TypeWildcard t -> - singleton t - TypeHole n -> - tokensOf n - TypeString t _ -> - singleton t - TypeInt neg t _ -> - foldMap singleton neg <> singleton t - TypeRow w -> - tokensOf w - TypeRecord w -> - tokensOf w - TypeForall t vars dot ty -> - cons t $ defer \_ -> - tokensOf vars - <> singleton dot - <> tokensOf ty - TypeKinded ty1 t ty2 -> - tokensOf ty1 - <> defer \_ -> singleton t <> tokensOf ty2 - TypeApp ty tys -> - tokensOf ty - <> defer \_ -> tokensOf tys - TypeOp ty ops -> - tokensOf ty - <> defer \_ -> foldMap (\(Tuple op arg) -> tokensOf op <> tokensOf arg) ops - TypeOpName n -> - tokensOf n - TypeArrow ty1 t ty2 -> - tokensOf ty1 - <> defer \_ -> singleton t <> tokensOf ty2 - TypeArrowName t -> - singleton t - TypeConstrained ty1 t ty2 -> - tokensOf ty1 - <> defer \_ -> singleton t <> tokensOf ty2 - TypeParens w -> - tokensOf w - TypeError e -> - tokensOf e - -instance tokensOfRow :: TokensOf e => TokensOf (Row e) where - tokensOf (Row { labels, tail }) = - foldMap tokensOf labels - <> foldMap (\(Tuple t ty) -> cons t $ tokensOf ty) tail - instance rangeOfTypeVarBinding :: RangeOf a => RangeOf (TypeVarBinding a e) where rangeOf = case _ of TypeVarKinded w -> @@ -265,13 +138,6 @@ instance rangeOfTypeVarBinding :: RangeOf a => RangeOf (TypeVarBinding a e) wher TypeVarName n -> rangeOf n -instance tokensOfTypeVarBinding :: (TokensOf a, TokensOf e) => TokensOf (TypeVarBinding a e) where - tokensOf = case _ of - TypeVarKinded w -> - tokensOf w - TypeVarName n -> - tokensOf n - instance rangeOfExport :: RangeOf e => RangeOf (Export e) where rangeOf = case _ of ExportValue n -> @@ -301,23 +167,6 @@ instance rangeOfExport :: RangeOf e => RangeOf (Export e) where ExportError e -> rangeOf e -instance tokensOfExport :: TokensOf e => TokensOf (Export e) where - tokensOf = case _ of - ExportValue n -> - tokensOf n - ExportOp n -> - tokensOf n - ExportType n dms -> - tokensOf n <> foldMap tokensOf dms - ExportTypeOp t n -> - cons t $ tokensOf n - ExportClass t n -> - cons t $ tokensOf n - ExportModule t n -> - cons t $ tokensOf n - ExportError e -> - tokensOf e - instance rangeOfDataMembers :: RangeOf DataMembers where rangeOf = case _ of DataAll t -> @@ -325,13 +174,6 @@ instance rangeOfDataMembers :: RangeOf DataMembers where DataEnumerated w -> rangeOf w -instance tokensOfDataMembers :: TokensOf DataMembers where - tokensOf = case _ of - DataAll t -> - singleton t - DataEnumerated w -> - tokensOf w - instance rangeOfImportDecl :: RangeOf (ImportDecl e) where rangeOf (ImportDecl { keyword, "module": mod, names, qualified }) = do let @@ -348,13 +190,6 @@ instance rangeOfImportDecl :: RangeOf (ImportDecl e) where , end } -instance tokensOfImportDecl :: TokensOf e => TokensOf (ImportDecl e) where - tokensOf (ImportDecl { keyword, "module": mod, names, qualified }) = - cons keyword $ defer \_ -> - tokensOf mod - <> foldMap (\(Tuple hiding imports) -> foldMap singleton hiding <> defer (\_ -> tokensOf imports)) names - <> foldMap (\(Tuple as mn) -> singleton as <> tokensOf mn) qualified - instance rangeOfImport :: RangeOf e => RangeOf (Import e) where rangeOf = case _ of ImportValue n -> @@ -380,21 +215,6 @@ instance rangeOfImport :: RangeOf e => RangeOf (Import e) where ImportError e -> rangeOf e -instance tokensOfImport :: TokensOf e => TokensOf (Import e) where - tokensOf = case _ of - ImportValue n -> - tokensOf n - ImportOp n -> - tokensOf n - ImportType n dms -> - tokensOf n <> foldMap tokensOf dms - ImportTypeOp t n -> - cons t $ tokensOf n - ImportClass t n -> - cons t $ tokensOf n - ImportError e -> - tokensOf e - instance rangeOfDataCtor :: RangeOf e => RangeOf (DataCtor e) where rangeOf (DataCtor { name, fields }) = do let @@ -407,10 +227,6 @@ instance rangeOfDataCtor :: RangeOf e => RangeOf (DataCtor e) where , end } -instance tokensOfDataCtor :: TokensOf e => TokensOf (DataCtor e) where - tokensOf (DataCtor { name, fields }) = - tokensOf name <> tokensOf fields - instance rangeOfDecl :: RangeOf e => RangeOf (Declaration e) where rangeOf = case _ of DeclData { keyword, name, vars } ctors -> do @@ -490,65 +306,6 @@ instance rangeOfDecl :: RangeOf e => RangeOf (Declaration e) where DeclError e -> rangeOf e -instance tokensOfDecl :: TokensOf e => TokensOf (Declaration e) where - tokensOf = case _ of - DeclData { keyword, name, vars } ctors -> - cons keyword $ defer \_ -> - tokensOf name - <> tokensOf vars - <> foldMap (\(Tuple t cs) -> cons t $ tokensOf cs) ctors - DeclType { keyword, name, vars } tok ty -> - cons keyword $ defer \_ -> - tokensOf name - <> tokensOf vars - <> singleton tok - <> tokensOf ty - DeclNewtype { keyword, name, vars } tok n ty -> - cons keyword $ defer \_ -> - tokensOf name - <> tokensOf vars - <> singleton tok - <> tokensOf n - <> tokensOf ty - DeclClass { keyword, super, name, vars, fundeps } members -> - cons keyword $ defer \_ -> - foldMap (\(Tuple cs t) -> tokensOf cs <> singleton t) super - <> tokensOf name - <> tokensOf vars - <> foldMap (\(Tuple t fs) -> cons t $ tokensOf fs) fundeps - <> foldMap (\(Tuple t ls) -> cons t $ tokensOf ls) members - DeclInstanceChain insts -> - tokensOf insts - DeclDerive keyword tok inst -> - cons keyword $ defer \_ -> - foldMap singleton tok - <> singleton inst.keyword - <> foldMap (\(Tuple cs t) -> tokensOf cs <> singleton t) inst.name - <> foldMap (\(Tuple cs t) -> tokensOf cs <> singleton t) inst.constraints - <> tokensOf inst.className - <> tokensOf inst.types - DeclKindSignature keyword lbl -> - cons keyword $ defer \_ -> - tokensOf lbl - DeclSignature sig -> - tokensOf sig - DeclValue { name, binders, guarded } -> - tokensOf name <> defer \_ -> - tokensOf binders <> tokensOf guarded - DeclFixity { keyword: Tuple keyword _, prec: Tuple prec _, operator } -> - cons keyword $ defer \_ -> - cons prec $ tokensOf operator - DeclForeign keyword imp frn -> - cons keyword $ defer \_ -> - cons imp $ tokensOf frn - DeclRole keyword rl n roles -> - cons keyword $ defer \_ -> - singleton rl - <> tokensOf n - <> foldMap (\(Tuple t _) -> singleton t) roles - DeclError e -> - tokensOf e - instance rangeOfClassFundep :: RangeOf ClassFundep where rangeOf = case _ of FundepDetermined t ns -> @@ -560,13 +317,6 @@ instance rangeOfClassFundep :: RangeOf ClassFundep where , end: (rangeOf (NonEmptyArray.last ns2)).end } -instance tokensOfClassFundep :: TokensOf ClassFundep where - tokensOf = case _ of - FundepDetermined t ns -> - cons t $ tokensOf ns - FundepDetermines ns1 t ns2 -> - tokensOf ns1 <> singleton t <> tokensOf ns2 - instance rangeOfInstance :: RangeOf e => RangeOf (Instance e) where rangeOf (Instance { head: { keyword, className, types }, body }) = do let @@ -583,15 +333,6 @@ instance rangeOfInstance :: RangeOf e => RangeOf (Instance e) where , end } -instance tokensOfInstance :: TokensOf e => TokensOf (Instance e) where - tokensOf (Instance { head, body }) = - cons head.keyword $ defer \_ -> - foldMap (\(Tuple cs t) -> tokensOf cs <> singleton t) head.name - <> foldMap (\(Tuple cs t) -> tokensOf cs <> singleton t) head.constraints - <> tokensOf head.className - <> tokensOf head.types - <> foldMap (\(Tuple t bs) -> cons t $ tokensOf bs) body - instance rangeOfGuarded :: RangeOf e => RangeOf (Guarded e) where rangeOf = case _ of Unconditional t wh -> @@ -603,31 +344,12 @@ instance rangeOfGuarded :: RangeOf e => RangeOf (Guarded e) where , end: (rangeOf (NonEmptyArray.last gs)).end } -instance tokensOfGuarded :: TokensOf e => TokensOf (Guarded e) where - tokensOf = case _ of - Unconditional t wh -> - cons t $ tokensOf wh - Guarded gs -> - tokensOf gs - instance rangeOfGuardedExpr :: RangeOf e => RangeOf (GuardedExpr e) where rangeOf (GuardedExpr ge) = { start: ge.bar.range.start , end: (rangeOf ge.where).end } -instance tokensOfGuardedExpr :: TokensOf e => TokensOf (GuardedExpr e) where - tokensOf (GuardedExpr ge) = - cons ge.bar $ defer \_ -> - tokensOf ge.patterns - <> singleton ge.separator - <> tokensOf ge.where - -instance tokensOfPatternGuard :: TokensOf e => TokensOf (PatternGuard e) where - tokensOf (PatternGuard { binder, expr }) = - foldMap (\(Tuple b t) -> tokensOf b <> singleton t) binder - <> tokensOf expr - instance rangeOfFixityOp :: RangeOf FixityOp where rangeOf = case _ of FixityValue n1 _ n2 -> @@ -639,13 +361,6 @@ instance rangeOfFixityOp :: RangeOf FixityOp where , end: (rangeOf n).end } -instance tokensOfFixityOp :: TokensOf FixityOp where - tokensOf = case _ of - FixityValue n1 t n2 -> - tokensOf n1 <> singleton t <> tokensOf n2 - FixityType t1 n1 t2 n2 -> - cons t1 $ tokensOf n1 <> singleton t2 <> tokensOf n2 - instance rangeOfForeign :: RangeOf e => RangeOf (Foreign e) where rangeOf = case _ of ForeignValue lbl -> @@ -659,15 +374,6 @@ instance rangeOfForeign :: RangeOf e => RangeOf (Foreign e) where , end: (rangeOf n).end } -instance tokensOfForeign :: TokensOf e => TokensOf (Foreign e) where - tokensOf = case _ of - ForeignValue lbl -> - tokensOf lbl - ForeignData t lbl -> - cons t $ tokensOf lbl - ForeignKind t n -> - cons t $ tokensOf n - instance rangeOfInstanceBinding :: RangeOf e => RangeOf (InstanceBinding e) where rangeOf = case _ of InstanceBindingSignature lbl -> @@ -677,15 +383,6 @@ instance rangeOfInstanceBinding :: RangeOf e => RangeOf (InstanceBinding e) wher , end: (rangeOf guarded).end } -instance tokensOfInstanceBinding :: TokensOf e => TokensOf (InstanceBinding e) where - tokensOf = case _ of - InstanceBindingSignature lbl -> - tokensOf lbl - InstanceBindingName { name, binders, guarded } -> - tokensOf name - <> tokensOf binders - <> tokensOf guarded - instance rangeOfExpr :: RangeOf e => RangeOf (Expr e) where rangeOf = case _ of ExprHole n -> @@ -769,80 +466,6 @@ instance rangeOfExpr :: RangeOf e => RangeOf (Expr e) where ExprError e -> rangeOf e -instance tokensOfExpr :: TokensOf e => TokensOf (Expr e) where - tokensOf = case _ of - ExprHole n -> - tokensOf n - ExprSection t -> - singleton t - ExprIdent n -> - tokensOf n - ExprConstructor n -> - tokensOf n - ExprBoolean t _ -> - singleton t - ExprChar t _ -> - singleton t - ExprString t _ -> - singleton t - ExprInt t _ -> - singleton t - ExprNumber t _ -> - singleton t - ExprArray exprs -> - tokensOf exprs - ExprRecord exprs -> - tokensOf exprs - ExprParens w -> - tokensOf w - ExprTyped expr t ty -> - tokensOf expr <> defer \_ -> cons t $ tokensOf ty - ExprInfix expr ops -> - tokensOf expr <> defer \_ -> tokensOf ops - ExprOp expr ops -> - tokensOf expr <> defer \_ -> tokensOf ops - ExprOpName n -> - tokensOf n - ExprNegate t expr -> - cons t $ tokensOf expr - ExprRecordAccessor { expr, dot, path } -> - tokensOf expr <> defer \_ -> cons dot $ tokensOf path - ExprRecordUpdate expr upds -> - tokensOf expr <> defer \_ -> tokensOf upds - ExprApp expr exprs -> - tokensOf expr <> defer \_ -> tokensOf exprs - ExprLambda { symbol, binders, arrow, body } -> - cons symbol $ defer \_ -> - tokensOf binders - <> singleton arrow - <> tokensOf body - ExprIf ifte -> - cons ifte.keyword $ defer \_ -> - tokensOf ifte.cond - <> singleton ifte.then - <> tokensOf ifte.true - <> singleton ifte.else - <> tokensOf ifte.false - ExprCase cs -> - cons cs.keyword $ defer \_ -> - tokensOf cs.head - <> singleton cs.of - <> tokensOf cs.branches - ExprLet lt -> - cons lt.keyword $ defer \_ -> - tokensOf lt.bindings - <> singleton lt.in - <> tokensOf lt.body - ExprDo { keyword, statements } -> - cons keyword $ defer \_ -> tokensOf statements - ExprAdo block -> - cons block.keyword $ defer \_ -> - tokensOf block.statements - <> singleton block.in - <> tokensOf block.result - ExprError e -> - tokensOf e - instance rangeOfAppSpine :: (RangeOf e, RangeOf (f e)) => RangeOf (AppSpine f e) where rangeOf = case _ of AppType t a -> @@ -852,20 +475,6 @@ instance rangeOfAppSpine :: (RangeOf e, RangeOf (f e)) => RangeOf (AppSpine f e) AppTerm a -> rangeOf a -instance tokensOfAppSpine :: (TokensOf e, TokensOf (f e)) => TokensOf (AppSpine f e) where - tokensOf = case _ of - AppType t a -> - cons t $ defer \_ -> tokensOf a - AppTerm a -> - tokensOf a - -instance tokensOfRecordUpdate :: TokensOf e => TokensOf (RecordUpdate e) where - tokensOf = case _ of - RecordUpdateLeaf n t e -> - tokensOf n <> singleton t <> tokensOf e - RecordUpdateBranch n us -> - tokensOf n <> tokensOf us - instance rangeOfDoStatement :: RangeOf e => RangeOf (DoStatement e) where rangeOf = case _ of DoLet t bindings -> @@ -881,17 +490,6 @@ instance rangeOfDoStatement :: RangeOf e => RangeOf (DoStatement e) where DoError e -> rangeOf e -instance tokensOfDoStatement :: TokensOf e => TokensOf (DoStatement e) where - tokensOf = case _ of - DoLet t bindings -> - cons t $ defer \_ -> tokensOf bindings - DoDiscard expr -> - tokensOf expr - DoBind b t expr -> - tokensOf b <> defer \_ -> cons t $ tokensOf expr - DoError e -> - tokensOf e - instance rangeOfLetBinding :: RangeOf e => RangeOf (LetBinding e) where rangeOf = case _ of LetBindingSignature lbl -> @@ -907,17 +505,6 @@ instance rangeOfLetBinding :: RangeOf e => RangeOf (LetBinding e) where LetBindingError e -> rangeOf e -instance tokensOfLetBinding :: TokensOf e => TokensOf (LetBinding e) where - tokensOf = case _ of - LetBindingSignature lbl -> - tokensOf lbl - LetBindingName { name, binders, guarded } -> - tokensOf name <> defer \_ -> tokensOf binders <> tokensOf guarded - LetBindingPattern b t wh -> - tokensOf b <> defer \_ -> cons t $ tokensOf wh - LetBindingError e -> - tokensOf e - instance rangeOfBinder :: RangeOf e => RangeOf (Binder e) where rangeOf = case _ of BinderWildcard t -> @@ -975,46 +562,6 @@ instance rangeOfBinder :: RangeOf e => RangeOf (Binder e) where BinderError e -> rangeOf e -instance tokensOfBinder :: TokensOf e => TokensOf (Binder e) where - tokensOf = case _ of - BinderWildcard t -> - singleton t - BinderVar n -> - tokensOf n - BinderNamed n t b -> - tokensOf n <> defer \_ -> cons t $ tokensOf b - BinderConstructor n bs -> - tokensOf n <> defer \_ -> tokensOf bs - BinderBoolean t _ -> - singleton t - BinderChar t _ -> - singleton t - BinderString t _ -> - singleton t - BinderInt neg t _ -> - foldMap singleton neg <> singleton t - BinderNumber neg t _ -> - foldMap singleton neg <> singleton t - BinderArray bs -> - tokensOf bs - BinderRecord bs -> - tokensOf bs - BinderParens b -> - tokensOf b - BinderTyped b t ty -> - tokensOf b <> defer \_ -> cons t $ tokensOf ty - BinderOp b ops -> - tokensOf b <> defer \_ -> tokensOf ops - BinderError e -> - tokensOf e - -instance tokensOfRecordLabeled :: TokensOf a => TokensOf (RecordLabeled a) where - tokensOf = case _ of - RecordPun n -> - tokensOf n - RecordField n t a -> - tokensOf n <> defer \_ -> cons t $ tokensOf a - instance rangeOfWhere :: RangeOf e => RangeOf (Where e) where rangeOf (Where { expr, bindings }) = case bindings of Nothing -> @@ -1023,8 +570,3 @@ instance rangeOfWhere :: RangeOf e => RangeOf (Where e) where { start: (rangeOf expr).start , end: (rangeOf (NonEmptyArray.last lb)).end } - -instance tokensOfWhere :: TokensOf e => TokensOf (Where e) where - tokensOf (Where { expr, bindings }) = - tokensOf expr <> defer \_ -> - foldMap (\(Tuple t bs) -> cons t $ tokensOf bs) bindings diff --git a/src/PureScript/CST/Recovered.purs b/src/PureScript/CST/Recovered.purs new file mode 100644 index 0000000..a2a7396 --- /dev/null +++ b/src/PureScript/CST/Recovered.purs @@ -0,0 +1,92 @@ +module PureScript.CST.Recovered + ( RecoveredParserResult(..) + , PartialModule(..) + , parseModule + , parsePartialModule + , parseImportDecl + , parseDecl + , parseExpr + , parseType + , parseBinder + , toRecovered + ) where + +import Prelude +import Prim hiding (Type) + +import Data.Array.NonEmpty (NonEmptyArray) +import Data.Array.NonEmpty as NonEmptyArray +import Data.Either (Either(..)) +import Data.Lazy as Z +import Data.Maybe (Maybe(..)) +import Data.Tuple (Tuple(..)) +import PureScript.CST.Lexer (lex, lexModule) +import PureScript.CST.Parser.Recovered (Recovered, parseModuleBody, parseModuleHeader) +import PureScript.CST.Parser.Recovered as Parser +import PureScript.CST.Parser (Parser, ParserResult(..), PositionedError, fromParserResult, initialParserState, runParser, runParser') +import PureScript.CST.TokenStream (TokenStream) +import PureScript.CST (Binder, Declaration, Expr, ImportDecl, Module(..), ModuleHeader, Type) +import Unsafe.Coerce (unsafeCoerce) + +data RecoveredParserResult f + = ParseSucceeded (f Void) + | ParseSucceededWithErrors (Recovered f) (NonEmptyArray PositionedError) + | ParseFailed PositionedError + +toRecoveredParserResult + :: forall f + . Either PositionedError (Tuple (Recovered f) (Array PositionedError)) + -> RecoveredParserResult f +toRecoveredParserResult = case _ of + Right (Tuple res errors) + | Just nea <- NonEmptyArray.fromArray errors -> + ParseSucceededWithErrors res nea + | otherwise -> + ParseSucceeded ((unsafeCoerce :: Recovered f -> f Void) res) + Left err -> + ParseFailed err + +toRecovered :: forall f. f Void -> Recovered f +toRecovered = unsafeCoerce + +runRecoveredParser :: forall a. Parser (Recovered a) -> TokenStream -> RecoveredParserResult a +runRecoveredParser p = toRecoveredParserResult <<< flip runParser p + +parseModule :: String -> RecoveredParserResult Module +parseModule = runRecoveredParser Parser.parseModule <<< lexModule + +parseImportDecl :: String -> RecoveredParserResult ImportDecl +parseImportDecl = runRecoveredParser Parser.parseImportDecl <<< lex + +parseDecl :: String -> RecoveredParserResult Declaration +parseDecl = runRecoveredParser Parser.parseDecl <<< lex + +parseExpr :: String -> RecoveredParserResult Expr +parseExpr = runRecoveredParser Parser.parseExpr <<< lex + +parseType :: String -> RecoveredParserResult Type +parseType = runRecoveredParser Parser.parseType <<< lex + +parseBinder :: String -> RecoveredParserResult Binder +parseBinder = runRecoveredParser Parser.parseBinder <<< lex + +newtype PartialModule e = PartialModule + { header :: ModuleHeader e + , full :: Z.Lazy (RecoveredParserResult Module) + } + +parsePartialModule :: String -> RecoveredParserResult PartialModule +parsePartialModule src = + toRecoveredParserResult $ case runParser' (initialParserState (lexModule src)) parseModuleHeader of + ParseSucc header state -> do + let + res = PartialModule + { header + , full: Z.defer \_ -> + toRecoveredParserResult $ fromParserResult $ runParser' state do + body <- parseModuleBody + pure $ Module { header, body } + } + Right $ Tuple res state.errors + ParseFail error _ -> + Left error diff --git a/src/PureScript/CST/Range/TokenList.purs b/src/PureScript/CST/TokenList.purs similarity index 97% rename from src/PureScript/CST/Range/TokenList.purs rename to src/PureScript/CST/TokenList.purs index 723fa10..1244ca2 100644 --- a/src/PureScript/CST/Range/TokenList.purs +++ b/src/PureScript/CST/TokenList.purs @@ -1,4 +1,4 @@ -module PureScript.CST.Range.TokenList +module PureScript.CST.TokenList ( TokenList , singleton , cons @@ -24,7 +24,7 @@ import Data.Maybe (Maybe(..)) import Data.Tuple (Tuple(..)) import Data.Unfoldable (class Unfoldable, unfoldr) import Partial.Unsafe (unsafePartial) -import PureScript.CST.Types (SourceToken) +import PureScript.CST (SourceToken) data TokenList = TokenEmpty diff --git a/src/PureScript/CST/TokenStream.purs b/src/PureScript/CST/TokenStream.purs index 9c60994..808f0a1 100644 --- a/src/PureScript/CST/TokenStream.purs +++ b/src/PureScript/CST/TokenStream.purs @@ -19,7 +19,7 @@ import Data.Newtype (class Newtype, unwrap) import Data.Tuple (Tuple(..)) import PureScript.CST.Errors (ParseError) import PureScript.CST.Layout (LayoutDelim(..), LayoutStack, currentIndent, isIndented, lytToken) -import PureScript.CST.Types (Comment, LineFeed, SourcePos, SourceToken, Token(..)) +import PureScript.CST (Comment, LineFeed, SourcePos, SourceToken, Token(..)) newtype TokenStream = TokenStream (Lazy TokenStep) diff --git a/src/PureScript/CST/Tokens.purs b/src/PureScript/CST/Tokens.purs new file mode 100644 index 0000000..8f2da92 --- /dev/null +++ b/src/PureScript/CST/Tokens.purs @@ -0,0 +1,462 @@ +module PureScript.CST.Tokens + ( class TokensOf + , tokensOf + ) where + +import Prelude +import Prim hiding (Row, Type) + +import Control.Lazy (defer) +import Data.Array.NonEmpty (NonEmptyArray) +import Data.Foldable (foldMap) +import Data.Maybe (Maybe(..)) +import Data.Tuple (Tuple(..)) +import PureScript.CST.Errors (RecoveredError(..)) +import PureScript.CST.TokenList (TokenList, cons, singleton) +import PureScript.CST.TokenList as TokenList +import PureScript.CST (AppSpine(..), Binder(..), ClassFundep(..), DataCtor(..), DataMembers(..), Declaration(..), DoStatement(..), Export(..), Expr(..), FixityOp(..), Foreign(..), Guarded(..), GuardedExpr(..), Import(..), ImportDecl(..), Instance(..), InstanceBinding(..), Labeled(..), LetBinding(..), Module(..), ModuleBody(..), ModuleHeader(..), Name(..), OneOrDelimited(..), PatternGuard(..), Prefixed(..), QualifiedName(..), RecordLabeled(..), RecordUpdate(..), Row(..), Separated(..), Type(..), TypeVarBinding(..), Where(..), Wrapped(..)) + +class TokensOf a where + tokensOf :: a -> TokenList + +instance tokensOfTuple :: (TokensOf a, TokensOf b) => TokensOf (Tuple a b) where + tokensOf (Tuple a b) = tokensOf a <> tokensOf b + +instance tokensOfMaybe :: TokensOf a => TokensOf (Maybe a) where + tokensOf = foldMap tokensOf + +instance tokensOfArray :: TokensOf a => TokensOf (Array a) where + tokensOf = foldMap (\a -> defer \_ -> tokensOf a) + +instance tokensOfNonEmptyArray :: TokensOf a => TokensOf (NonEmptyArray a) where + tokensOf = foldMap (\a -> defer \_ -> tokensOf a) + +instance tokensOfVoid :: TokensOf Void where + tokensOf = absurd + +instance tokensOfRecoveredError :: TokensOf RecoveredError where + tokensOf (RecoveredError { tokens }) = TokenList.fromArray tokens + +instance tokensOfModule :: TokensOf e => TokensOf (Module e) where + tokensOf (Module { header: ModuleHeader header, body: ModuleBody body }) = + cons header.keyword + $ tokensOf header.name + <> defer (\_ -> foldMap tokensOf header.exports) + <> singleton header.where + <> defer (\_ -> foldMap tokensOf header.imports) + <> defer (\_ -> foldMap tokensOf body.decls) + +instance tokensOfName :: TokensOf (Name a) where + tokensOf (Name { token }) = singleton token + +instance tokensOfQualifiedName :: TokensOf (QualifiedName a) where + tokensOf (QualifiedName { token }) = singleton token + +instance tokensOfWrapped :: TokensOf a => TokensOf (Wrapped a) where + tokensOf (Wrapped { open, value, close }) = + TokenList.wrap open (defer \_ -> tokensOf value) close + +instance tokensOfSeparated :: TokensOf a => TokensOf (Separated a) where + tokensOf (Separated { head, tail }) = + tokensOf head + <> defer \_ -> foldMap (\(Tuple a b) -> cons a $ defer (\_ -> tokensOf b)) tail + +instance tokensOfLabeled :: (TokensOf a, TokensOf b) => TokensOf (Labeled a b) where + tokensOf (Labeled { label, separator, value }) = + tokensOf label <> singleton separator <> tokensOf value + +instance tokensOfPrefixed :: TokensOf a => TokensOf (Prefixed a) where + tokensOf (Prefixed { prefix, value }) = + case prefix of + Just tok -> + cons tok $ defer \_ -> tokensOf value + Nothing -> + tokensOf value + +instance tokensOfOneOrDelimited :: TokensOf a => TokensOf (OneOrDelimited a) where + tokensOf = case _ of + One a -> tokensOf a + Many as -> tokensOf as + +instance tokensOfType :: TokensOf e => TokensOf (Type e) where + tokensOf = case _ of + TypeVar n -> + tokensOf n + TypeConstructor n -> + tokensOf n + TypeWildcard t -> + singleton t + TypeHole n -> + tokensOf n + TypeString t _ -> + singleton t + TypeInt neg t _ -> + foldMap singleton neg <> singleton t + TypeRow w -> + tokensOf w + TypeRecord w -> + tokensOf w + TypeForall t vars dot ty -> + cons t $ defer \_ -> + tokensOf vars + <> singleton dot + <> tokensOf ty + TypeKinded ty1 t ty2 -> + tokensOf ty1 + <> defer \_ -> singleton t <> tokensOf ty2 + TypeApp ty tys -> + tokensOf ty + <> defer \_ -> tokensOf tys + TypeOp ty ops -> + tokensOf ty + <> defer \_ -> foldMap (\(Tuple op arg) -> tokensOf op <> tokensOf arg) ops + TypeOpName n -> + tokensOf n + TypeArrow ty1 t ty2 -> + tokensOf ty1 + <> defer \_ -> singleton t <> tokensOf ty2 + TypeArrowName t -> + singleton t + TypeConstrained ty1 t ty2 -> + tokensOf ty1 + <> defer \_ -> singleton t <> tokensOf ty2 + TypeParens w -> + tokensOf w + TypeError e -> + tokensOf e + +instance tokensOfRow :: TokensOf e => TokensOf (Row e) where + tokensOf (Row { labels, tail }) = + foldMap tokensOf labels + <> foldMap (\(Tuple t ty) -> cons t $ tokensOf ty) tail + +instance tokensOfTypeVarBinding :: (TokensOf a, TokensOf e) => TokensOf (TypeVarBinding a e) where + tokensOf = case _ of + TypeVarKinded w -> + tokensOf w + TypeVarName n -> + tokensOf n + +instance tokensOfExport :: TokensOf e => TokensOf (Export e) where + tokensOf = case _ of + ExportValue n -> + tokensOf n + ExportOp n -> + tokensOf n + ExportType n dms -> + tokensOf n <> foldMap tokensOf dms + ExportTypeOp t n -> + cons t $ tokensOf n + ExportClass t n -> + cons t $ tokensOf n + ExportModule t n -> + cons t $ tokensOf n + ExportError e -> + tokensOf e + +instance tokensOfDataMembers :: TokensOf DataMembers where + tokensOf = case _ of + DataAll t -> + singleton t + DataEnumerated w -> + tokensOf w + +instance tokensOfImportDecl :: TokensOf e => TokensOf (ImportDecl e) where + tokensOf (ImportDecl { keyword, "module": mod, names, qualified }) = + cons keyword $ defer \_ -> + tokensOf mod + <> foldMap (\(Tuple hiding imports) -> foldMap singleton hiding <> defer (\_ -> tokensOf imports)) names + <> foldMap (\(Tuple as mn) -> singleton as <> tokensOf mn) qualified + +instance tokensOfImport :: TokensOf e => TokensOf (Import e) where + tokensOf = case _ of + ImportValue n -> + tokensOf n + ImportOp n -> + tokensOf n + ImportType n dms -> + tokensOf n <> foldMap tokensOf dms + ImportTypeOp t n -> + cons t $ tokensOf n + ImportClass t n -> + cons t $ tokensOf n + ImportError e -> + tokensOf e + +instance tokensOfDataCtor :: TokensOf e => TokensOf (DataCtor e) where + tokensOf (DataCtor { name, fields }) = + tokensOf name <> tokensOf fields + +instance tokensOfDecl :: TokensOf e => TokensOf (Declaration e) where + tokensOf = case _ of + DeclData { keyword, name, vars } ctors -> + cons keyword $ defer \_ -> + tokensOf name + <> tokensOf vars + <> foldMap (\(Tuple t cs) -> cons t $ tokensOf cs) ctors + DeclType { keyword, name, vars } tok ty -> + cons keyword $ defer \_ -> + tokensOf name + <> tokensOf vars + <> singleton tok + <> tokensOf ty + DeclNewtype { keyword, name, vars } tok n ty -> + cons keyword $ defer \_ -> + tokensOf name + <> tokensOf vars + <> singleton tok + <> tokensOf n + <> tokensOf ty + DeclClass { keyword, super, name, vars, fundeps } members -> + cons keyword $ defer \_ -> + foldMap (\(Tuple cs t) -> tokensOf cs <> singleton t) super + <> tokensOf name + <> tokensOf vars + <> foldMap (\(Tuple t fs) -> cons t $ tokensOf fs) fundeps + <> foldMap (\(Tuple t ls) -> cons t $ tokensOf ls) members + DeclInstanceChain insts -> + tokensOf insts + DeclDerive keyword tok inst -> + cons keyword $ defer \_ -> + foldMap singleton tok + <> singleton inst.keyword + <> foldMap (\(Tuple cs t) -> tokensOf cs <> singleton t) inst.name + <> foldMap (\(Tuple cs t) -> tokensOf cs <> singleton t) inst.constraints + <> tokensOf inst.className + <> tokensOf inst.types + DeclKindSignature keyword lbl -> + cons keyword $ defer \_ -> + tokensOf lbl + DeclSignature sig -> + tokensOf sig + DeclValue { name, binders, guarded } -> + tokensOf name <> defer \_ -> + tokensOf binders <> tokensOf guarded + DeclFixity { keyword: Tuple keyword _, prec: Tuple prec _, operator } -> + cons keyword $ defer \_ -> + cons prec $ tokensOf operator + DeclForeign keyword imp frn -> + cons keyword $ defer \_ -> + cons imp $ tokensOf frn + DeclRole keyword rl n roles -> + cons keyword $ defer \_ -> + singleton rl + <> tokensOf n + <> foldMap (\(Tuple t _) -> singleton t) roles + DeclError e -> + tokensOf e + +instance tokensOfClassFundep :: TokensOf ClassFundep where + tokensOf = case _ of + FundepDetermined t ns -> + cons t $ tokensOf ns + FundepDetermines ns1 t ns2 -> + tokensOf ns1 <> singleton t <> tokensOf ns2 + +instance tokensOfInstance :: TokensOf e => TokensOf (Instance e) where + tokensOf (Instance { head, body }) = + cons head.keyword $ defer \_ -> + foldMap (\(Tuple cs t) -> tokensOf cs <> singleton t) head.name + <> foldMap (\(Tuple cs t) -> tokensOf cs <> singleton t) head.constraints + <> tokensOf head.className + <> tokensOf head.types + <> foldMap (\(Tuple t bs) -> cons t $ tokensOf bs) body + +instance tokensOfGuarded :: TokensOf e => TokensOf (Guarded e) where + tokensOf = case _ of + Unconditional t wh -> + cons t $ tokensOf wh + Guarded gs -> + tokensOf gs + +instance tokensOfGuardedExpr :: TokensOf e => TokensOf (GuardedExpr e) where + tokensOf (GuardedExpr ge) = + cons ge.bar $ defer \_ -> + tokensOf ge.patterns + <> singleton ge.separator + <> tokensOf ge.where + +instance tokensOfPatternGuard :: TokensOf e => TokensOf (PatternGuard e) where + tokensOf (PatternGuard { binder, expr }) = + foldMap (\(Tuple b t) -> tokensOf b <> singleton t) binder + <> tokensOf expr + +instance tokensOfFixityOp :: TokensOf FixityOp where + tokensOf = case _ of + FixityValue n1 t n2 -> + tokensOf n1 <> singleton t <> tokensOf n2 + FixityType t1 n1 t2 n2 -> + cons t1 $ tokensOf n1 <> singleton t2 <> tokensOf n2 + +instance tokensOfForeign :: TokensOf e => TokensOf (Foreign e) where + tokensOf = case _ of + ForeignValue lbl -> + tokensOf lbl + ForeignData t lbl -> + cons t $ tokensOf lbl + ForeignKind t n -> + cons t $ tokensOf n + +instance tokensOfInstanceBinding :: TokensOf e => TokensOf (InstanceBinding e) where + tokensOf = case _ of + InstanceBindingSignature lbl -> + tokensOf lbl + InstanceBindingName { name, binders, guarded } -> + tokensOf name + <> tokensOf binders + <> tokensOf guarded + +instance tokensOfExpr :: TokensOf e => TokensOf (Expr e) where + tokensOf = case _ of + ExprHole n -> + tokensOf n + ExprSection t -> + singleton t + ExprIdent n -> + tokensOf n + ExprConstructor n -> + tokensOf n + ExprBoolean t _ -> + singleton t + ExprChar t _ -> + singleton t + ExprString t _ -> + singleton t + ExprInt t _ -> + singleton t + ExprNumber t _ -> + singleton t + ExprArray exprs -> + tokensOf exprs + ExprRecord exprs -> + tokensOf exprs + ExprParens w -> + tokensOf w + ExprTyped expr t ty -> + tokensOf expr <> defer \_ -> cons t $ tokensOf ty + ExprInfix expr ops -> + tokensOf expr <> defer \_ -> tokensOf ops + ExprOp expr ops -> + tokensOf expr <> defer \_ -> tokensOf ops + ExprOpName n -> + tokensOf n + ExprNegate t expr -> + cons t $ tokensOf expr + ExprRecordAccessor { expr, dot, path } -> + tokensOf expr <> defer \_ -> cons dot $ tokensOf path + ExprRecordUpdate expr upds -> + tokensOf expr <> defer \_ -> tokensOf upds + ExprApp expr exprs -> + tokensOf expr <> defer \_ -> tokensOf exprs + ExprLambda { symbol, binders, arrow, body } -> + cons symbol $ defer \_ -> + tokensOf binders + <> singleton arrow + <> tokensOf body + ExprIf ifte -> + cons ifte.keyword $ defer \_ -> + tokensOf ifte.cond + <> singleton ifte.then + <> tokensOf ifte.true + <> singleton ifte.else + <> tokensOf ifte.false + ExprCase cs -> + cons cs.keyword $ defer \_ -> + tokensOf cs.head + <> singleton cs.of + <> tokensOf cs.branches + ExprLet lt -> + cons lt.keyword $ defer \_ -> + tokensOf lt.bindings + <> singleton lt.in + <> tokensOf lt.body + ExprDo { keyword, statements } -> + cons keyword $ defer \_ -> tokensOf statements + ExprAdo block -> + cons block.keyword $ defer \_ -> + tokensOf block.statements + <> singleton block.in + <> tokensOf block.result + ExprError e -> + tokensOf e + +instance tokensOfAppSpine :: (TokensOf e, TokensOf (f e)) => TokensOf (AppSpine f e) where + tokensOf = case _ of + AppType t a -> + cons t $ defer \_ -> tokensOf a + AppTerm a -> + tokensOf a + +instance tokensOfRecordUpdate :: TokensOf e => TokensOf (RecordUpdate e) where + tokensOf = case _ of + RecordUpdateLeaf n t e -> + tokensOf n <> singleton t <> tokensOf e + RecordUpdateBranch n us -> + tokensOf n <> tokensOf us + +instance tokensOfDoStatement :: TokensOf e => TokensOf (DoStatement e) where + tokensOf = case _ of + DoLet t bindings -> + cons t $ defer \_ -> tokensOf bindings + DoDiscard expr -> + tokensOf expr + DoBind b t expr -> + tokensOf b <> defer \_ -> cons t $ tokensOf expr + DoError e -> + tokensOf e + +instance tokensOfLetBinding :: TokensOf e => TokensOf (LetBinding e) where + tokensOf = case _ of + LetBindingSignature lbl -> + tokensOf lbl + LetBindingName { name, binders, guarded } -> + tokensOf name <> defer \_ -> tokensOf binders <> tokensOf guarded + LetBindingPattern b t wh -> + tokensOf b <> defer \_ -> cons t $ tokensOf wh + LetBindingError e -> + tokensOf e + +instance tokensOfBinder :: TokensOf e => TokensOf (Binder e) where + tokensOf = case _ of + BinderWildcard t -> + singleton t + BinderVar n -> + tokensOf n + BinderNamed n t b -> + tokensOf n <> defer \_ -> cons t $ tokensOf b + BinderConstructor n bs -> + tokensOf n <> defer \_ -> tokensOf bs + BinderBoolean t _ -> + singleton t + BinderChar t _ -> + singleton t + BinderString t _ -> + singleton t + BinderInt neg t _ -> + foldMap singleton neg <> singleton t + BinderNumber neg t _ -> + foldMap singleton neg <> singleton t + BinderArray bs -> + tokensOf bs + BinderRecord bs -> + tokensOf bs + BinderParens b -> + tokensOf b + BinderTyped b t ty -> + tokensOf b <> defer \_ -> cons t $ tokensOf ty + BinderOp b ops -> + tokensOf b <> defer \_ -> tokensOf ops + BinderError e -> + tokensOf e + +instance tokensOfRecordLabeled :: TokensOf a => TokensOf (RecordLabeled a) where + tokensOf = case _ of + RecordPun n -> + tokensOf n + RecordField n t a -> + tokensOf n <> defer \_ -> cons t $ tokensOf a + +instance tokensOfWhere :: TokensOf e => TokensOf (Where e) where + tokensOf (Where { expr, bindings }) = + tokensOf expr <> defer \_ -> + foldMap (\(Tuple t bs) -> cons t $ tokensOf bs) bindings diff --git a/src/PureScript/CST/Traversal.purs b/src/PureScript/CST/Traversal.purs index dd9eba4..6e0917e 100644 --- a/src/PureScript/CST/Traversal.purs +++ b/src/PureScript/CST/Traversal.purs @@ -111,7 +111,7 @@ import Data.Newtype (un) import Data.Traversable (traverse) import Data.Tuple (Tuple(..), curry, uncurry) import Prim as P -import PureScript.CST.Types (AdoBlock, AppSpine(..), Binder(..), CaseOf, ClassHead, DataCtor(..), DataHead, Declaration(..), Delimited, DelimitedNonEmpty, DoBlock, DoStatement(..), Expr(..), Foreign(..), Guarded(..), GuardedExpr(..), IfThenElse, Instance(..), InstanceBinding(..), InstanceHead, Labeled(..), Lambda, LetBinding(..), LetIn, Module(..), ModuleBody(..), OneOrDelimited(..), PatternGuard(..), RecordAccessor, RecordLabeled(..), RecordUpdate(..), Row(..), Separated(..), Type(..), TypeVarBinding(..), ValueBindingFields, Where(..), Wrapped(..)) +import PureScript.CST (AdoBlock, AppSpine(..), Binder(..), CaseOf, ClassHead, DataCtor(..), DataHead, Declaration(..), Delimited, DelimitedNonEmpty, DoBlock, DoStatement(..), Expr(..), Foreign(..), Guarded(..), GuardedExpr(..), IfThenElse, Instance(..), InstanceBinding(..), InstanceHead, Labeled(..), Lambda, LetBinding(..), LetIn, Module(..), ModuleBody(..), OneOrDelimited(..), PatternGuard(..), RecordAccessor, RecordLabeled(..), RecordUpdate(..), Row(..), Separated(..), Type(..), TypeVarBinding(..), ValueBindingFields, Where(..), Wrapped(..)) import Type.Row (type (+)) type Rewrite e f (g :: P.Type -> P.Type) = g e -> f (g e) diff --git a/src/PureScript/CST/Types.purs b/src/PureScript/CST/Types.purs deleted file mode 100644 index 7952771..0000000 --- a/src/PureScript/CST/Types.purs +++ /dev/null @@ -1,489 +0,0 @@ -module PureScript.CST.Types where - -import Prelude - -import Data.Array.NonEmpty (NonEmptyArray) -import Data.Either (Either) -import Data.Maybe (Maybe) -import Data.Newtype (class Newtype) -import Data.Tuple (Tuple) -import Prim hiding (Row, Type) - -newtype ModuleName = ModuleName String - -derive newtype instance eqModuleName :: Eq ModuleName -derive newtype instance ordModuleName :: Ord ModuleName -derive instance newtypeModuleName :: Newtype ModuleName _ - -type SourcePos = - { line :: Int - , column :: Int - } - -type SourceRange = - { start :: SourcePos - , end :: SourcePos - } - -data Comment l - = Comment String - | Space Int - | Line l Int - -data LineFeed - = LF - | CRLF - -data SourceStyle - = ASCII - | Unicode - -derive instance eqSourceStyle :: Eq SourceStyle - -data IntValue - = SmallInt Int - | BigInt String - | BigHex String - -derive instance eqIntValue :: Eq IntValue - -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 - | TokAt - | TokLowerName (Maybe ModuleName) String - | TokUpperName (Maybe ModuleName) String - | TokOperator (Maybe ModuleName) String - | TokSymbolName (Maybe ModuleName) String - | TokSymbolArrow SourceStyle - | TokHole String - | TokChar String Char - | TokString String String - | TokRawString String - | TokInt String IntValue - | TokNumber String Number - | TokLayoutStart Int - | TokLayoutSep Int - | TokLayoutEnd Int - -derive instance eqToken :: Eq Token - -type SourceToken = - { range :: SourceRange - , leadingComments :: Array (Comment LineFeed) - , trailingComments :: Array (Comment Void) - , value :: Token - } - -newtype Ident = Ident String - -derive newtype instance eqIdent :: Eq Ident -derive newtype instance ordIdent :: Ord Ident -derive instance newtypeIdent :: Newtype Ident _ - -newtype Proper = Proper String - -derive newtype instance eqProper :: Eq Proper -derive newtype instance ordProper :: Ord Proper -derive instance newtypeProper :: Newtype Proper _ - -newtype Label = Label String - -derive newtype instance eqLabel :: Eq Label -derive newtype instance ordLabel :: Ord Label -derive instance newtypeLabel :: Newtype Label _ - -newtype Operator = Operator String - -derive newtype instance eqOperator :: Eq Operator -derive newtype instance ordOperator :: Ord Operator -derive instance newtypeOperator :: Newtype Operator _ - -newtype Name a = Name - { token :: SourceToken - , name :: a - } - -derive instance newtypeName :: Newtype (Name a) _ - -newtype QualifiedName a = QualifiedName - { token :: SourceToken - , module :: Maybe ModuleName - , name :: a - } - -derive instance newtypeQualifiedName :: Newtype (QualifiedName a) _ - -newtype Wrapped a = Wrapped - { open :: SourceToken - , value :: a - , close :: SourceToken - } - -derive instance newtypeWrapped :: Newtype (Wrapped a) _ - -newtype Separated a = Separated - { head :: a - , tail :: Array (Tuple SourceToken a) - } - -derive instance newtypeSeparated :: Newtype (Separated a) _ - -newtype Labeled a b = Labeled - { label :: a - , separator :: SourceToken - , value :: b - } - -derive instance newtypeLabeled :: Newtype (Labeled a b) _ - -newtype Prefixed a = Prefixed - { prefix :: Maybe SourceToken - , value :: a - } - -derive instance newtypePrefixed :: Newtype (Prefixed a) _ - -type Delimited a = Wrapped (Maybe (Separated a)) -type DelimitedNonEmpty a = Wrapped (Separated a) - -data OneOrDelimited a - = One a - | Many (DelimitedNonEmpty a) - -data Type e - = TypeVar (Name Ident) - | TypeConstructor (QualifiedName Proper) - | TypeWildcard SourceToken - | TypeHole (Name Ident) - | TypeString SourceToken String - | TypeInt (Maybe SourceToken) SourceToken IntValue - | TypeRow (Wrapped (Row e)) - | TypeRecord (Wrapped (Row e)) - | TypeForall SourceToken (NonEmptyArray (TypeVarBinding (Prefixed (Name Ident)) e)) SourceToken (Type e) - | TypeKinded (Type e) SourceToken (Type e) - | TypeApp (Type e) (NonEmptyArray (Type e)) - | TypeOp (Type e) (NonEmptyArray (Tuple (QualifiedName Operator) (Type e))) - | TypeOpName (QualifiedName Operator) - | TypeArrow (Type e) SourceToken (Type e) - | TypeArrowName SourceToken - | TypeConstrained (Type e) SourceToken (Type e) - | TypeParens (Wrapped (Type e)) - | TypeError e - -data TypeVarBinding a e - = TypeVarKinded (Wrapped (Labeled a (Type e))) - | TypeVarName a - -newtype Row e = Row - { labels :: Maybe (Separated (Labeled (Name Label) (Type e))) - , tail :: Maybe (Tuple SourceToken (Type e)) - } - -derive instance newtypeRow :: Newtype (Row e) _ - -newtype Module e = Module - { header :: ModuleHeader e - , body :: ModuleBody e - } - -derive instance newtypeModule :: Newtype (Module e) _ - -newtype ModuleHeader e = ModuleHeader - { keyword :: SourceToken - , name :: Name ModuleName - , exports :: Maybe (DelimitedNonEmpty (Export e)) - , where :: SourceToken - , imports :: Array (ImportDecl e) - } - -derive instance newtypeModuleHeader :: Newtype (ModuleHeader e) _ - -newtype ModuleBody e = ModuleBody - { decls :: Array (Declaration e) - , trailingComments :: Array (Comment LineFeed) - , end :: SourcePos - } - -derive instance newtypeModuleBody :: Newtype (ModuleBody e) _ - -data Export e - = ExportValue (Name Ident) - | ExportOp (Name Operator) - | ExportType (Name Proper) (Maybe DataMembers) - | ExportTypeOp SourceToken (Name Operator) - | ExportClass SourceToken (Name Proper) - | ExportModule SourceToken (Name ModuleName) - | ExportError e - -data DataMembers - = DataAll SourceToken - | DataEnumerated (Delimited (Name Proper)) - -data Declaration e - = DeclData (DataHead e) (Maybe (Tuple SourceToken (Separated (DataCtor e)))) - | DeclType (DataHead e) SourceToken (Type e) - | DeclNewtype (DataHead e) SourceToken (Name Proper) (Type e) - | DeclClass (ClassHead e) (Maybe (Tuple SourceToken (NonEmptyArray (Labeled (Name Ident) (Type e))))) - | DeclInstanceChain (Separated (Instance e)) - | DeclDerive SourceToken (Maybe SourceToken) (InstanceHead e) - | DeclKindSignature SourceToken (Labeled (Name Proper) (Type e)) - | DeclSignature (Labeled (Name Ident) (Type e)) - | DeclValue (ValueBindingFields e) - | DeclFixity FixityFields - | DeclForeign SourceToken SourceToken (Foreign e) - | DeclRole SourceToken SourceToken (Name Proper) (NonEmptyArray (Tuple SourceToken Role)) - | DeclError e - -newtype Instance e = Instance - { head :: InstanceHead e - , body :: Maybe (Tuple SourceToken (NonEmptyArray (InstanceBinding e))) - } - -derive instance newtypeInstance :: Newtype (Instance e) _ - -data InstanceBinding e - = InstanceBindingSignature (Labeled (Name Ident) (Type e)) - | InstanceBindingName (ValueBindingFields e) - -newtype ImportDecl e = ImportDecl - { keyword :: SourceToken - , module :: Name ModuleName - , names :: Maybe (Tuple (Maybe SourceToken) (DelimitedNonEmpty (Import e))) - , qualified :: Maybe (Tuple SourceToken (Name ModuleName)) - } - -derive instance newtypeImportDecl :: Newtype (ImportDecl e) _ - -data Import e - = ImportValue (Name Ident) - | ImportOp (Name Operator) - | ImportType (Name Proper) (Maybe DataMembers) - | ImportTypeOp SourceToken (Name Operator) - | ImportClass SourceToken (Name Proper) - | ImportError e - -type DataHead e = - { keyword :: SourceToken - , name :: Name Proper - , vars :: Array (TypeVarBinding (Name Ident) e) - } - -newtype DataCtor e = DataCtor - { name :: Name Proper - , fields :: Array (Type e) - } - -derive instance newtypeDataCtor :: Newtype (DataCtor e) _ - -type ClassHead e = - { keyword :: SourceToken - , super :: Maybe (Tuple (OneOrDelimited (Type e)) SourceToken) - , name :: Name Proper - , vars :: Array (TypeVarBinding (Name Ident) e) - , fundeps :: Maybe (Tuple SourceToken (Separated ClassFundep)) - } - -data ClassFundep - = FundepDetermined SourceToken (NonEmptyArray (Name Ident)) - | FundepDetermines (NonEmptyArray (Name Ident)) SourceToken (NonEmptyArray (Name Ident)) - -type InstanceHead e = - { keyword :: SourceToken - , name :: Maybe (Tuple (Name Ident) SourceToken) - , constraints :: Maybe (Tuple (OneOrDelimited (Type e)) SourceToken) - , className :: QualifiedName Proper - , types :: Array (Type e) - } - -data Fixity - = Infix - | Infixl - | Infixr - -data FixityOp - = FixityValue (QualifiedName (Either Ident Proper)) SourceToken (Name Operator) - | FixityType SourceToken (QualifiedName Proper) SourceToken (Name Operator) - -type FixityFields = - { keyword :: Tuple SourceToken Fixity - , prec :: Tuple SourceToken Int - , operator :: FixityOp - } - -type ValueBindingFields e = - { name :: Name Ident - , binders :: Array (Binder e) - , guarded :: Guarded e - } - -data Guarded e - = Unconditional SourceToken (Where e) - | Guarded (NonEmptyArray (GuardedExpr e)) - -newtype GuardedExpr e = GuardedExpr - { bar :: SourceToken - , patterns :: Separated (PatternGuard e) - , separator :: SourceToken - , where :: Where e - } - -derive instance newtypeGuardedExpr :: Newtype (GuardedExpr e) _ - -newtype PatternGuard e = PatternGuard - { binder :: Maybe (Tuple (Binder e) SourceToken) - , expr :: Expr e - } - -derive instance newtypePatternGuard :: Newtype (PatternGuard e) _ - -data Foreign e - = ForeignValue (Labeled (Name Ident) (Type e)) - | ForeignData SourceToken (Labeled (Name Proper) (Type e)) - | ForeignKind SourceToken (Name Proper) - -data Role - = Nominal - | Representational - | Phantom - -data Expr e - = ExprHole (Name Ident) - | ExprSection SourceToken - | ExprIdent (QualifiedName Ident) - | ExprConstructor (QualifiedName Proper) - | ExprBoolean SourceToken Boolean - | ExprChar SourceToken Char - | ExprString SourceToken String - | ExprInt SourceToken IntValue - | ExprNumber SourceToken Number - | ExprArray (Delimited (Expr e)) - | ExprRecord (Delimited (RecordLabeled (Expr e))) - | ExprParens (Wrapped (Expr e)) - | ExprTyped (Expr e) SourceToken (Type e) - | ExprInfix (Expr e) (NonEmptyArray (Tuple (Wrapped (Expr e)) (Expr e))) - | ExprOp (Expr e) (NonEmptyArray (Tuple (QualifiedName Operator) (Expr e))) - | ExprOpName (QualifiedName Operator) - | ExprNegate SourceToken (Expr e) - | ExprRecordAccessor (RecordAccessor e) - | ExprRecordUpdate (Expr e) (DelimitedNonEmpty (RecordUpdate e)) - | ExprApp (Expr e) (NonEmptyArray (AppSpine Expr e)) - | ExprLambda (Lambda e) - | ExprIf (IfThenElse e) - | ExprCase (CaseOf e) - | ExprLet (LetIn e) - | ExprDo (DoBlock e) - | ExprAdo (AdoBlock e) - | ExprError e - -data AppSpine f e - = AppType SourceToken (Type e) - | AppTerm (f e) - -data RecordLabeled a - = RecordPun (Name Ident) - | RecordField (Name Label) SourceToken a - -data RecordUpdate e - = RecordUpdateLeaf (Name Label) SourceToken (Expr e) - | RecordUpdateBranch (Name Label) (DelimitedNonEmpty (RecordUpdate e)) - -type RecordAccessor e = - { expr :: Expr e - , dot :: SourceToken - , path :: Separated (Name Label) - } - -type Lambda e = - { symbol :: SourceToken - , binders :: NonEmptyArray (Binder e) - , arrow :: SourceToken - , body :: Expr e - } - -type IfThenElse e = - { keyword :: SourceToken - , cond :: Expr e - , then :: SourceToken - , true :: Expr e - , else :: SourceToken - , false :: Expr e - } - -type CaseOf e = - { keyword :: SourceToken - , head :: Separated (Expr e) - , of :: SourceToken - , branches :: NonEmptyArray (Tuple (Separated (Binder e)) (Guarded e)) - } - -type LetIn e = - { keyword :: SourceToken - , bindings :: NonEmptyArray (LetBinding e) - , in :: SourceToken - , body :: Expr e - } - -newtype Where e = Where - { expr :: Expr e - , bindings :: Maybe (Tuple SourceToken (NonEmptyArray (LetBinding e))) - } - -derive instance newtypeWhere :: Newtype (Where e) _ - -data LetBinding e - = LetBindingSignature (Labeled (Name Ident) (Type e)) - | LetBindingName (ValueBindingFields e) - | LetBindingPattern (Binder e) SourceToken (Where e) - | LetBindingError e - -type DoBlock e = - { keyword :: SourceToken - , statements :: NonEmptyArray (DoStatement e) - } - -data DoStatement e - = DoLet SourceToken (NonEmptyArray (LetBinding e)) - | DoDiscard (Expr e) - | DoBind (Binder e) SourceToken (Expr e) - | DoError e - -type AdoBlock e = - { keyword :: SourceToken - , statements :: Array (DoStatement e) - , in :: SourceToken - , result :: Expr e - } - -data Binder e - = BinderWildcard SourceToken - | BinderVar (Name Ident) - | BinderNamed (Name Ident) SourceToken (Binder e) - | BinderConstructor (QualifiedName Proper) (Array (Binder e)) - | BinderBoolean SourceToken Boolean - | BinderChar SourceToken Char - | BinderString SourceToken String - | BinderInt (Maybe SourceToken) SourceToken IntValue - | BinderNumber (Maybe SourceToken) SourceToken Number - | BinderArray (Delimited (Binder e)) - | BinderRecord (Delimited (RecordLabeled (Binder e))) - | BinderParens (Wrapped (Binder e)) - | BinderTyped (Binder e) SourceToken (Type e) - | BinderOp (Binder e) (NonEmptyArray (Tuple (QualifiedName Operator) (Binder e))) - | BinderError e diff --git a/test/Main.purs b/test/Main.purs index b4dd1cd..0d9fbce 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -12,8 +12,8 @@ import Data.String.CodeUnits as SCU import Effect (Effect) import Effect.Class.Console as Console import Node.Process as Process -import PureScript.CST (RecoveredParserResult(..), parseBinder, parseDecl, parseExpr, parseModule, parseType) -import PureScript.CST.Types (AppSpine(..), Binder, Comment(..), Declaration(..), DoStatement(..), Expr(..), Label(..), Labeled(..), LetBinding(..), LineFeed(..), Module(..), ModuleBody(..), ModuleHeader(..), Name(..), Prefixed(..), RecordLabeled(..), Separated(..), Token(..), Type(..), TypeVarBinding(..), Wrapped(..)) +import PureScript.CST.Recovered (RecoveredParserResult(..), parseBinder, parseDecl, parseExpr, parseModule, parseType) +import PureScript.CST (AppSpine(..), Binder, Comment(..), Declaration(..), DoStatement(..), Expr(..), Label(..), Labeled(..), LetBinding(..), LineFeed(..), Module(..), ModuleBody(..), ModuleHeader(..), Name(..), Prefixed(..), RecordLabeled(..), Separated(..), Token(..), Type(..), TypeVarBinding(..), Wrapped(..)) class ParseFor f where parseFor :: String -> RecoveredParserResult f