module Language.PureScript.Parser.Declarations (
parseDeclaration,
parseModule,
parseModules,
parseValue,
parseGuard,
parseBinder,
parseBinderNoParens,
) where
import Data.Maybe (isJust, fromMaybe)
import Control.Applicative
import Language.PureScript.Parser.State
import Language.PureScript.Parser.Common
import Language.PureScript.Declarations
import Language.PureScript.Parser.Types
import Language.PureScript.Parser.Kinds
import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.Environment
import qualified Language.PureScript.Parser.Common as C
import qualified Text.Parsec as P
import qualified Text.Parsec.Expr as P
sourcePos :: P.Parsec s u SourcePos
sourcePos = toSourcePos <$> P.getPosition
where
toSourcePos p = SourcePos (P.sourceName p) (P.sourceLine p) (P.sourceColumn p)
parseDataDeclaration :: P.Parsec String ParseState Declaration
parseDataDeclaration = do
reserved "data"
name <- indented *> properName
tyArgs <- many (indented *> identifier)
ctors <- P.option [] $ do
_ <- lexeme $ indented *> P.char '='
sepBy1 ((,) <$> properName <*> P.many (indented *> parseTypeAtom)) pipe
return $ DataDeclaration name tyArgs ctors
parseTypeDeclaration :: P.Parsec String ParseState Declaration
parseTypeDeclaration =
TypeDeclaration <$> P.try (parseIdent <* lexeme (indented *> P.string "::"))
<*> parsePolyType
parseTypeSynonymDeclaration :: P.Parsec String ParseState Declaration
parseTypeSynonymDeclaration =
TypeSynonymDeclaration <$> (P.try (reserved "type") *> indented *> properName)
<*> many (indented *> identifier)
<*> (lexeme (indented *> P.char '=') *> parsePolyType)
parseValueDeclaration :: P.Parsec String ParseState Declaration
parseValueDeclaration = do
name <- parseIdent
binders <- P.many parseBinderNoParens
guard <- P.optionMaybe parseGuard
value <- lexeme (indented *> P.char '=') *> parseValue
whereClause <- P.optionMaybe $ do
C.indented
reserved "where"
C.indented
C.mark $ P.many1 (C.same *> parseLocalDeclaration)
return $ ValueDeclaration name Value binders guard (maybe value (`Let` value) whereClause)
parseExternDeclaration :: P.Parsec String ParseState Declaration
parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "import" *> indented *>
(ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)
<*> (lexeme (indented *> P.string "::") *> parseKind)
<|> (do reserved "instance"
name <- parseIdent <* lexeme (indented *> P.string "::")
deps <- P.option [] $ do
deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many parseTypeAtom))
indented
reservedOp "=>"
return deps
className <- indented *> parseQualified properName
tys <- P.many (indented *> parseTypeAtom)
return $ ExternInstanceDeclaration name deps className tys)
<|> (do ident <- parseIdent
js <- P.optionMaybe (JSRaw <$> stringLiteral)
ty <- lexeme (indented *> P.string "::") *> parsePolyType
return $ ExternDeclaration (if isJust js then InlineJavascript else ForeignImport) ident js ty))
parseAssociativity :: P.Parsec String ParseState Associativity
parseAssociativity =
(P.try (reserved "infixl") >> return Infixl) <|>
(P.try (reserved "infixr") >> return Infixr) <|>
(P.try (reserved "infix") >> return Infix)
parseFixity :: P.Parsec String ParseState Fixity
parseFixity = Fixity <$> parseAssociativity <*> (indented *> natural)
parseFixityDeclaration :: P.Parsec String ParseState Declaration
parseFixityDeclaration = do
fixity <- parseFixity
indented
name <- operator
return $ FixityDeclaration fixity name
parseImportDeclaration :: P.Parsec String ParseState Declaration
parseImportDeclaration = do
reserved "import"
indented
qualImport <|> stdImport
where
stdImport = do
moduleName' <- moduleName
idents <- P.optionMaybe $ parens $ commaSep parseDeclarationRef
return $ ImportDeclaration moduleName' idents Nothing
qualImport = do
reserved "qualified"
indented
moduleName' <- moduleName
idents <- P.optionMaybe $ parens $ commaSep parseDeclarationRef
reserved "as"
asQ <- moduleName
return $ ImportDeclaration moduleName' idents (Just asQ)
parseDeclarationRef :: P.Parsec String ParseState DeclarationRef
parseDeclarationRef = PositionedDeclarationRef <$> sourcePos <*>
(ValueRef <$> parseIdent
<|> do name <- properName
dctors <- P.optionMaybe $ parens (lexeme (P.string "..") *> pure Nothing <|> Just <$> commaSep properName)
return $ maybe (TypeClassRef name) (TypeRef name) dctors)
parseTypeClassDeclaration :: P.Parsec String ParseState Declaration
parseTypeClassDeclaration = do
reserved "class"
implies <- P.option [] $ do
indented
implies <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many parseTypeAtom))
reservedOp "<="
return implies
className <- indented *> properName
idents <- P.many (indented *> identifier)
members <- P.option [] . P.try $ do
indented *> reserved "where"
mark (P.many (same *> positioned parseTypeDeclaration))
return $ TypeClassDeclaration className idents implies members
parseTypeInstanceDeclaration :: P.Parsec String ParseState Declaration
parseTypeInstanceDeclaration = do
reserved "instance"
name <- parseIdent <* lexeme (indented *> P.string "::")
deps <- P.optionMaybe $ do
deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many parseTypeAtom))
indented
reservedOp "=>"
return deps
className <- indented *> parseQualified properName
ty <- P.many (indented *> parseTypeAtom)
members <- P.option [] . P.try $ do
indented *> reserved "where"
mark (P.many (same *> positioned parseValueDeclaration))
return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty members
positioned :: P.Parsec String ParseState Declaration -> P.Parsec String ParseState Declaration
positioned d = PositionedDeclaration <$> sourcePos <*> d
parseDeclaration :: P.Parsec String ParseState Declaration
parseDeclaration = positioned (P.choice
[ parseDataDeclaration
, parseTypeDeclaration
, parseTypeSynonymDeclaration
, parseValueDeclaration
, parseExternDeclaration
, parseFixityDeclaration
, parseImportDeclaration
, parseTypeClassDeclaration
, parseTypeInstanceDeclaration
]) P.<?> "declaration"
parseLocalDeclaration :: P.Parsec String ParseState Declaration
parseLocalDeclaration = PositionedDeclaration <$> sourcePos <*> P.choice
[ parseTypeDeclaration
, parseValueDeclaration
] P.<?> "local declaration"
parseModule :: P.Parsec String ParseState Module
parseModule = do
reserved "module"
indented
name <- moduleName
exports <- P.optionMaybe $ parens $ commaSep1 parseDeclarationRef
_ <- lexeme $ P.string "where"
decls <- mark (P.many (same *> parseDeclaration))
return $ Module name decls exports
parseModules :: P.Parsec String ParseState [Module]
parseModules = whiteSpace *> mark (P.many (same *> parseModule)) <* P.eof
booleanLiteral :: P.Parsec String ParseState Bool
booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)
parseNumericLiteral :: P.Parsec String ParseState Value
parseNumericLiteral = NumericLiteral <$> C.integerOrFloat
parseStringLiteral :: P.Parsec String ParseState Value
parseStringLiteral = StringLiteral <$> C.stringLiteral
parseBooleanLiteral :: P.Parsec String ParseState Value
parseBooleanLiteral = BooleanLiteral <$> booleanLiteral
parseArrayLiteral :: P.Parsec String ParseState Value
parseArrayLiteral = ArrayLiteral <$> C.squares (C.commaSep parseValue)
parseObjectLiteral :: P.Parsec String ParseState Value
parseObjectLiteral = ObjectLiteral <$> C.braces (C.commaSep parseIdentifierAndValue)
parseIdentifierAndValue :: P.Parsec String ParseState (String, Value)
parseIdentifierAndValue = (,) <$> (C.indented *> (C.identifier <|> C.stringLiteral) <* C.indented <* C.colon)
<*> (C.indented *> parseValue)
parseAbs :: P.Parsec String ParseState Value
parseAbs = do
C.reservedOp "\\"
args <- P.many1 (C.indented *> (Abs <$> (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens)))
C.indented *> C.reservedOp "->"
value <- parseValue
return $ toFunction args value
where
toFunction :: [Value -> Value] -> Value -> Value
toFunction args value = foldr ($) value args
parseVar :: P.Parsec String ParseState Value
parseVar = Var <$> C.parseQualified C.parseIdent
parseConstructor :: P.Parsec String ParseState Value
parseConstructor = Constructor <$> C.parseQualified C.properName
parseCase :: P.Parsec String ParseState Value
parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") (return <$> parseValue)
<*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))
parseCaseAlternative :: P.Parsec String ParseState CaseAlternative
parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder)
<*> P.optionMaybe parseGuard
<*> (C.indented *> C.reservedOp "->" *> parseValue)
P.<?> "case alternative"
parseIfThenElse :: P.Parsec String ParseState Value
parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parseValue)
<*> (C.indented *> C.reserved "then" *> C.indented *> parseValue)
<*> (C.indented *> C.reserved "else" *> C.indented *> parseValue)
parseLet :: P.Parsec String ParseState Value
parseLet = do
C.reserved "let"
C.indented
ds <- C.mark $ P.many1 (C.same *> parseLocalDeclaration)
C.indented
C.reserved "in"
result <- parseValue
return $ Let ds result
parseValueAtom :: P.Parsec String ParseState Value
parseValueAtom = P.choice
[ P.try parseNumericLiteral
, P.try parseStringLiteral
, P.try parseBooleanLiteral
, parseArrayLiteral
, P.try parseObjectLiteral
, parseAbs
, P.try parseConstructor
, P.try parseVar
, parseCase
, parseIfThenElse
, parseDo
, parseLet
, Parens <$> C.parens parseValue ]
parsePropertyUpdate :: P.Parsec String ParseState (String, Value)
parsePropertyUpdate = do
name <- C.lexeme (C.identifier <|> C.stringLiteral)
_ <- C.lexeme $ C.indented *> P.char '='
value <- C.indented *> parseValue
return (name, value)
parseAccessor :: Value -> P.Parsec String ParseState Value
parseAccessor (Constructor _) = P.unexpected "constructor"
parseAccessor obj = P.try $ Accessor <$> (C.indented *> C.dot *> P.notFollowedBy C.opLetter *> C.indented *> (C.identifier <|> C.stringLiteral)) <*> pure obj
parseDo :: P.Parsec String ParseState Value
parseDo = do
C.reserved "do"
C.indented
Do <$> C.mark (P.many (C.same *> C.mark parseDoNotationElement))
parseDoNotationLet :: P.Parsec String ParseState DoNotationElement
parseDoNotationLet = DoNotationLet <$> (C.reserved "let" *> C.indented *> C.mark (P.many1 (C.same *> parseLocalDeclaration)))
parseDoNotationBind :: P.Parsec String ParseState DoNotationElement
parseDoNotationBind = DoNotationBind <$> parseBinder <*> (C.indented *> C.reservedOp "<-" *> parseValue)
parseDoNotationElement :: P.Parsec String ParseState DoNotationElement
parseDoNotationElement = P.choice
[ P.try parseDoNotationBind
, parseDoNotationLet
, P.try (DoNotationValue <$> parseValue) ]
parseValue :: P.Parsec String ParseState Value
parseValue = PositionedValue <$> sourcePos <*>
(P.buildExpressionParser operators
. C.buildPostfixParser postfixTable2
$ indexersAndAccessors) P.<?> "expression"
where
indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom
postfixTable1 = [ parseAccessor
, \v -> P.try $ flip ObjectUpdate <$> (C.indented *> C.braces (C.commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]
postfixTable2 = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v
, \v -> flip (TypedValue True) <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) <*> pure v
]
operators = [ [ P.Prefix (C.lexeme (P.try (C.indented *> P.char '-') >> return UnaryMinus))
]
, [ P.Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident ->
return (BinaryNoParens ident))) P.AssocRight
]
]
parseStringBinder :: P.Parsec String ParseState Binder
parseStringBinder = StringBinder <$> C.stringLiteral
parseBooleanBinder :: P.Parsec String ParseState Binder
parseBooleanBinder = BooleanBinder <$> booleanLiteral
parseNumberBinder :: P.Parsec String ParseState Binder
parseNumberBinder = NumberBinder <$> C.integerOrFloat
parseVarBinder :: P.Parsec String ParseState Binder
parseVarBinder = VarBinder <$> C.parseIdent
parseNullaryConstructorBinder :: P.Parsec String ParseState Binder
parseNullaryConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> pure []
parseConstructorBinder :: P.Parsec String ParseState Binder
parseConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> many (C.indented *> parseBinderNoParens)
parseObjectBinder :: P.Parsec String ParseState Binder
parseObjectBinder = ObjectBinder <$> C.braces (C.commaSep (C.indented *> parseIdentifierAndBinder))
parseArrayBinder :: P.Parsec String ParseState Binder
parseArrayBinder = C.squares $ ArrayBinder <$> C.commaSep (C.indented *> parseBinder)
parseNamedBinder :: P.Parsec String ParseState Binder
parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* C.lexeme (P.char '@'))
<*> (C.indented *> parseBinder)
parseNullBinder :: P.Parsec String ParseState Binder
parseNullBinder = C.lexeme (P.char '_') *> P.notFollowedBy C.identLetter *> return NullBinder
parseIdentifierAndBinder :: P.Parsec String ParseState (String, Binder)
parseIdentifierAndBinder = do
name <- C.lexeme (C.identifier <|> C.stringLiteral)
_ <- C.lexeme $ C.indented *> P.char '='
binder <- C.indented *> parseBinder
return (name, binder)
parseBinder :: P.Parsec String ParseState Binder
parseBinder = PositionedBinder <$> sourcePos <*>
P.buildExpressionParser operators parseBinderAtom P.<?> "expression"
where
operators = [ [ P.Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) P.AssocRight ] ]
parseBinderAtom :: P.Parsec String ParseState Binder
parseBinderAtom = P.choice (map P.try
[ parseNullBinder
, parseStringBinder
, parseBooleanBinder
, parseNumberBinder
, parseNamedBinder
, parseVarBinder
, parseConstructorBinder
, parseObjectBinder
, parseArrayBinder
, C.parens parseBinder ]) P.<?> "binder"
parseBinderNoParens :: P.Parsec String ParseState Binder
parseBinderNoParens = P.choice (map P.try
[ parseNullBinder
, parseStringBinder
, parseBooleanBinder
, parseNumberBinder
, parseNamedBinder
, parseVarBinder
, parseNullaryConstructorBinder
, parseObjectBinder
, parseArrayBinder
, C.parens parseBinder ]) P.<?> "binder"
parseGuard :: P.Parsec String ParseState Guard
parseGuard = C.indented *> C.pipe *> C.indented *> parseValue