module Language.PureScript.CST.Utils where
import Prelude
import Control.Monad (unless)
import Data.Coerce (coerce)
import Data.Foldable (for_)
import Data.Functor (($>))
import Data.List.NonEmpty qualified as NE
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as Text
import Language.PureScript.CST.Errors (ParserErrorType(..))
import Language.PureScript.CST.Monad (Parser, addFailure, parseFail, pushBack)
import Language.PureScript.CST.Positions (TokenRange, binderRange, importDeclRange, recordUpdateRange, typeRange)
import Language.PureScript.CST.Traversals.Type (everythingOnTypes)
import Language.PureScript.CST.Types
import Language.PureScript.Names qualified as N
import Language.PureScript.PSString (PSString, mkString)
newtype QualifiedProperName =
QualifiedProperName { QualifiedProperName
-> forall (a :: ProperNameType). QualifiedName (ProperName a)
getQualifiedProperName :: forall a. QualifiedName (N.ProperName a) }
qualifiedProperName :: QualifiedName (N.ProperName a) -> QualifiedProperName
qualifiedProperName :: forall (a :: ProperNameType).
QualifiedName (ProperName a) -> QualifiedProperName
qualifiedProperName QualifiedName (ProperName a)
n = (forall (a :: ProperNameType). QualifiedName (ProperName a))
-> QualifiedProperName
QualifiedProperName (forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
N.coerceProperName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualifiedName (ProperName a)
n)
newtype ProperName =
ProperName { ProperName -> forall (a :: ProperNameType). Name (ProperName a)
_getProperName :: forall a. Name (N.ProperName a) }
properName :: Name (N.ProperName a) -> ProperName
properName :: forall (a :: ProperNameType). Name (ProperName a) -> ProperName
properName Name (ProperName a)
n = (forall (a :: ProperNameType). Name (ProperName a)) -> ProperName
ProperName (forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
N.coerceProperName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name (ProperName a)
n)
getProperName :: forall a. ProperName -> Name (N.ProperName a)
getProperName :: forall (a :: ProperNameType). ProperName -> Name (ProperName a)
getProperName ProperName
pn = ProperName -> forall (a :: ProperNameType). Name (ProperName a)
_getProperName ProperName
pn
newtype QualifiedOpName =
QualifiedOpName { QualifiedOpName
-> forall (a :: OpNameType). QualifiedName (OpName a)
getQualifiedOpName :: forall a. QualifiedName (N.OpName a) }
qualifiedOpName :: QualifiedName (N.OpName a) -> QualifiedOpName
qualifiedOpName :: forall (a :: OpNameType).
QualifiedName (OpName a) -> QualifiedOpName
qualifiedOpName QualifiedName (OpName a)
n = (forall (a :: OpNameType). QualifiedName (OpName a))
-> QualifiedOpName
QualifiedOpName (forall (a :: OpNameType) (b :: OpNameType). OpName a -> OpName b
N.coerceOpName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualifiedName (OpName a)
n)
newtype OpName =
OpName { OpName -> forall (a :: OpNameType). Name (OpName a)
getOpName :: forall a. Name (N.OpName a) }
opName :: Name (N.OpName a) -> OpName
opName :: forall (a :: OpNameType). Name (OpName a) -> OpName
opName Name (OpName a)
n = (forall (a :: OpNameType). Name (OpName a)) -> OpName
OpName (forall (a :: OpNameType) (b :: OpNameType). OpName a -> OpName b
N.coerceOpName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name (OpName a)
n)
placeholder :: SourceToken
placeholder :: SourceToken
placeholder = SourceToken
{ tokAnn :: TokenAnn
tokAnn = SourceRange -> [Comment LineFeed] -> [Comment Void] -> TokenAnn
TokenAnn (SourcePos -> SourcePos -> SourceRange
SourceRange (Int -> Int -> SourcePos
SourcePos Int
0 Int
0) (Int -> Int -> SourcePos
SourcePos Int
0 Int
0)) [] []
, tokValue :: Token
tokValue = [Text] -> Text -> Token
TokLowerName [] Text
"<placeholder>"
}
unexpectedName :: SourceToken -> Name Ident
unexpectedName :: SourceToken -> Name Ident
unexpectedName SourceToken
tok = forall a. SourceToken -> a -> Name a
Name SourceToken
tok (Text -> Ident
Ident Text
"<unexpected>")
unexpectedQual :: SourceToken -> QualifiedName Ident
unexpectedQual :: SourceToken -> QualifiedName Ident
unexpectedQual SourceToken
tok = forall a. SourceToken -> Maybe ModuleName -> a -> QualifiedName a
QualifiedName SourceToken
tok forall a. Maybe a
Nothing (Text -> Ident
Ident Text
"<unexpected>")
unexpectedLabel :: SourceToken -> Label
unexpectedLabel :: SourceToken -> Label
unexpectedLabel SourceToken
tok = SourceToken -> PSString -> Label
Label SourceToken
tok PSString
"<unexpected>"
unexpectedExpr :: Monoid a => [SourceToken] -> Expr a
unexpectedExpr :: forall a. Monoid a => [SourceToken] -> Expr a
unexpectedExpr [SourceToken]
toks = forall a. a -> QualifiedName Ident -> Expr a
ExprIdent forall a. Monoid a => a
mempty (SourceToken -> QualifiedName Ident
unexpectedQual (forall a. [a] -> a
head [SourceToken]
toks))
unexpectedBinder :: Monoid a => [SourceToken] -> Binder a
unexpectedBinder :: forall a. Monoid a => [SourceToken] -> Binder a
unexpectedBinder [SourceToken]
toks = forall a. a -> Name Ident -> Binder a
BinderVar forall a. Monoid a => a
mempty (SourceToken -> Name Ident
unexpectedName (forall a. [a] -> a
head [SourceToken]
toks))
unexpectedRecordUpdate :: Monoid a => [SourceToken] -> RecordUpdate a
unexpectedRecordUpdate :: forall a. Monoid a => [SourceToken] -> RecordUpdate a
unexpectedRecordUpdate [SourceToken]
toks = forall a. Label -> SourceToken -> Expr a -> RecordUpdate a
RecordUpdateLeaf (SourceToken -> Label
unexpectedLabel (forall a. [a] -> a
head [SourceToken]
toks)) (forall a. [a] -> a
head [SourceToken]
toks) (forall a. Monoid a => [SourceToken] -> Expr a
unexpectedExpr [SourceToken]
toks)
unexpectedRecordLabeled :: [SourceToken] -> RecordLabeled a
unexpectedRecordLabeled :: forall a. [SourceToken] -> RecordLabeled a
unexpectedRecordLabeled [SourceToken]
toks = forall a. Name Ident -> RecordLabeled a
RecordPun (SourceToken -> Name Ident
unexpectedName (forall a. [a] -> a
head [SourceToken]
toks))
rangeToks :: TokenRange -> [SourceToken]
rangeToks :: TokenRange -> [SourceToken]
rangeToks (SourceToken
a, SourceToken
b) = [SourceToken
a, SourceToken
b]
unexpectedToks :: (a -> TokenRange) -> ([SourceToken] -> b) -> ParserErrorType -> (a -> Parser b)
unexpectedToks :: forall a b.
(a -> TokenRange)
-> ([SourceToken] -> b) -> ParserErrorType -> a -> Parser b
unexpectedToks a -> TokenRange
toRange [SourceToken] -> b
toCst ParserErrorType
err a
old = do
let toks :: [SourceToken]
toks = TokenRange -> [SourceToken]
rangeToks forall a b. (a -> b) -> a -> b
$ a -> TokenRange
toRange a
old
[SourceToken] -> ParserErrorType -> Parser ()
addFailure [SourceToken]
toks ParserErrorType
err
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [SourceToken] -> b
toCst [SourceToken]
toks
separated :: [(SourceToken, a)] -> Separated a
separated :: forall a. [(SourceToken, a)] -> Separated a
separated = forall {a}. [(SourceToken, a)] -> [(SourceToken, a)] -> Separated a
go []
where
go :: [(SourceToken, a)] -> [(SourceToken, a)] -> Separated a
go [(SourceToken, a)]
accum [(SourceToken
_, a
a)] = forall a. a -> [(SourceToken, a)] -> Separated a
Separated a
a [(SourceToken, a)]
accum
go [(SourceToken, a)]
accum ((SourceToken, a)
x : [(SourceToken, a)]
xs) = [(SourceToken, a)] -> [(SourceToken, a)] -> Separated a
go ((SourceToken, a)
x forall a. a -> [a] -> [a]
: [(SourceToken, a)]
accum) [(SourceToken, a)]
xs
go [(SourceToken, a)]
_ [] = forall a. String -> a
internalError String
"Separated should not be empty"
internalError :: String -> a
internalError :: forall a. String -> a
internalError = forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Internal parser error: " forall a. Semigroup a => a -> a -> a
<>)
toModuleName :: SourceToken -> [Text] -> Parser (Maybe N.ModuleName)
toModuleName :: SourceToken -> [Text] -> Parser (Maybe ModuleName)
toModuleName SourceToken
_ [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
toModuleName SourceToken
tok [Text]
ns = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Text -> Bool
isValidModuleNamespace [Text]
ns) forall a b. (a -> b) -> a -> b
$ [SourceToken] -> ParserErrorType -> Parser ()
addFailure [SourceToken
tok] ParserErrorType
ErrModuleName
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ModuleName
N.ModuleName forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
Text.intercalate Text
"." [Text]
ns
upperToModuleName :: SourceToken -> Parser (Name N.ModuleName)
upperToModuleName :: SourceToken -> Parser (Name ModuleName)
upperToModuleName SourceToken
tok = case SourceToken -> Token
tokValue SourceToken
tok of
TokUpperName [Text]
q Text
a -> do
let ns :: [Text]
ns = [Text]
q forall a. Semigroup a => a -> a -> a
<> [Text
a]
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Text -> Bool
isValidModuleNamespace [Text]
ns) forall a b. (a -> b) -> a -> b
$ [SourceToken] -> ParserErrorType -> Parser ()
addFailure [SourceToken
tok] ParserErrorType
ErrModuleName
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. SourceToken -> a -> Name a
Name SourceToken
tok forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ModuleName
N.ModuleName forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
Text.intercalate Text
"." [Text]
ns
Token
_ -> forall a. String -> a
internalError forall a b. (a -> b) -> a -> b
$ String
"Invalid upper name: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show SourceToken
tok
toQualifiedName :: (Text -> a) -> SourceToken -> Parser (QualifiedName a)
toQualifiedName :: forall a. (Text -> a) -> SourceToken -> Parser (QualifiedName a)
toQualifiedName Text -> a
k SourceToken
tok = case SourceToken -> Token
tokValue SourceToken
tok of
TokLowerName [Text]
q Text
a
| Bool -> Bool
not (forall a. Ord a => a -> Set a -> Bool
Set.member Text
a Set Text
reservedNames) -> forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a. SourceToken -> Maybe ModuleName -> a -> QualifiedName a
QualifiedName SourceToken
tok) (Text -> a
k Text
a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceToken -> [Text] -> Parser (Maybe ModuleName)
toModuleName SourceToken
tok [Text]
q
| Bool
otherwise -> [SourceToken] -> ParserErrorType -> Parser ()
addFailure [SourceToken
tok] ParserErrorType
ErrKeywordVar forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall a. SourceToken -> Maybe ModuleName -> a -> QualifiedName a
QualifiedName SourceToken
tok forall a. Maybe a
Nothing (Text -> a
k Text
"<unexpected>")
TokUpperName [Text]
q Text
a -> forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a. SourceToken -> Maybe ModuleName -> a -> QualifiedName a
QualifiedName SourceToken
tok) (Text -> a
k Text
a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceToken -> [Text] -> Parser (Maybe ModuleName)
toModuleName SourceToken
tok [Text]
q
TokSymbolName [Text]
q Text
a -> forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a. SourceToken -> Maybe ModuleName -> a -> QualifiedName a
QualifiedName SourceToken
tok) (Text -> a
k Text
a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceToken -> [Text] -> Parser (Maybe ModuleName)
toModuleName SourceToken
tok [Text]
q
TokOperator [Text]
q Text
a -> forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a. SourceToken -> Maybe ModuleName -> a -> QualifiedName a
QualifiedName SourceToken
tok) (Text -> a
k Text
a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceToken -> [Text] -> Parser (Maybe ModuleName)
toModuleName SourceToken
tok [Text]
q
Token
_ -> forall a. String -> a
internalError forall a b. (a -> b) -> a -> b
$ String
"Invalid qualified name: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show SourceToken
tok
toName :: (Text -> a) -> SourceToken -> Parser (Name a)
toName :: forall a. (Text -> a) -> SourceToken -> Parser (Name a)
toName Text -> a
k SourceToken
tok = case SourceToken -> Token
tokValue SourceToken
tok of
TokLowerName [] Text
a
| Bool -> Bool
not (forall a. Ord a => a -> Set a -> Bool
Set.member Text
a Set Text
reservedNames) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. SourceToken -> a -> Name a
Name SourceToken
tok (Text -> a
k Text
a)
| Bool
otherwise -> [SourceToken] -> ParserErrorType -> Parser ()
addFailure [SourceToken
tok] ParserErrorType
ErrKeywordVar forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall a. SourceToken -> a -> Name a
Name SourceToken
tok (Text -> a
k Text
"<unexpected>")
TokString Text
_ PSString
_ -> forall a. SourceToken -> ParserErrorType -> Parser a
parseFail SourceToken
tok ParserErrorType
ErrQuotedPun
TokRawString Text
_ -> forall a. SourceToken -> ParserErrorType -> Parser a
parseFail SourceToken
tok ParserErrorType
ErrQuotedPun
TokUpperName [] Text
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. SourceToken -> a -> Name a
Name SourceToken
tok (Text -> a
k Text
a)
TokSymbolName [] Text
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. SourceToken -> a -> Name a
Name SourceToken
tok (Text -> a
k Text
a)
TokOperator [] Text
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. SourceToken -> a -> Name a
Name SourceToken
tok (Text -> a
k Text
a)
TokHole Text
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. SourceToken -> a -> Name a
Name SourceToken
tok (Text -> a
k Text
a)
Token
_ -> forall a. String -> a
internalError forall a b. (a -> b) -> a -> b
$ String
"Invalid name: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show SourceToken
tok
toLabel :: SourceToken -> Label
toLabel :: SourceToken -> Label
toLabel SourceToken
tok = case SourceToken -> Token
tokValue SourceToken
tok of
TokLowerName [] Text
a -> SourceToken -> PSString -> Label
Label SourceToken
tok forall a b. (a -> b) -> a -> b
$ Text -> PSString
mkString Text
a
TokString Text
_ PSString
a -> SourceToken -> PSString -> Label
Label SourceToken
tok PSString
a
TokRawString Text
a -> SourceToken -> PSString -> Label
Label SourceToken
tok forall a b. (a -> b) -> a -> b
$ Text -> PSString
mkString Text
a
TokForall SourceStyle
ASCII -> SourceToken -> PSString -> Label
Label SourceToken
tok forall a b. (a -> b) -> a -> b
$ Text -> PSString
mkString Text
"forall"
Token
_ -> forall a. String -> a
internalError forall a b. (a -> b) -> a -> b
$ String
"Invalid label: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show SourceToken
tok
toString :: SourceToken -> (SourceToken, PSString)
toString :: SourceToken -> (SourceToken, PSString)
toString SourceToken
tok = case SourceToken -> Token
tokValue SourceToken
tok of
TokString Text
_ PSString
a -> (SourceToken
tok, PSString
a)
TokRawString Text
a -> (SourceToken
tok, Text -> PSString
mkString Text
a)
Token
_ -> forall a. String -> a
internalError forall a b. (a -> b) -> a -> b
$ String
"Invalid string literal: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show SourceToken
tok
toChar :: SourceToken -> (SourceToken, Char)
toChar :: SourceToken -> (SourceToken, Char)
toChar SourceToken
tok = case SourceToken -> Token
tokValue SourceToken
tok of
TokChar Text
_ Char
a -> (SourceToken
tok, Char
a)
Token
_ -> forall a. String -> a
internalError forall a b. (a -> b) -> a -> b
$ String
"Invalid char literal: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show SourceToken
tok
toNumber :: SourceToken -> (SourceToken, Either Integer Double)
toNumber :: SourceToken -> (SourceToken, Either Integer Double)
toNumber SourceToken
tok = case SourceToken -> Token
tokValue SourceToken
tok of
TokInt Text
_ Integer
a -> (SourceToken
tok, forall a b. a -> Either a b
Left Integer
a)
TokNumber Text
_ Double
a -> (SourceToken
tok, forall a b. b -> Either a b
Right Double
a)
Token
_ -> forall a. String -> a
internalError forall a b. (a -> b) -> a -> b
$ String
"Invalid number literal: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show SourceToken
tok
toInt :: SourceToken -> (SourceToken, Integer)
toInt :: SourceToken -> (SourceToken, Integer)
toInt SourceToken
tok = case SourceToken -> Token
tokValue SourceToken
tok of
TokInt Text
_ Integer
a -> (SourceToken
tok, Integer
a)
Token
_ -> forall a. String -> a
internalError forall a b. (a -> b) -> a -> b
$ String
"Invalid integer literal: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show SourceToken
tok
toBoolean :: SourceToken -> (SourceToken, Bool)
toBoolean :: SourceToken -> (SourceToken, Bool)
toBoolean SourceToken
tok = case SourceToken -> Token
tokValue SourceToken
tok of
TokLowerName [] Text
"true" -> (SourceToken
tok, Bool
True)
TokLowerName [] Text
"false" -> (SourceToken
tok, Bool
False)
Token
_ -> forall a. String -> a
internalError forall a b. (a -> b) -> a -> b
$ String
"Invalid boolean literal: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show SourceToken
tok
toConstraint :: forall a. Monoid a => Type a -> Parser (Constraint a)
toConstraint :: forall a. Monoid a => Type a -> Parser (Constraint a)
toConstraint = Type a -> Parser (Constraint a)
convertParens
where
convertParens :: Type a -> Parser (Constraint a)
convertParens :: Type a -> Parser (Constraint a)
convertParens = \case
TypeParens a
a (Wrapped SourceToken
b Type a
c SourceToken
d) -> do
Constraint a
c' <- Type a -> Parser (Constraint a)
convertParens Type a
c
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Wrapped (Constraint a) -> Constraint a
ConstraintParens a
a (forall a. SourceToken -> a -> SourceToken -> Wrapped a
Wrapped SourceToken
b Constraint a
c' SourceToken
d)
Type a
ty -> a -> [Type a] -> Type a -> Parser (Constraint a)
convert forall a. Monoid a => a
mempty [] Type a
ty
convert :: a -> [Type a] -> Type a -> Parser (Constraint a)
convert :: a -> [Type a] -> Type a -> Parser (Constraint a)
convert a
ann [Type a]
acc = \case
TypeApp a
a Type a
lhs Type a
rhs -> a -> [Type a] -> Type a -> Parser (Constraint a)
convert (a
a forall a. Semigroup a => a -> a -> a
<> a
ann) (Type a
rhs forall a. a -> [a] -> [a]
: [Type a]
acc) Type a
lhs
TypeConstructor a
a QualifiedName (ProperName 'TypeName)
name -> do
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Type a]
acc forall a. Type a -> Parser ()
checkNoForalls
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
a
-> QualifiedName (ProperName 'ClassName)
-> [Type a]
-> Constraint a
Constraint (a
a forall a. Semigroup a => a -> a -> a
<> a
ann) (coerce :: forall a b. Coercible a b => a -> b
coerce QualifiedName (ProperName 'TypeName)
name) [Type a]
acc
Type a
ty -> do
let (SourceToken
tok1, SourceToken
tok2) = forall a. Type a -> TokenRange
typeRange Type a
ty
[SourceToken] -> ParserErrorType -> Parser ()
addFailure [SourceToken
tok1, SourceToken
tok2] ParserErrorType
ErrTypeInConstraint
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
a
-> QualifiedName (ProperName 'ClassName)
-> [Type a]
-> Constraint a
Constraint forall a. Monoid a => a
mempty (forall a. SourceToken -> Maybe ModuleName -> a -> QualifiedName a
QualifiedName SourceToken
tok1 forall a. Maybe a
Nothing (forall (a :: ProperNameType). Text -> ProperName a
N.ProperName Text
"<unexpected")) []
isConstrained :: Type a -> Bool
isConstrained :: forall a. Type a -> Bool
isConstrained = forall r a. (r -> r -> r) -> (Type a -> r) -> Type a -> r
everythingOnTypes Bool -> Bool -> Bool
(||) forall a b. (a -> b) -> a -> b
$ \case
TypeConstrained{} -> Bool
True
Type a
_ -> Bool
False
toBinderConstructor :: Monoid a => NE.NonEmpty (Binder a) -> Parser (Binder a)
toBinderConstructor :: forall a. Monoid a => NonEmpty (Binder a) -> Parser (Binder a)
toBinderConstructor = \case
BinderConstructor a
a QualifiedName (ProperName 'ConstructorName)
name [] NE.:| [Binder a]
bs ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
a
-> QualifiedName (ProperName 'ConstructorName)
-> [Binder a]
-> Binder a
BinderConstructor a
a QualifiedName (ProperName 'ConstructorName)
name [Binder a]
bs
Binder a
a NE.:| [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Binder a
a
Binder a
a NE.:| [Binder a]
_ -> forall a b.
(a -> TokenRange)
-> ([SourceToken] -> b) -> ParserErrorType -> a -> Parser b
unexpectedToks forall a. Binder a -> TokenRange
binderRange forall a. Monoid a => [SourceToken] -> Binder a
unexpectedBinder ParserErrorType
ErrExprInBinder Binder a
a
toRecordFields
:: Monoid a
=> Separated (Either (RecordLabeled (Expr a)) (RecordUpdate a))
-> Parser (Either (Separated (RecordLabeled (Expr a))) (Separated (RecordUpdate a)))
toRecordFields :: forall a.
Monoid a =>
Separated (Either (RecordLabeled (Expr a)) (RecordUpdate a))
-> Parser
(Either
(Separated (RecordLabeled (Expr a))) (Separated (RecordUpdate a)))
toRecordFields = \case
Separated (Left RecordLabeled (Expr a)
a) [(SourceToken, Either (RecordLabeled (Expr a)) (RecordUpdate a))]
as ->
forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [(SourceToken, a)] -> Separated a
Separated RecordLabeled (Expr a)
a forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {a} {a}.
Either (RecordLabeled a) (RecordUpdate a)
-> ParserM ParserError ParserState (RecordLabeled a)
unLeft) [(SourceToken, Either (RecordLabeled (Expr a)) (RecordUpdate a))]
as
Separated (Right RecordUpdate a
a) [(SourceToken, Either (RecordLabeled (Expr a)) (RecordUpdate a))]
as ->
forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [(SourceToken, a)] -> Separated a
Separated RecordUpdate a
a forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {a} {a}.
Monoid a =>
Either (RecordLabeled a) (RecordUpdate a)
-> ParserM ParserError ParserState (RecordUpdate a)
unRight) [(SourceToken, Either (RecordLabeled (Expr a)) (RecordUpdate a))]
as
where
unLeft :: Either (RecordLabeled a) (RecordUpdate a)
-> ParserM ParserError ParserState (RecordLabeled a)
unLeft (Left RecordLabeled a
tok) = forall (f :: * -> *) a. Applicative f => a -> f a
pure RecordLabeled a
tok
unLeft (Right RecordUpdate a
tok) =
forall a b.
(a -> TokenRange)
-> ([SourceToken] -> b) -> ParserErrorType -> a -> Parser b
unexpectedToks forall a. RecordUpdate a -> TokenRange
recordUpdateRange forall a. [SourceToken] -> RecordLabeled a
unexpectedRecordLabeled ParserErrorType
ErrRecordUpdateInCtr RecordUpdate a
tok
unRight :: Either (RecordLabeled a) (RecordUpdate a)
-> ParserM ParserError ParserState (RecordUpdate a)
unRight (Right RecordUpdate a
tok) = forall (f :: * -> *) a. Applicative f => a -> f a
pure RecordUpdate a
tok
unRight (Left (RecordPun (Name SourceToken
tok Ident
_))) = do
[SourceToken] -> ParserErrorType -> Parser ()
addFailure [SourceToken
tok] ParserErrorType
ErrRecordPunInUpdate
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [SourceToken] -> RecordUpdate a
unexpectedRecordUpdate [SourceToken
tok]
unRight (Left (RecordField Label
_ SourceToken
tok a
_)) = do
[SourceToken] -> ParserErrorType -> Parser ()
addFailure [SourceToken
tok] ParserErrorType
ErrRecordCtrInUpdate
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [SourceToken] -> RecordUpdate a
unexpectedRecordUpdate [SourceToken
tok]
checkFundeps :: ClassHead a -> Parser ()
checkFundeps :: forall a. ClassHead a -> Parser ()
checkFundeps (ClassHead SourceToken
_ Maybe (OneOrDelimited (Constraint a), SourceToken)
_ Name (ProperName 'ClassName)
_ [TypeVarBinding a]
_ Maybe (SourceToken, Separated ClassFundep)
Nothing) = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
checkFundeps (ClassHead SourceToken
_ Maybe (OneOrDelimited (Constraint a), SourceToken)
_ Name (ProperName 'ClassName)
_ [TypeVarBinding a]
vars (Just (SourceToken
_, Separated ClassFundep
fundeps))) = do
let
k :: TypeVarBinding a -> Text
k (TypeVarKinded (Wrapped SourceToken
_ (Labeled (Maybe SourceToken
_, Name Ident
a) SourceToken
_ Type a
_) SourceToken
_)) = Ident -> Text
getIdent forall a b. (a -> b) -> a -> b
$ forall a. Name a -> a
nameValue Name Ident
a
k (TypeVarName (Maybe SourceToken
_, Name Ident
a)) = Ident -> Text
getIdent forall a b. (a -> b) -> a -> b
$ forall a. Name a -> a
nameValue Name Ident
a
names :: [Text]
names = forall {a}. TypeVarBinding a -> Text
k forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TypeVarBinding a]
vars
check :: Name Ident -> Parser ()
check Name Ident
a
| Ident -> Text
getIdent (forall a. Name a -> a
nameValue Name Ident
a) forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
names = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
| Bool
otherwise = [SourceToken] -> ParserErrorType -> Parser ()
addFailure [forall a. Name a -> SourceToken
nameTok Name Ident
a] ParserErrorType
ErrUnknownFundep
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Separated ClassFundep
fundeps forall a b. (a -> b) -> a -> b
$ \case
FundepDetermined SourceToken
_ NonEmpty (Name Ident)
bs -> forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ NonEmpty (Name Ident)
bs Name Ident -> Parser ()
check
FundepDetermines NonEmpty (Name Ident)
as SourceToken
_ NonEmpty (Name Ident)
bs -> do
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ NonEmpty (Name Ident)
as Name Ident -> Parser ()
check
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ NonEmpty (Name Ident)
bs Name Ident -> Parser ()
check
data TmpModuleDecl a
= TmpImport (ImportDecl a)
| TmpChain (Separated (Declaration a))
deriving (Int -> TmpModuleDecl a -> String -> String
forall a. Show a => Int -> TmpModuleDecl a -> String -> String
forall a. Show a => [TmpModuleDecl a] -> String -> String
forall a. Show a => TmpModuleDecl a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [TmpModuleDecl a] -> String -> String
$cshowList :: forall a. Show a => [TmpModuleDecl a] -> String -> String
show :: TmpModuleDecl a -> String
$cshow :: forall a. Show a => TmpModuleDecl a -> String
showsPrec :: Int -> TmpModuleDecl a -> String -> String
$cshowsPrec :: forall a. Show a => Int -> TmpModuleDecl a -> String -> String
Show)
toModuleDecls :: Monoid a => [TmpModuleDecl a] -> Parser ([ImportDecl a], [Declaration a])
toModuleDecls :: forall a.
Monoid a =>
[TmpModuleDecl a] -> Parser ([ImportDecl a], [Declaration a])
toModuleDecls = forall {a}.
Semigroup a =>
[ImportDecl a]
-> [TmpModuleDecl a]
-> ParserM
ParserError ParserState ([ImportDecl a], [Declaration a])
goImport []
where
goImport :: [ImportDecl a]
-> [TmpModuleDecl a]
-> ParserM
ParserError ParserState ([ImportDecl a], [Declaration a])
goImport [ImportDecl a]
acc (TmpImport ImportDecl a
x : [TmpModuleDecl a]
xs) = [ImportDecl a]
-> [TmpModuleDecl a]
-> ParserM
ParserError ParserState ([ImportDecl a], [Declaration a])
goImport (ImportDecl a
x forall a. a -> [a] -> [a]
: [ImportDecl a]
acc) [TmpModuleDecl a]
xs
goImport [ImportDecl a]
acc [TmpModuleDecl a]
xs = (forall a. [a] -> [a]
reverse [ImportDecl a]
acc,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a}.
Semigroup a =>
[Declaration a]
-> [TmpModuleDecl a]
-> ParserM ParserError ParserState [Declaration a]
goDecl [] [TmpModuleDecl a]
xs
goDecl :: [Declaration a]
-> [TmpModuleDecl a]
-> ParserM ParserError ParserState [Declaration a]
goDecl [Declaration a]
acc [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [Declaration a]
acc
goDecl [Declaration a]
acc (TmpChain (Separated Declaration a
x []) : [TmpModuleDecl a]
xs) = [Declaration a]
-> [TmpModuleDecl a]
-> ParserM ParserError ParserState [Declaration a]
goDecl (Declaration a
x forall a. a -> [a] -> [a]
: [Declaration a]
acc) [TmpModuleDecl a]
xs
goDecl [Declaration a]
acc (TmpChain (Separated (DeclInstanceChain a
a (Separated Instance a
h [(SourceToken, Instance a)]
t)) [(SourceToken, Declaration a)]
t') : [TmpModuleDecl a]
xs) = do
(a
a', [(SourceToken, Instance a)]
instances) <- forall {a}.
Semigroup a =>
QualifiedName (ProperName 'ClassName)
-> a
-> [(SourceToken, Instance a)]
-> [(SourceToken, Declaration a)]
-> ParserM ParserError ParserState (a, [(SourceToken, Instance a)])
goChain (forall {a}. Instance a -> QualifiedName (ProperName 'ClassName)
getName Instance a
h) a
a [] [(SourceToken, Declaration a)]
t'
[Declaration a]
-> [TmpModuleDecl a]
-> ParserM ParserError ParserState [Declaration a]
goDecl (forall a. a -> Separated (Instance a) -> Declaration a
DeclInstanceChain a
a' (forall a. a -> [(SourceToken, a)] -> Separated a
Separated Instance a
h ([(SourceToken, Instance a)]
t forall a. Semigroup a => a -> a -> a
<> [(SourceToken, Instance a)]
instances)) forall a. a -> [a] -> [a]
: [Declaration a]
acc) [TmpModuleDecl a]
xs
goDecl [Declaration a]
acc (TmpChain (Separated Declaration a
_ [(SourceToken, Declaration a)]
t) : [TmpModuleDecl a]
xs) = do
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(SourceToken, Declaration a)]
t forall a b. (a -> b) -> a -> b
$ \(SourceToken
tok, Declaration a
_) -> [SourceToken] -> ParserErrorType -> Parser ()
addFailure [SourceToken
tok] ParserErrorType
ErrElseInDecl
[Declaration a]
-> [TmpModuleDecl a]
-> ParserM ParserError ParserState [Declaration a]
goDecl [Declaration a]
acc [TmpModuleDecl a]
xs
goDecl [Declaration a]
acc (TmpImport ImportDecl a
imp : [TmpModuleDecl a]
xs) = do
forall a b.
(a -> TokenRange)
-> ([SourceToken] -> b) -> ParserErrorType -> a -> Parser b
unexpectedToks forall a. ImportDecl a -> TokenRange
importDeclRange (forall a b. a -> b -> a
const ()) ParserErrorType
ErrImportInDecl ImportDecl a
imp
[Declaration a]
-> [TmpModuleDecl a]
-> ParserM ParserError ParserState [Declaration a]
goDecl [Declaration a]
acc [TmpModuleDecl a]
xs
goChain :: QualifiedName (ProperName 'ClassName)
-> a
-> [(SourceToken, Instance a)]
-> [(SourceToken, Declaration a)]
-> ParserM ParserError ParserState (a, [(SourceToken, Instance a)])
goChain QualifiedName (ProperName 'ClassName)
_ a
ann [(SourceToken, Instance a)]
acc [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
ann, forall a. [a] -> [a]
reverse [(SourceToken, Instance a)]
acc)
goChain QualifiedName (ProperName 'ClassName)
name a
ann [(SourceToken, Instance a)]
acc ((SourceToken
tok, DeclInstanceChain a
a (Separated Instance a
h [(SourceToken, Instance a)]
t)) : [(SourceToken, Declaration a)]
xs)
| forall {a}. Eq a => QualifiedName a -> QualifiedName a -> Bool
eqName (forall {a}. Instance a -> QualifiedName (ProperName 'ClassName)
getName Instance a
h) QualifiedName (ProperName 'ClassName)
name = QualifiedName (ProperName 'ClassName)
-> a
-> [(SourceToken, Instance a)]
-> [(SourceToken, Declaration a)]
-> ParserM ParserError ParserState (a, [(SourceToken, Instance a)])
goChain QualifiedName (ProperName 'ClassName)
name (a
ann forall a. Semigroup a => a -> a -> a
<> a
a) (forall a. [a] -> [a]
reverse ((SourceToken
tok, Instance a
h) forall a. a -> [a] -> [a]
: [(SourceToken, Instance a)]
t) forall a. Semigroup a => a -> a -> a
<> [(SourceToken, Instance a)]
acc) [(SourceToken, Declaration a)]
xs
| Bool
otherwise = do
[SourceToken] -> ParserErrorType -> Parser ()
addFailure [forall a. QualifiedName a -> SourceToken
qualTok forall a b. (a -> b) -> a -> b
$ forall {a}. Instance a -> QualifiedName (ProperName 'ClassName)
getName Instance a
h] ParserErrorType
ErrInstanceNameMismatch
QualifiedName (ProperName 'ClassName)
-> a
-> [(SourceToken, Instance a)]
-> [(SourceToken, Declaration a)]
-> ParserM ParserError ParserState (a, [(SourceToken, Instance a)])
goChain QualifiedName (ProperName 'ClassName)
name a
ann [(SourceToken, Instance a)]
acc [(SourceToken, Declaration a)]
xs
goChain QualifiedName (ProperName 'ClassName)
name a
ann [(SourceToken, Instance a)]
acc ((SourceToken
tok, Declaration a
_) : [(SourceToken, Declaration a)]
xs) = do
[SourceToken] -> ParserErrorType -> Parser ()
addFailure [SourceToken
tok] ParserErrorType
ErrElseInDecl
QualifiedName (ProperName 'ClassName)
-> a
-> [(SourceToken, Instance a)]
-> [(SourceToken, Declaration a)]
-> ParserM ParserError ParserState (a, [(SourceToken, Instance a)])
goChain QualifiedName (ProperName 'ClassName)
name a
ann [(SourceToken, Instance a)]
acc [(SourceToken, Declaration a)]
xs
getName :: Instance a -> QualifiedName (ProperName 'ClassName)
getName = forall a. InstanceHead a -> QualifiedName (ProperName 'ClassName)
instClass forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Instance a -> InstanceHead a
instHead
eqName :: QualifiedName a -> QualifiedName a -> Bool
eqName (QualifiedName SourceToken
_ Maybe ModuleName
a a
b) (QualifiedName SourceToken
_ Maybe ModuleName
c a
d) = Maybe ModuleName
a forall a. Eq a => a -> a -> Bool
== Maybe ModuleName
c Bool -> Bool -> Bool
&& a
b forall a. Eq a => a -> a -> Bool
== a
d
checkNoWildcards :: Type a -> Parser ()
checkNoWildcards :: forall a. Type a -> Parser ()
checkNoWildcards Type a
ty = do
let
k :: Type a -> [Parser ()]
k = \case
TypeWildcard a
_ SourceToken
a -> [[SourceToken] -> ParserErrorType -> Parser ()
addFailure [SourceToken
a] ParserErrorType
ErrWildcardInType]
TypeHole a
_ Name Ident
a -> [[SourceToken] -> ParserErrorType -> Parser ()
addFailure [forall a. Name a -> SourceToken
nameTok Name Ident
a] ParserErrorType
ErrHoleInType]
Type a
_ -> []
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$ forall r a. (r -> r -> r) -> (Type a -> r) -> Type a -> r
everythingOnTypes forall a. Semigroup a => a -> a -> a
(<>) forall {a}. Type a -> [Parser ()]
k Type a
ty
checkNoForalls :: Type a -> Parser ()
checkNoForalls :: forall a. Type a -> Parser ()
checkNoForalls Type a
ty = do
let
k :: Type a -> [Parser ()]
k = \case
TypeForall a
_ SourceToken
a NonEmpty (TypeVarBinding a)
_ SourceToken
_ Type a
_ -> [[SourceToken] -> ParserErrorType -> Parser ()
addFailure [SourceToken
a] ParserErrorType
ErrToken]
Type a
_ -> []
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$ forall r a. (r -> r -> r) -> (Type a -> r) -> Type a -> r
everythingOnTypes forall a. Semigroup a => a -> a -> a
(<>) forall {a}. Type a -> [Parser ()]
k Type a
ty
revert :: Parser a -> SourceToken -> Parser a
revert :: forall a. Parser a -> SourceToken -> Parser a
revert Parser a
p SourceToken
lk = SourceToken -> Parser ()
pushBack SourceToken
lk forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a
p
reservedNames :: Set Text
reservedNames :: Set Text
reservedNames = forall a. Ord a => [a] -> Set a
Set.fromList
[ Text
"ado"
, Text
"case"
, Text
"class"
, Text
"data"
, Text
"derive"
, Text
"do"
, Text
"else"
, Text
"false"
, Text
"forall"
, Text
"foreign"
, Text
"import"
, Text
"if"
, Text
"in"
, Text
"infix"
, Text
"infixl"
, Text
"infixr"
, Text
"instance"
, Text
"let"
, Text
"module"
, Text
"newtype"
, Text
"of"
, Text
"true"
, Text
"type"
, Text
"where"
]
isValidModuleNamespace :: Text -> Bool
isValidModuleNamespace :: Text -> Bool
isValidModuleNamespace = Text -> Bool
Text.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> (Text, Text)
Text.span (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
/= Char
'_' Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
'\'')
isLeftFatArrow :: Text -> Bool
isLeftFatArrow :: Text -> Bool
isLeftFatArrow Text
str = Text
str forall a. Eq a => a -> a -> Bool
== Text
"<=" Bool -> Bool -> Bool
|| Text
str forall a. Eq a => a -> a -> Bool
== Text
"⇐"