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)

-- |
-- A newtype for a qualified proper name whose ProperNameType has not yet been determined.
-- This is a workaround for Happy's limited support for polymorphism; it is used
-- inside the parser to allow us to write just one parser for qualified proper names
-- which can be used for all of the different ProperNameTypes
-- (via a call to getQualifiedProperName).
newtype QualifiedProperName =
  QualifiedProperName { 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)

-- |
-- A newtype for a proper name whose ProperNameType has not yet been determined.
-- This is a workaround for Happy's limited support for polymorphism; it is used
-- inside the parser to allow us to write just one parser for proper names
-- which can be used for all of the different ProperNameTypes
-- (via a call to getProperName).
newtype ProperName =
  ProperName { 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 -- eta expansion needed here due to simplified subsumption

-- |
-- A newtype for a qualified operator name whose OpNameType has not yet been determined.
-- This is a workaround for Happy's limited support for polymorphism; it is used
-- inside the parser to allow us to write just one parser for qualified operator names
-- which can be used for all of the different OpNameTypes
-- (via a call to getQualifiedOpName).
newtype QualifiedOpName =
  QualifiedOpName { 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)

-- |
-- A newtype for a operator name whose OpNameType has not yet been determined.
-- This is a workaround for Happy's limited support for polymorphism; it is used
-- inside the parser to allow us to write just one parser for operator names
-- which can be used for all of the different OpNameTypes
-- (via a call to getOpName).
newtype OpName =
  OpName { 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 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 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
'\'')

-- | This is to keep the @Parser.y@ file ASCII, otherwise @happy@ will break
-- in non-unicode locales.
--
-- Related GHC issue: https://gitlab.haskell.org/ghc/ghc/issues/8167
isLeftFatArrow :: Text -> Bool
isLeftFatArrow :: 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
"⇐"