{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
module Language.Haskell.Exts.ParseUtils (
splitTyConApp
, checkEnabled
, checkEnabledOneOf
, checkToplevel
, checkPatternGuards
, mkRecConstrOrUpdate
, checkPrec
, checkPContext
, checkContext
, checkAssertion
, checkDataHeader
, checkClassHeader
, checkInstHeader
, checkDeriving
, checkPattern
, checkExpr
, checkType
, checkTyVar
, bangType
, checkKind
, checkValDef
, checkExplicitPatSyn
, checkClassBody
, checkInstBody
, checkUnQual
, checkQualOrUnQual
, checkSingleDecl
, checkRevDecls
, checkRevClsDecls
, checkRevInstDecls
, checkDataOrNew
, checkDataOrNewG
, checkSimpleType
, checkSigVar
, checkDefSigDef
, getGConName
, mkTyForall
, mkRoleAnnotDecl
, mkAssocType
, mkEThingWith
, splitTilde
, checkRPattern
, checkEqNames
, checkPageModule
, checkHybridModule
, mkDVar
, checkRuleExpr
, readTool
, updateQNameLoc
, SumOrTuple(..), mkSumOrTuple
, PExp(..), PFieldUpdate(..), ParseXAttr(..), PType(..), PContext, PAsst(..)
, p_unit_con
, p_tuple_con
, p_unboxed_singleton_con
, pexprToQName
) where
import Language.Haskell.Exts.Syntax hiding ( Type(..), Asst(..), Exp(..), FieldUpdate(..), XAttr(..), Context(..) )
import qualified Language.Haskell.Exts.Syntax as S ( Type(..), Asst(..), Exp(..), FieldUpdate(..), XAttr(..), Context(..), Role(..), PatternSynDirection(..))
import Language.Haskell.Exts.ParseSyntax
import Language.Haskell.Exts.ParseMonad
import Language.Haskell.Exts.Pretty
import Language.Haskell.Exts.SrcLoc hiding (loc)
import Language.Haskell.Exts.Extension
import Language.Haskell.Exts.ExtScheme
import Prelude hiding (mod)
import Data.List (intercalate, intersperse)
import Data.Maybe (fromJust, fromMaybe)
import Data.Either
import Control.Monad (when,unless)
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif
type L = SrcSpanInfo
type S = SrcSpan
pexprToQName :: PExp l -> P (QName l)
pexprToQName :: forall l. PExp l -> P (QName l)
pexprToQName (Con l
_ QName l
qn) = QName l -> P (QName l)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return QName l
qn
pexprToQName (List l
l []) = QName l -> P (QName l)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName l -> P (QName l)) -> QName l -> P (QName l)
forall a b. (a -> b) -> a -> b
$ l -> SpecialCon l -> QName l
forall l. l -> SpecialCon l -> QName l
Special l
l (l -> SpecialCon l
forall l. l -> SpecialCon l
ListCon l
l)
pexprToQName PExp l
_ = String -> P (QName l)
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"pexprToQName"
splitTyConApp :: PType L -> P (Name L, [S.Type L])
splitTyConApp :: PType L -> P (Name L, [Type L])
splitTyConApp PType L
t0 = do
(n, pts) <- PType L -> [PType L] -> P (Name L, [PType L])
split PType L
t0 []
ts <- mapM checkType pts
return (n,ts)
where
split :: PType L -> [PType L] -> P (Name L, [PType L])
split :: PType L -> [PType L] -> P (Name L, [PType L])
split (TyApp L
_ PType L
t PType L
u) [PType L]
ts = PType L -> [PType L] -> P (Name L, [PType L])
split PType L
t (PType L
uPType L -> [PType L] -> [PType L]
forall a. a -> [a] -> [a]
:[PType L]
ts)
split (TyCon L
_ (UnQual L
_ Name L
t)) [PType L]
ts = (Name L, [PType L]) -> P (Name L, [PType L])
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name L
t,[PType L]
ts)
split (TyInfix L
l PType L
a MaybePromotedName L
op PType L
b) [PType L]
ts = PType L -> [PType L] -> P (Name L, [PType L])
split (L -> QName L -> PType L
forall l. l -> QName l -> PType l
TyCon L
l (MaybePromotedName L -> QName L
forall l. MaybePromotedName l -> QName l
getMaybePromotedQName MaybePromotedName L
op)) (PType L
aPType L -> [PType L] -> [PType L]
forall a. a -> [a] -> [a]
:PType L
bPType L -> [PType L] -> [PType L]
forall a. a -> [a] -> [a]
:[PType L]
ts)
split PType L
_ [PType L]
_ = String -> P (Name L, [PType L])
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Illegal data/newtype declaration"
checkEnabled :: (Show e, Enabled e) => e -> P ()
checkEnabled :: forall e. (Show e, Enabled e) => e -> P ()
checkEnabled e
e = do
exts <- P [KnownExtension]
getExtensions
unless (isEnabled e exts) $ fail errorMsg
where errorMsg :: String
errorMsg = [String] -> String
unwords
[ e -> String
forall a. Show a => a -> String
show e
e
, String
"language extension is not enabled."
, String
"Please add {-# LANGUAGE " String -> String -> String
forall a. [a] -> [a] -> [a]
++ e -> String
forall a. Show a => a -> String
show e
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" #-}"
, String
"pragma at the top of your module."
]
checkEnabledOneOf :: (Show e, Enabled e) => [e] -> P ()
checkEnabledOneOf :: forall e. (Show e, Enabled e) => [e] -> P ()
checkEnabledOneOf [e]
es = do
exts <- P [KnownExtension]
getExtensions
unless (any (`isEnabled` exts) es) $
fail errorMsg
where errorMsg :: String
errorMsg = [String] -> String
unwords
[ String
"At least one of"
, (String -> String) -> String
joinOr String -> String
forall a. a -> a
id
, String
"language extensions needs to be enabled."
, String
"Please add:"
, (String -> String) -> String
joinOr (\String
s -> String
"{-# LANGUAGE " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" #-}")
, String
"language pragma at the top of your module."
]
joinOr :: (String -> String) -> String
joinOr String -> String
f = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> ([e] -> [String]) -> [e] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
" or " ([String] -> [String]) -> ([e] -> [String]) -> [e] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> String) -> [e] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
f (String -> String) -> (e -> String) -> e -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> String
forall a. Show a => a -> String
show) ([e] -> String) -> [e] -> String
forall a b. (a -> b) -> a -> b
$ [e]
es
checkPatternGuards :: [Stmt L] -> P ()
checkPatternGuards :: [Stmt L] -> P ()
checkPatternGuards [Qualifier L
_ Exp L
_] = () -> P ()
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkPatternGuards [Stmt L]
_ = KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
PatternGuards
checkToplevel :: PExp t -> P ()
checkToplevel :: forall t. PExp t -> P ()
checkToplevel PExp t
e = do
exts <- P [KnownExtension]
getExtensions
let isQQ = case PExp t
e of
QuasiQuote {} -> KnownExtension -> [KnownExtension] -> Bool
forall a. Enabled a => a -> [KnownExtension] -> Bool
isEnabled KnownExtension
QuasiQuotes [KnownExtension]
exts
PExp t
_ -> Bool
False
unless isQQ (checkEnabled TemplateHaskell)
checkPContext :: PType L -> P (PContext L)
checkPContext :: PType L -> P (PContext L)
checkPContext (TyTuple L
l Boxed
Boxed [PType L]
ts) =
(PType L -> P (PAsst L)) -> [PType L] -> P [PAsst L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PType L -> P (PAsst L)
checkAssertion [PType L]
ts P [PAsst L] -> ([PAsst L] -> P (PContext L)) -> P (PContext L)
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PContext L -> P (PContext L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (PContext L -> P (PContext L))
-> ([PAsst L] -> PContext L) -> [PAsst L] -> P (PContext L)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> [PAsst L] -> PContext L
forall l. l -> [PAsst l] -> PContext l
CxTuple L
l
checkPContext (TyCon L
l (Special L
_ (UnitCon L
_))) =
PContext L -> P (PContext L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (PContext L -> P (PContext L)) -> PContext L -> P (PContext L)
forall a b. (a -> b) -> a -> b
$ L -> PContext L
forall l. l -> PContext l
CxEmpty L
l
checkPContext (TyParen L
l PType L
t) = do
c <- PType L -> P (PAsst L)
checkAssertion PType L
t
return $ CxSingle l (ParenA l c)
checkPContext t :: PType L
t@(TyEquals L
tp PType L
_ PType L
_) = do
[KnownExtension] -> P ()
forall e. (Show e, Enabled e) => [e] -> P ()
checkEnabledOneOf [KnownExtension
TypeFamilies, KnownExtension
GADTs]
PContext L -> P (PContext L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (PContext L -> P (PContext L)) -> PContext L -> P (PContext L)
forall a b. (a -> b) -> a -> b
$ L -> PAsst L -> PContext L
forall l. l -> PAsst l -> PContext l
CxSingle L
tp (PAsst L -> PContext L) -> PAsst L -> PContext L
forall a b. (a -> b) -> a -> b
$ L -> PType L -> PAsst L
forall l. l -> PType l -> PAsst l
TypeA L
tp PType L
t
checkPContext PType L
t = do
c <- PType L -> P (PAsst L)
checkAssertion PType L
t
return $ CxSingle (ann c) c
checkAssertion :: PType L -> P (PAsst L)
checkAssertion :: PType L -> P (PAsst L)
checkAssertion (TyParen L
l PType L
asst) = do
asst' <- PType L -> P (PAsst L)
checkAssertion PType L
asst
return $ ParenA l asst'
checkAssertion (TyPred L
_ PAsst L
p) = PAsst L -> P (PAsst L)
checkAAssertion PAsst L
p
checkAssertion PType L
t' = do
t'' <- (L -> L) -> [PType L] -> PType L -> P (PType L)
checkAssertion' L -> L
forall a. a -> a
id [] PType L
t'
return $ TypeA (ann t'') t''
where
checkAssertion' :: (L -> L) -> [PType L] -> PType L -> P (PType L)
checkAssertion' L -> L
_ [PType L]
_ t :: PType L
t@(TyEquals L
_ PType L
_ PType L
_) = PType L -> P (PType L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return PType L
t
checkAssertion' L -> L
fl [PType L]
ts (TyCon L
l QName L
c) = do
Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([PType L] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PType L]
ts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1) (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$ KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
FlexibleContexts
QName L -> P ()
checkAndWarnTypeOperators QName L
c
PType L -> P (PType L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (PType L -> P (PType L)) -> PType L -> P (PType L)
forall a b. (a -> b) -> a -> b
$ L -> PType L -> [PType L] -> PType L
tyApps (L -> L
fl L
l) (L -> QName L -> PType L
forall l. l -> QName l -> PType l
TyCon (L -> L
fl L
l) QName L
c) [PType L]
ts
checkAssertion' L -> L
fl [PType L]
ts (TyApp L
l PType L
a PType L
t) =
(L -> L) -> [PType L] -> PType L -> P (PType L)
checkAssertion' (L -> L -> L
forall a b. a -> b -> a
const (L -> L
fl L
l)) (PType L
tPType L -> [PType L] -> [PType L]
forall a. a -> [a] -> [a]
:[PType L]
ts) PType L
a
checkAssertion' L -> L
fl [PType L]
_ (TyInfix L
l PType L
a MaybePromotedName L
op PType L
b) = do
QName L -> P ()
checkAndWarnTypeOperators (MaybePromotedName L -> QName L
forall l. MaybePromotedName l -> QName l
getMaybePromotedQName MaybePromotedName L
op)
PType L -> P (PType L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (PType L -> P (PType L)) -> PType L -> P (PType L)
forall a b. (a -> b) -> a -> b
$ L -> PType L -> MaybePromotedName L -> PType L -> PType L
forall l. l -> PType l -> MaybePromotedName l -> PType l -> PType l
TyInfix (L -> L
fl L
l) PType L
a MaybePromotedName L
op PType L
b
checkAssertion' L -> L
fl [PType L]
ts (TyParen L
l PType L
t) =
(L -> L) -> [PType L] -> PType L -> P (PType L)
checkAssertion' (L -> L -> L
forall a b. a -> b -> a
const (L -> L
fl L
l)) [PType L]
ts PType L
t
checkAssertion' L -> L
fl [PType L]
ts (TyVar L
l Name L
t) = do
KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
ConstraintKinds
PType L -> P (PType L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (PType L -> P (PType L)) -> PType L -> P (PType L)
forall a b. (a -> b) -> a -> b
$ L -> PType L -> [PType L] -> PType L
tyApps (L -> L
fl L
l) (L -> Name L -> PType L
forall l. l -> Name l -> PType l
TyVar (L -> L
fl L
l) Name L
t) [PType L]
ts
checkAssertion' L -> L
_ [PType L]
_ t :: PType L
t@(TyWildCard L
_ Maybe (Name L)
_) = PType L -> P (PType L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return PType L
t
checkAssertion' L -> L
_ [PType L]
_ PType L
t = do
KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
QuantifiedConstraints
PType L -> P (PType L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return PType L
t
tyApps :: L -> PType L -> [PType L] -> PType L
tyApps :: L -> PType L -> [PType L] -> PType L
tyApps L
_ PType L
c [] = PType L
c
tyApps L
l PType L
c (PType L
a:[PType L]
aa) = L -> PType L -> [PType L] -> PType L
tyApps L
l (L -> PType L -> PType L -> PType L
forall l. l -> PType l -> PType l -> PType l
TyApp L
l PType L
c PType L
a) [PType L]
aa
checkAAssertion :: PAsst L -> P (PAsst L)
checkAAssertion :: PAsst L -> P (PAsst L)
checkAAssertion (TypeA L
_ PType L
t) = PType L -> P (PAsst L)
checkAssertion PType L
t
checkAAssertion (ParenA L
l PAsst L
a) = do
a' <- PAsst L -> P (PAsst L)
checkAAssertion PAsst L
a
return $ ParenA l a'
checkAAssertion PAsst L
p = PAsst L -> P (PAsst L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return PAsst L
p
checkMultiParam :: PType L -> P ()
checkMultiParam :: PType L -> P ()
checkMultiParam = [PType L] -> PType L -> P ()
forall {l}. [PType l] -> PType l -> P ()
checkMultiParam' []
where
checkMultiParam' :: [PType l] -> PType l -> P ()
checkMultiParam' [PType l]
ts (TyCon l
_ QName l
_) =
Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([PType l] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PType l]
ts Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1) (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$ KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
MultiParamTypeClasses
checkMultiParam' [PType l]
ts (TyApp l
_ PType l
a PType l
t) = [PType l] -> PType l -> P ()
checkMultiParam' (PType l
tPType l -> [PType l] -> [PType l]
forall a. a -> [a] -> [a]
:[PType l]
ts) PType l
a
checkMultiParam' [PType l]
_ (TyInfix l
_ PType l
_ MaybePromotedName l
_ PType l
_) = KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
MultiParamTypeClasses
checkMultiParam' [PType l]
ts (TyParen l
_ PType l
t) = [PType l] -> PType l -> P ()
checkMultiParam' [PType l]
ts PType l
t
checkMultiParam' [PType l]
_ PType l
_ = () -> P ()
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
getSymbol :: QName L -> Maybe String
getSymbol :: QName L -> Maybe String
getSymbol (UnQual L
_ (Symbol L
_ String
s)) = String -> Maybe String
forall a. a -> Maybe a
Just String
s
getSymbol (Qual L
_ ModuleName L
_ (Symbol L
_ String
s)) = String -> Maybe String
forall a. a -> Maybe a
Just String
s
getSymbol QName L
_ = Maybe String
forall a. Maybe a
Nothing
checkAndWarnTypeOperators :: QName L -> P ()
checkAndWarnTypeOperators :: QName L -> P ()
checkAndWarnTypeOperators QName L
c =
case QName L -> Maybe String
getSymbol QName L
c of
Just String
s | String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"." -> [KnownExtension] -> P ()
forall e. (Show e, Enabled e) => [e] -> P ()
checkEnabledOneOf [KnownExtension
ExplicitForAll, KnownExtension
TypeOperators]
| Bool
otherwise -> KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
TypeOperators
Maybe String
Nothing -> () -> P ()
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkSContext :: Maybe (PContext L) -> P (Maybe (S.Context L))
checkSContext :: Maybe (PContext L) -> P (Maybe (Context L))
checkSContext (Just PContext L
ctxt) = case PContext L
ctxt of
CxEmpty L
l -> Maybe (Context L) -> P (Maybe (Context L))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Context L) -> P (Maybe (Context L)))
-> Maybe (Context L) -> P (Maybe (Context L))
forall a b. (a -> b) -> a -> b
$ Context L -> Maybe (Context L)
forall a. a -> Maybe a
Just (Context L -> Maybe (Context L)) -> Context L -> Maybe (Context L)
forall a b. (a -> b) -> a -> b
$ L -> Context L
forall l. l -> Context l
S.CxEmpty L
l
CxSingle L
l PAsst L
a -> PAsst L -> P (Asst L)
checkAsst PAsst L
a P (Asst L)
-> (Asst L -> P (Maybe (Context L))) -> P (Maybe (Context L))
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (Context L) -> P (Maybe (Context L))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Context L) -> P (Maybe (Context L)))
-> (Asst L -> Maybe (Context L)) -> Asst L -> P (Maybe (Context L))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context L -> Maybe (Context L)
forall a. a -> Maybe a
Just (Context L -> Maybe (Context L))
-> (Asst L -> Context L) -> Asst L -> Maybe (Context L)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> Asst L -> Context L
forall l. l -> Asst l -> Context l
S.CxSingle L
l
CxTuple L
l [PAsst L]
as -> (PAsst L -> P (Asst L)) -> [PAsst L] -> P [Asst L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PAsst L -> P (Asst L)
checkAsst [PAsst L]
as P [Asst L]
-> ([Asst L] -> P (Maybe (Context L))) -> P (Maybe (Context L))
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (Context L) -> P (Maybe (Context L))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Context L) -> P (Maybe (Context L)))
-> ([Asst L] -> Maybe (Context L))
-> [Asst L]
-> P (Maybe (Context L))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context L -> Maybe (Context L)
forall a. a -> Maybe a
Just (Context L -> Maybe (Context L))
-> ([Asst L] -> Context L) -> [Asst L] -> Maybe (Context L)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> [Asst L] -> Context L
forall l. l -> [Asst l] -> Context l
S.CxTuple L
l
checkSContext Maybe (PContext L)
_ = Maybe (Context L) -> P (Maybe (Context L))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Context L)
forall a. Maybe a
Nothing
checkContext :: Maybe (PContext L) -> P (Maybe (S.Context L))
checkContext :: Maybe (PContext L) -> P (Maybe (Context L))
checkContext (Just PContext L
ctxt) = case PContext L
ctxt of
CxEmpty L
l -> Maybe (Context L) -> P (Maybe (Context L))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Context L) -> P (Maybe (Context L)))
-> Maybe (Context L) -> P (Maybe (Context L))
forall a b. (a -> b) -> a -> b
$ Context L -> Maybe (Context L)
forall a. a -> Maybe a
Just (Context L -> Maybe (Context L)) -> Context L -> Maybe (Context L)
forall a b. (a -> b) -> a -> b
$ L -> Context L
forall l. l -> Context l
S.CxEmpty L
l
CxSingle L
l PAsst L
a -> PAsst L -> P (Asst L)
checkAsst PAsst L
a P (Asst L)
-> (Asst L -> P (Maybe (Context L))) -> P (Maybe (Context L))
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (Context L) -> P (Maybe (Context L))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Context L) -> P (Maybe (Context L)))
-> (Asst L -> Maybe (Context L)) -> Asst L -> P (Maybe (Context L))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context L -> Maybe (Context L)
forall a. a -> Maybe a
Just (Context L -> Maybe (Context L))
-> (Asst L -> Context L) -> Asst L -> Maybe (Context L)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> Asst L -> Context L
forall l. l -> Asst l -> Context l
S.CxSingle L
l
CxTuple L
l [PAsst L]
as -> (PAsst L -> P (Asst L)) -> [PAsst L] -> P [Asst L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PAsst L -> P (Asst L)
checkAsst [PAsst L]
as P [Asst L]
-> ([Asst L] -> P (Maybe (Context L))) -> P (Maybe (Context L))
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (Context L) -> P (Maybe (Context L))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Context L) -> P (Maybe (Context L)))
-> ([Asst L] -> Maybe (Context L))
-> [Asst L]
-> P (Maybe (Context L))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context L -> Maybe (Context L)
forall a. a -> Maybe a
Just (Context L -> Maybe (Context L))
-> ([Asst L] -> Context L) -> [Asst L] -> Maybe (Context L)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> [Asst L] -> Context L
forall l. l -> [Asst l] -> Context l
S.CxTuple L
l
checkContext Maybe (PContext L)
_ = Maybe (Context L) -> P (Maybe (Context L))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Context L)
forall a. Maybe a
Nothing
checkAsst :: PAsst L -> P (S.Asst L)
checkAsst :: PAsst L -> P (Asst L)
checkAsst PAsst L
asst =
case PAsst L
asst of
TypeA L
l PType L
pt -> do
t <- PType L -> P (Type L)
checkType PType L
pt
return $ S.TypeA l t
IParam L
l IPName L
ipn PType L
pt -> do
t <- PType L -> P (Type L)
checkType PType L
pt
return $ S.IParam l ipn t
ParenA L
l PAsst L
a -> do
a' <- PAsst L -> P (Asst L)
checkAsst PAsst L
a
return $ S.ParenA l a'
checkDataHeader :: PType L -> P (Maybe (S.Context L), DeclHead L)
(TyForall L
_ Maybe [TyVarBind L]
Nothing Maybe (PContext L)
cs PType L
t) = do
dh <- String -> PType L -> P (DeclHead L)
checkSimple String
"data/newtype" PType L
t
cs' <- checkContext cs
return (cs',dh)
checkDataHeader PType L
t = do
dh <- String -> PType L -> P (DeclHead L)
checkSimple String
"data/newtype" PType L
t
return (Nothing,dh)
checkClassHeader :: PType L -> P (Maybe (S.Context L), DeclHead L)
(TyForall L
_ Maybe [TyVarBind L]
Nothing Maybe (PContext L)
cs PType L
t) = do
PType L -> P ()
checkMultiParam PType L
t
dh <- String -> PType L -> P (DeclHead L)
checkSimple String
"class" PType L
t
cs' <- checkSContext cs
return (cs',dh)
checkClassHeader PType L
t = do
PType L -> P ()
checkMultiParam PType L
t
dh <- String -> PType L -> P (DeclHead L)
checkSimple String
"class" PType L
t
return (Nothing,dh)
checkSimple :: String -> PType L -> P (DeclHead L)
checkSimple :: String -> PType L -> P (DeclHead L)
checkSimple String
kw (TyApp L
l PType L
h PType L
t) = do
tvb <- String -> PType L -> P (TyVarBind L)
mkTyVarBind String
kw PType L
t
h' <- checkSimple kw h
return $ DHApp l h' tvb
checkSimple String
kw (TyInfix L
l PType L
t1 MaybePromotedName L
mq PType L
t2)
| c :: QName L
c@(UnQual L
_ Name L
t) <- MaybePromotedName L -> QName L
forall l. MaybePromotedName l -> QName l
getMaybePromotedQName MaybePromotedName L
mq
= do
QName L -> P ()
checkAndWarnTypeOperators QName L
c
tv1 <- String -> PType L -> P (TyVarBind L)
mkTyVarBind String
kw PType L
t1
tv2 <- mkTyVarBind kw t2
return $ DHApp l (DHInfix l tv1 t) tv2
checkSimple String
_kw (TyCon L
_ c :: QName L
c@(UnQual L
l Name L
t)) = do
QName L -> P ()
checkAndWarnTypeOperators QName L
c
DeclHead L -> P (DeclHead L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Name L -> DeclHead L
forall l. l -> Name l -> DeclHead l
DHead L
l Name L
t)
checkSimple String
kw (TyParen L
l PType L
t) = do
dh <- String -> PType L -> P (DeclHead L)
checkSimple String
kw PType L
t
return (DHParen l dh)
checkSimple String
kw PType L
_ = String -> P (DeclHead L)
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Illegal " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
kw String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" declaration")
mkTyVarBind :: String -> PType L -> P (TyVarBind L)
mkTyVarBind :: String -> PType L -> P (TyVarBind L)
mkTyVarBind String
_ (TyVar L
l Name L
n) = TyVarBind L -> P (TyVarBind L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyVarBind L -> P (TyVarBind L)) -> TyVarBind L -> P (TyVarBind L)
forall a b. (a -> b) -> a -> b
$ L -> Name L -> TyVarBind L
forall l. l -> Name l -> TyVarBind l
UnkindedVar L
l Name L
n
mkTyVarBind String
_ (TyKind L
l (TyVar L
_ Name L
n) Type L
k) = TyVarBind L -> P (TyVarBind L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyVarBind L -> P (TyVarBind L)) -> TyVarBind L -> P (TyVarBind L)
forall a b. (a -> b) -> a -> b
$ L -> Name L -> Type L -> TyVarBind L
forall l. l -> Name l -> Kind l -> TyVarBind l
KindedVar L
l Name L
n Type L
k
mkTyVarBind String
_ (TyCon L
l c :: QName L
c@(UnQual L
_ n :: Name L
n@(Symbol L
_ String
_))) = QName L -> P ()
checkAndWarnTypeOperators QName L
c P () -> P (TyVarBind L) -> P (TyVarBind L)
forall a b. P a -> P b -> P b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TyVarBind L -> P (TyVarBind L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Name L -> TyVarBind L
forall l. l -> Name l -> TyVarBind l
UnkindedVar L
l Name L
n)
mkTyVarBind String
_ (TyKind L
l (TyCon L
_ c :: QName L
c@(UnQual L
_ n :: Name L
n@(Symbol L
_ String
_))) Type L
k) = QName L -> P ()
checkAndWarnTypeOperators QName L
c P () -> P (TyVarBind L) -> P (TyVarBind L)
forall a b. P a -> P b -> P b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TyVarBind L -> P (TyVarBind L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Name L -> Type L -> TyVarBind L
forall l. l -> Name l -> Kind l -> TyVarBind l
KindedVar L
l Name L
n Type L
k)
mkTyVarBind String
kw PType L
_ = String -> P (TyVarBind L)
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Illegal " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
kw String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" declaration")
checkInstHeader :: PType L -> P (InstRule L)
(TyParen L
l PType L
t) = PType L -> P (InstRule L)
checkInstHeader PType L
t P (InstRule L) -> (InstRule L -> P (InstRule L)) -> P (InstRule L)
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InstRule L -> P (InstRule L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstRule L -> P (InstRule L))
-> (InstRule L -> InstRule L) -> InstRule L -> P (InstRule L)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> InstRule L -> InstRule L
forall l. l -> InstRule l -> InstRule l
IParen L
l
checkInstHeader (TyForall L
l Maybe [TyVarBind L]
mtvs Maybe (PContext L)
cs PType L
t) = do
cs' <- Maybe (PContext L) -> P (Maybe (Context L))
checkSContext Maybe (PContext L)
cs
checkMultiParam t
checkInsts (Just l) mtvs cs' t
checkInstHeader PType L
t = PType L -> P ()
checkMultiParam PType L
t P () -> P (InstRule L) -> P (InstRule L)
forall a b. P a -> P b -> P b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe L
-> Maybe [TyVarBind L]
-> Maybe (Context L)
-> PType L
-> P (InstRule L)
checkInsts Maybe L
forall a. Maybe a
Nothing Maybe [TyVarBind L]
forall a. Maybe a
Nothing Maybe (Context L)
forall a. Maybe a
Nothing PType L
t
checkInsts :: Maybe L -> Maybe [TyVarBind L] -> Maybe (S.Context L) -> PType L -> P (InstRule L)
checkInsts :: Maybe L
-> Maybe [TyVarBind L]
-> Maybe (Context L)
-> PType L
-> P (InstRule L)
checkInsts Maybe L
_ Maybe [TyVarBind L]
mtvs Maybe (Context L)
mctxt (TyParen L
l PType L
t) = Maybe L
-> Maybe [TyVarBind L]
-> Maybe (Context L)
-> PType L
-> P (InstRule L)
checkInsts Maybe L
forall a. Maybe a
Nothing Maybe [TyVarBind L]
mtvs Maybe (Context L)
mctxt PType L
t P (InstRule L) -> (InstRule L -> P (InstRule L)) -> P (InstRule L)
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InstRule L -> P (InstRule L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstRule L -> P (InstRule L))
-> (InstRule L -> InstRule L) -> InstRule L -> P (InstRule L)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> InstRule L -> InstRule L
forall l. l -> InstRule l -> InstRule l
IParen L
l
checkInsts Maybe L
l1 Maybe [TyVarBind L]
mtvs Maybe (Context L)
mctxt PType L
t = do
t' <- PType L -> P (InstHead L)
checkInstsGuts PType L
t
return $ IRule (fromMaybe (fmap ann mctxt <?+> ann t') l1) mtvs mctxt t'
checkInstsGuts :: PType L -> P (InstHead L)
checkInstsGuts :: PType L -> P (InstHead L)
checkInstsGuts (TyApp L
l PType L
h PType L
t) = do
t' <- PType L -> P (Type L)
checkType PType L
t
h' <- checkInstsGuts h
return $ IHApp l h' t'
checkInstsGuts (TyCon L
l QName L
c) = do
QName L -> P ()
checkAndWarnTypeOperators QName L
c
InstHead L -> P (InstHead L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstHead L -> P (InstHead L)) -> InstHead L -> P (InstHead L)
forall a b. (a -> b) -> a -> b
$ L -> QName L -> InstHead L
forall l. l -> QName l -> InstHead l
IHCon L
l QName L
c
checkInstsGuts (TyInfix L
l PType L
a MaybePromotedName L
op PType L
b) = do
QName L -> P ()
checkAndWarnTypeOperators (MaybePromotedName L -> QName L
forall l. MaybePromotedName l -> QName l
getMaybePromotedQName MaybePromotedName L
op)
[ta,tb] <- [PType L] -> P [Type L]
checkTypes [PType L
a,PType L
b]
return $ IHApp l (IHInfix l ta (getMaybePromotedQName op)) tb
checkInstsGuts (TyParen L
l PType L
t) = PType L -> P (InstHead L)
checkInstsGuts PType L
t P (InstHead L) -> (InstHead L -> P (InstHead L)) -> P (InstHead L)
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InstHead L -> P (InstHead L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstHead L -> P (InstHead L))
-> (InstHead L -> InstHead L) -> InstHead L -> P (InstHead L)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> InstHead L -> InstHead L
forall l. l -> InstHead l -> InstHead l
IHParen L
l
checkInstsGuts PType L
_ = String -> P (InstHead L)
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Illegal instance declaration"
checkDeriving :: [PType L] -> P [InstRule L]
checkDeriving :: [PType L] -> P [InstRule L]
checkDeriving = (PType L -> P (InstRule L)) -> [PType L] -> P [InstRule L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Maybe L
-> Maybe [TyVarBind L]
-> Maybe (Context L)
-> PType L
-> P (InstRule L)
checkInsts Maybe L
forall a. Maybe a
Nothing Maybe [TyVarBind L]
forall a. Maybe a
Nothing Maybe (Context L)
forall a. Maybe a
Nothing)
checkPattern :: PExp L -> P (Pat L)
checkPattern :: PExp L -> P (Pat L)
checkPattern PExp L
e = PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
checkPat :: PExp L -> [Pat L] -> P (Pat L)
checkPat :: PExp L -> [Pat L] -> P (Pat L)
checkPat (Con L
l QName L
c) [Pat L]
args = do
let l' :: L
l' = (L -> L -> L) -> L -> [L] -> L
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl L -> L -> L
combSpanInfo L
l ((Pat L -> L) -> [Pat L] -> [L]
forall a b. (a -> b) -> [a] -> [b]
map Pat L -> L
forall l. Pat l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann [Pat L]
args)
Pat L -> P (Pat L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> QName L -> [Pat L] -> Pat L
forall l. l -> QName l -> [Pat l] -> Pat l
PApp L
l' QName L
c [Pat L]
args)
checkPat (App L
_ PExp L
f PExp L
x) [Pat L]
args = do
x' <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
x []
checkPat f (x':args)
checkPat (InfixApp L
_ PExp L
l QOp L
op PExp L
r) [Pat L]
args
| QOp L
op QOp L -> QOp () -> Bool
forall (a :: * -> *) l1 l2.
(Annotated a, Eq (a ())) =>
a l1 -> a l2 -> Bool
=~= () -> QName () -> QOp ()
forall l. l -> QName l -> QOp l
QVarOp () (() -> Name () -> QName ()
forall l. l -> Name l -> QName l
UnQual () (() -> String -> Name ()
forall l. l -> String -> Name l
Symbol () String
"!")) = do
KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
BangPatterns
let (PExp L
e,[PExp L]
es) = PExp L -> [PExp L] -> (PExp L, [PExp L])
splitBang PExp L
r []
ps <- (PExp L -> P (Pat L)) -> [PExp L] -> P [Pat L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PExp L -> P (Pat L)
checkPattern (L -> PExp L -> PExp L
forall l. l -> PExp l -> PExp l
BangPat (QOp L -> L
forall l. QOp l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann QOp L
op) PExp L
ePExp L -> [PExp L] -> [PExp L]
forall a. a -> [a] -> [a]
:[PExp L]
es)
checkPat l (ps++args)
checkPat PExp L
e' [] = case PExp L
e' of
Var L
_ (UnQual L
l Name L
x) -> Pat L -> P (Pat L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Name L -> Pat L
forall l. l -> Name l -> Pat l
PVar L
l Name L
x)
Var L
_ (Special L
l (ExprHole L
_)) -> Pat L -> P (Pat L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Pat L
forall l. l -> Pat l
PWildCard L
l)
Lit L
l Literal L
lit -> Pat L -> P (Pat L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Sign L -> Literal L -> Pat L
forall l. l -> Sign l -> Literal l -> Pat l
PLit L
l (L -> Sign L
forall l. l -> Sign l
Signless L
l2) Literal L
lit)
where l2 :: L
l2 = SrcSpan -> L
noInfoSpan (SrcSpan -> L) -> (L -> SrcSpan) -> L -> L
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> SrcSpan
srcInfoSpan (L -> L) -> L -> L
forall a b. (a -> b) -> a -> b
$ L
l
InfixApp L
loc PExp L
l QOp L
op PExp L
r ->
case QOp L
op of
QConOp L
_ QName L
c -> do
l' <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
l []
r' <- checkPat r []
return (PInfixApp loc l' c r')
QVarOp L
ppos (UnQual L
_ (Symbol L
_ String
"+")) -> do
KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
NPlusKPatterns
case (PExp L
l,PExp L
r) of
(Var L
_ (UnQual L
_ n :: Name L
n@(Ident L
_ String
_)), Lit L
_ (Int L
kpos Integer
k String
_)) -> do
let pp :: SrcSpan
pp = L -> SrcSpan
srcInfoSpan L
ppos
kp :: SrcSpan
kp = L -> SrcSpan
srcInfoSpan L
kpos
Pat L -> P (Pat L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Name L -> Integer -> Pat L
forall l. l -> Name l -> Integer -> Pat l
PNPlusK (L
loc L -> [SrcSpan] -> L
<** [SrcSpan
pp,SrcSpan
kp]) Name L
n Integer
k)
(PExp L, PExp L)
_ -> String -> P (Pat L)
forall a. String -> P a
patFail String
""
QOp L
_ -> String -> P (Pat L)
forall a. String -> P a
patFail String
""
TupleSection L
l Boxed
bx [Maybe (PExp L)]
mes ->
if Maybe (PExp L)
forall a. Maybe a
Nothing Maybe (PExp L) -> [Maybe (PExp L)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Maybe (PExp L)]
mes
then do ps <- (PExp L -> P (Pat L)) -> [PExp L] -> P [Pat L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\PExp L
e -> PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []) ((Maybe (PExp L) -> PExp L) -> [Maybe (PExp L)] -> [PExp L]
forall a b. (a -> b) -> [a] -> [b]
map Maybe (PExp L) -> PExp L
forall a. HasCallStack => Maybe a -> a
fromJust [Maybe (PExp L)]
mes)
return (PTuple l bx ps)
else String -> P (Pat L)
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Illegal tuple section in pattern"
UnboxedSum L
l Int
b Int
a PExp L
e ->
L -> Int -> Int -> Pat L -> Pat L
forall l. l -> Int -> Int -> Pat l -> Pat l
PUnboxedSum L
l Int
b Int
a (Pat L -> Pat L) -> P (Pat L) -> P (Pat L)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PExp L -> P (Pat L)
checkPattern PExp L
e
List L
l [PExp L]
es -> do
ps <- (PExp L -> P (RPat L)) -> [PExp L] -> P [RPat L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PExp L -> P (RPat L)
checkRPattern [PExp L]
es
if all isStdPat ps
then return . PList l $ map stripRP ps
else checkEnabled RegularPatterns >> return (PRPat l $ map fixRPOpPrec ps)
where isStdPat :: RPat L -> Bool
isStdPat :: RPat L -> Bool
isStdPat (RPPat L
_ Pat L
_) = Bool
True
isStdPat (RPAs L
_ Name L
_ RPat L
p) = RPat L -> Bool
isStdPat RPat L
p
isStdPat (RPParen L
_ RPat L
p) = RPat L -> Bool
isStdPat RPat L
p
isStdPat RPat L
_ = Bool
False
stripRP :: RPat L -> Pat L
stripRP :: RPat L -> Pat L
stripRP (RPPat L
_ Pat L
p) = Pat L
p
stripRP (RPAs L
l' Name L
n RPat L
p) = L -> Name L -> Pat L -> Pat L
forall l. l -> Name l -> Pat l -> Pat l
PAsPat L
l' Name L
n (RPat L -> Pat L
stripRP RPat L
p)
stripRP (RPParen L
l' RPat L
p) = L -> Pat L -> Pat L
forall l. l -> Pat l -> Pat l
PParen L
l' (RPat L -> Pat L
stripRP RPat L
p)
stripRP RPat L
_ = String -> Pat L
forall a. HasCallStack => String -> a
error String
"cannot strip RP wrapper if not all patterns are base"
Paren L
l PExp L
e -> do
p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
return (PParen l p)
AsPat L
l Name L
n PExp L
e -> do
p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
return (PAsPat l n p)
WildCard L
l -> Pat L -> P (Pat L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Pat L
forall l. l -> Pat l
PWildCard L
l)
IrrPat L
l PExp L
e -> do
p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
return (PIrrPat l p)
ViewPat L
l PExp L
e Pat L
p -> do
e1 <- PExp L -> P (Exp L)
checkExpr PExp L
e
return (PViewPat l e1 p)
RecConstr L
l QName L
c [PFieldUpdate L]
fs -> do
fs' <- (PFieldUpdate L -> P (PatField L))
-> [PFieldUpdate L] -> P [PatField L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PFieldUpdate L -> P (PatField L)
checkPatField [PFieldUpdate L]
fs
return (PRec l c fs')
NegApp L
l (Lit L
_ Literal L
lit) ->
let siSign :: SrcSpan
siSign = [SrcSpan] -> SrcSpan
forall a. HasCallStack => [a] -> a
last ([SrcSpan] -> SrcSpan) -> (L -> [SrcSpan]) -> L -> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> [SrcSpan]
srcInfoPoints (L -> SrcSpan) -> L -> SrcSpan
forall a b. (a -> b) -> a -> b
$ L
l
lSign :: L
lSign = SrcSpan -> [SrcSpan] -> L
infoSpan SrcSpan
siSign [SrcSpan
siSign]
in do
Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> (Literal L -> Bool) -> Literal L -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Literal L -> Bool
forall a. Literal a -> Bool
isNegatableLiteral (Literal L -> Bool) -> Literal L -> Bool
forall a b. (a -> b) -> a -> b
$ Literal L
lit) (String -> P ()
forall a. String -> P a
patFail (String -> P ()) -> String -> P ()
forall a b. (a -> b) -> a -> b
$ PExp L -> String
forall a. Pretty a => a -> String
prettyPrint PExp L
e')
Pat L -> P (Pat L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Sign L -> Literal L -> Pat L
forall l. l -> Sign l -> Literal l -> Pat l
PLit L
l (L -> Sign L
forall l. l -> Sign l
Negative L
lSign) Literal L
lit)
ExpTypeSig L
l PExp L
e Type L
t -> do
KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
ScopedTypeVariables
p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
return (PatTypeSig l p t)
XTag L
l XName L
n [ParseXAttr L]
attrs Maybe (PExp L)
mattr [PExp L]
cs -> do
pattrs <- (ParseXAttr L -> P (PXAttr L)) -> [ParseXAttr L] -> P [PXAttr L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ParseXAttr L -> P (PXAttr L)
checkPAttr [ParseXAttr L]
attrs
pcs <- mapM (\PExp L
c -> PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
c []) cs
mpattr <- maybe (return Nothing)
(\PExp L
e -> do p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
return $ Just p)
mattr
let cps = [Pat L] -> [Pat L]
mkChildrenPat [Pat L]
pcs
return $ PXTag l n pattrs mpattr cps
XETag L
l XName L
n [ParseXAttr L]
attrs Maybe (PExp L)
mattr -> do
pattrs <- (ParseXAttr L -> P (PXAttr L)) -> [ParseXAttr L] -> P [PXAttr L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ParseXAttr L -> P (PXAttr L)
checkPAttr [ParseXAttr L]
attrs
mpattr <- maybe (return Nothing)
(\PExp L
e -> do p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
return $ Just p)
mattr
return $ PXETag l n pattrs mpattr
XPcdata L
l String
pcdata -> Pat L -> P (Pat L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat L -> P (Pat L)) -> Pat L -> P (Pat L)
forall a b. (a -> b) -> a -> b
$ L -> String -> Pat L
forall l. l -> String -> Pat l
PXPcdata L
l String
pcdata
XExpTag L
l PExp L
e -> do
p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
return $ PXPatTag l p
XRPats L
l [PExp L]
es -> do
rps <- (PExp L -> P (RPat L)) -> [PExp L] -> P [RPat L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PExp L -> P (RPat L)
checkRPattern [PExp L]
es
return (PXRPats l $ map fixRPOpPrec rps)
SpliceExp L
l Splice L
e -> Pat L -> P (Pat L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat L -> P (Pat L)) -> Pat L -> P (Pat L)
forall a b. (a -> b) -> a -> b
$ L -> Splice L -> Pat L
forall l. l -> Splice l -> Pat l
PSplice L
l Splice L
e
QuasiQuote L
l String
n String
q -> Pat L -> P (Pat L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat L -> P (Pat L)) -> Pat L -> P (Pat L)
forall a b. (a -> b) -> a -> b
$ L -> String -> String -> Pat L
forall l. l -> String -> String -> Pat l
PQuasiQuote L
l String
n String
q
BangPat L
l PExp L
e -> do
p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
return $ PBangPat l p
PreOp L
l (QVarOp L
_ (UnQual L
_ (Symbol L
_ String
"!"))) PExp L
e -> do
KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
BangPatterns
p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
return $ PBangPat l p
PExp L
e -> String -> P (Pat L)
forall a. String -> P a
patFail (String -> P (Pat L)) -> String -> P (Pat L)
forall a b. (a -> b) -> a -> b
$ PExp L -> String
forall a. Pretty a => a -> String
prettyPrint PExp L
e
checkPat PExp L
e [Pat L]
_ = String -> P (Pat L)
forall a. String -> P a
patFail (String -> P (Pat L)) -> String -> P (Pat L)
forall a b. (a -> b) -> a -> b
$ PExp L -> String
forall a. Pretty a => a -> String
prettyPrint PExp L
e
isNegatableLiteral :: Literal a -> Bool
isNegatableLiteral :: forall a. Literal a -> Bool
isNegatableLiteral (Int a
_ Integer
_ String
_) = Bool
True
isNegatableLiteral (Frac a
_ Rational
_ String
_) = Bool
True
isNegatableLiteral (PrimInt a
_ Integer
_ String
_) = Bool
True
isNegatableLiteral (PrimFloat a
_ Rational
_ String
_) = Bool
True
isNegatableLiteral (PrimDouble a
_ Rational
_ String
_) = Bool
True
isNegatableLiteral Literal a
_ = Bool
False
splitBang :: PExp L -> [PExp L] -> (PExp L, [PExp L])
splitBang :: PExp L -> [PExp L] -> (PExp L, [PExp L])
splitBang (App L
_ PExp L
f PExp L
x) [PExp L]
es = PExp L -> [PExp L] -> (PExp L, [PExp L])
splitBang PExp L
f (PExp L
xPExp L -> [PExp L] -> [PExp L]
forall a. a -> [a] -> [a]
:[PExp L]
es)
splitBang PExp L
e [PExp L]
es = (PExp L
e, [PExp L]
es)
checkPatField :: PFieldUpdate L -> P (PatField L)
checkPatField :: PFieldUpdate L -> P (PatField L)
checkPatField (FieldUpdate L
l QName L
n PExp L
e) = do
p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
return (PFieldPat l n p)
checkPatField (FieldPun L
l QName L
n) = PatField L -> P (PatField L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> QName L -> PatField L
forall l. l -> QName l -> PatField l
PFieldPun L
l QName L
n)
checkPatField (FieldWildcard L
l) = PatField L -> P (PatField L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> PatField L
forall l. l -> PatField l
PFieldWildcard L
l)
checkPAttr :: ParseXAttr L -> P (PXAttr L)
checkPAttr :: ParseXAttr L -> P (PXAttr L)
checkPAttr (XAttr L
l XName L
n PExp L
v) = do p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
v []
return $ PXAttr l n p
patFail :: String -> P a
patFail :: forall a. String -> P a
patFail String
s = String -> P a
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> P a) -> String -> P a
forall a b. (a -> b) -> a -> b
$ String
"Parse error in pattern: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
checkRPattern :: PExp L -> P (RPat L)
checkRPattern :: PExp L -> P (RPat L)
checkRPattern PExp L
e' = case PExp L
e' of
SeqRP L
l [PExp L]
es -> do
rps <- (PExp L -> P (RPat L)) -> [PExp L] -> P [RPat L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PExp L -> P (RPat L)
checkRPattern [PExp L]
es
return $ RPSeq l rps
PostOp L
l PExp L
e QOp L
op -> do
rpop <- QOp L -> P (RPatOp L)
checkRPatOp QOp L
op
rp <- checkRPattern e
return $ RPOp l rp rpop
GuardRP L
l PExp L
e [Stmt L]
gs -> do
rp <- PExp L -> P (Pat L)
checkPattern PExp L
e
return $ RPGuard l rp gs
EitherRP L
l PExp L
e1 PExp L
e2 -> do
rp1 <- PExp L -> P (RPat L)
checkRPattern PExp L
e1
rp2 <- checkRPattern e2
return $ RPEither l rp1 rp2
CAsRP L
l Name L
n PExp L
e -> do
rp <- PExp L -> P (RPat L)
checkRPattern PExp L
e
return $ RPCAs l n rp
AsPat L
l Name L
n PExp L
e -> do
rp <- PExp L -> P (RPat L)
checkRPattern PExp L
e
return $ RPAs l n rp
Paren L
l PExp L
e -> do
rp <- PExp L -> P (RPat L)
checkRPattern PExp L
e
return $ RPParen l rp
PExp L
_ -> do
p <- PExp L -> P (Pat L)
checkPattern PExp L
e'
return $ RPPat (ann p) p
checkRPatOp :: QOp L -> P (RPatOp L)
checkRPatOp :: QOp L -> P (RPatOp L)
checkRPatOp o :: QOp L
o@(QVarOp L
l (UnQual L
_ (Symbol L
_ String
sym))) =
case String
sym of
String
"*" -> RPatOp L -> P (RPatOp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (RPatOp L -> P (RPatOp L)) -> RPatOp L -> P (RPatOp L)
forall a b. (a -> b) -> a -> b
$ L -> RPatOp L
forall l. l -> RPatOp l
RPStar L
l
String
"*!" -> RPatOp L -> P (RPatOp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (RPatOp L -> P (RPatOp L)) -> RPatOp L -> P (RPatOp L)
forall a b. (a -> b) -> a -> b
$ L -> RPatOp L
forall l. l -> RPatOp l
RPStarG L
l
String
"+" -> RPatOp L -> P (RPatOp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (RPatOp L -> P (RPatOp L)) -> RPatOp L -> P (RPatOp L)
forall a b. (a -> b) -> a -> b
$ L -> RPatOp L
forall l. l -> RPatOp l
RPPlus L
l
String
"+!" -> RPatOp L -> P (RPatOp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (RPatOp L -> P (RPatOp L)) -> RPatOp L -> P (RPatOp L)
forall a b. (a -> b) -> a -> b
$ L -> RPatOp L
forall l. l -> RPatOp l
RPPlusG L
l
String
"?" -> RPatOp L -> P (RPatOp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (RPatOp L -> P (RPatOp L)) -> RPatOp L -> P (RPatOp L)
forall a b. (a -> b) -> a -> b
$ L -> RPatOp L
forall l. l -> RPatOp l
RPOpt L
l
String
"?!" -> RPatOp L -> P (RPatOp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (RPatOp L -> P (RPatOp L)) -> RPatOp L -> P (RPatOp L)
forall a b. (a -> b) -> a -> b
$ L -> RPatOp L
forall l. l -> RPatOp l
RPOptG L
l
String
_ -> QOp L -> P (RPatOp L)
forall a b. Pretty a => a -> P b
rpOpFail QOp L
o
checkRPatOp QOp L
o = QOp L -> P (RPatOp L)
forall a b. Pretty a => a -> P b
rpOpFail QOp L
o
rpOpFail :: Pretty a => a -> P b
rpOpFail :: forall a b. Pretty a => a -> P b
rpOpFail a
sym = String -> P b
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> P b) -> String -> P b
forall a b. (a -> b) -> a -> b
$ String
"Unrecognized regular pattern operator: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Pretty a => a -> String
prettyPrint a
sym
fixRPOpPrec :: RPat L -> RPat L
fixRPOpPrec :: RPat L -> RPat L
fixRPOpPrec RPat L
rp' = case RPat L
rp' of
RPOp L
l RPat L
rp RPatOp L
rpop -> RPat L -> (RPat L -> RPat L) -> RPat L
fPrecOp RPat L
rp ((RPat L -> RPatOp L -> RPat L) -> RPatOp L -> RPat L -> RPat L
forall a b c. (a -> b -> c) -> b -> a -> c
flip (L -> RPat L -> RPatOp L -> RPat L
forall l. l -> RPat l -> RPatOp l -> RPat l
RPOp L
l) RPatOp L
rpop)
RPEither L
l RPat L
rp1 RPat L
rp2 -> L -> RPat L -> RPat L -> RPat L
forall l. l -> RPat l -> RPat l -> RPat l
RPEither L
l (RPat L -> RPat L
fixRPOpPrec RPat L
rp1) (RPat L -> RPat L
fixRPOpPrec RPat L
rp2)
RPSeq L
l [RPat L]
rps -> L -> [RPat L] -> RPat L
forall l. l -> [RPat l] -> RPat l
RPSeq L
l ([RPat L] -> RPat L) -> [RPat L] -> RPat L
forall a b. (a -> b) -> a -> b
$ (RPat L -> RPat L) -> [RPat L] -> [RPat L]
forall a b. (a -> b) -> [a] -> [b]
map RPat L -> RPat L
fixRPOpPrec [RPat L]
rps
RPCAs L
l Name L
n RPat L
rp -> L -> Name L -> RPat L -> RPat L
forall l. l -> Name l -> RPat l -> RPat l
RPCAs L
l Name L
n (RPat L -> RPat L) -> RPat L -> RPat L
forall a b. (a -> b) -> a -> b
$ RPat L -> RPat L
fixRPOpPrec RPat L
rp
RPAs L
l Name L
n RPat L
rp -> L -> Name L -> RPat L -> RPat L
forall l. l -> Name l -> RPat l -> RPat l
RPAs L
l Name L
n (RPat L -> RPat L) -> RPat L -> RPat L
forall a b. (a -> b) -> a -> b
$ RPat L -> RPat L
fixRPOpPrec RPat L
rp
RPParen L
l RPat L
rp -> L -> RPat L -> RPat L
forall l. l -> RPat l -> RPat l
RPParen L
l (RPat L -> RPat L) -> RPat L -> RPat L
forall a b. (a -> b) -> a -> b
$ RPat L -> RPat L
fixRPOpPrec RPat L
rp
RPat L
_ -> RPat L
rp'
where fPrecOp :: RPat L -> (RPat L -> RPat L) -> RPat L
fPrecOp :: RPat L -> (RPat L -> RPat L) -> RPat L
fPrecOp (RPOp L
l RPat L
rp RPatOp L
rpop) RPat L -> RPat L
f = RPat L -> (RPat L -> RPat L) -> RPat L
fPrecOp RPat L
rp (RPat L -> RPat L
f (RPat L -> RPat L) -> (RPat L -> RPat L) -> RPat L -> RPat L
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RPat L -> RPatOp L -> RPat L) -> RPatOp L -> RPat L -> RPat L
forall a b c. (a -> b -> c) -> b -> a -> c
flip (L -> RPat L -> RPatOp L -> RPat L
forall l. l -> RPat l -> RPatOp l -> RPat l
RPOp L
l) RPatOp L
rpop)
fPrecOp (RPCAs L
l Name L
n RPat L
rp) RPat L -> RPat L
f = RPat L -> (RPat L -> RPat L) -> (RPat L -> RPat L) -> RPat L
fPrecAs RPat L
rp RPat L -> RPat L
f (L -> Name L -> RPat L -> RPat L
forall l. l -> Name l -> RPat l -> RPat l
RPCAs L
l Name L
n)
fPrecOp (RPAs L
l Name L
n RPat L
rp) RPat L -> RPat L
f = RPat L -> (RPat L -> RPat L) -> (RPat L -> RPat L) -> RPat L
fPrecAs RPat L
rp RPat L -> RPat L
f (L -> Name L -> RPat L -> RPat L
forall l. l -> Name l -> RPat l -> RPat l
RPAs L
l Name L
n)
fPrecOp RPat L
rp RPat L -> RPat L
f = RPat L -> RPat L
f (RPat L -> RPat L) -> RPat L -> RPat L
forall a b. (a -> b) -> a -> b
$ RPat L -> RPat L
fixRPOpPrec RPat L
rp
fPrecAs :: RPat L -> (RPat L -> RPat L) -> (RPat L -> RPat L) -> RPat L
fPrecAs :: RPat L -> (RPat L -> RPat L) -> (RPat L -> RPat L) -> RPat L
fPrecAs (RPCAs L
l Name L
n RPat L
rp) RPat L -> RPat L
f RPat L -> RPat L
g = RPat L -> (RPat L -> RPat L) -> (RPat L -> RPat L) -> RPat L
fPrecAs RPat L
rp RPat L -> RPat L
f (RPat L -> RPat L
g (RPat L -> RPat L) -> (RPat L -> RPat L) -> RPat L -> RPat L
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> Name L -> RPat L -> RPat L
forall l. l -> Name l -> RPat l -> RPat l
RPCAs L
l Name L
n)
fPrecAs (RPAs L
l Name L
n RPat L
rp) RPat L -> RPat L
f RPat L -> RPat L
g = RPat L -> (RPat L -> RPat L) -> (RPat L -> RPat L) -> RPat L
fPrecAs RPat L
rp RPat L -> RPat L
f (RPat L -> RPat L
g (RPat L -> RPat L) -> (RPat L -> RPat L) -> RPat L -> RPat L
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> Name L -> RPat L -> RPat L
forall l. l -> Name l -> RPat l -> RPat l
RPAs L
l Name L
n)
fPrecAs RPat L
rp RPat L -> RPat L
f RPat L -> RPat L
g = RPat L -> RPat L
g (RPat L -> RPat L) -> (RPat L -> RPat L) -> RPat L -> RPat L
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RPat L -> RPat L
f (RPat L -> RPat L) -> RPat L -> RPat L
forall a b. (a -> b) -> a -> b
$ RPat L -> RPat L
fixRPOpPrec RPat L
rp
mkChildrenPat :: [Pat L] -> [Pat L]
mkChildrenPat :: [Pat L] -> [Pat L]
mkChildrenPat [Pat L]
ps' = [Pat L] -> [Pat L] -> [Pat L]
mkCPAux [Pat L]
ps' []
where mkCPAux :: [Pat L] -> [Pat L] -> [Pat L]
mkCPAux :: [Pat L] -> [Pat L] -> [Pat L]
mkCPAux [] [Pat L]
qs = [Pat L] -> [Pat L]
forall a. [a] -> [a]
reverse [Pat L]
qs
mkCPAux (Pat L
p:[Pat L]
ps) [Pat L]
qs = case Pat L
p of
(PRPat L
l [RPat L]
rps) -> [L -> [Pat L] -> [RPat L] -> Pat L
mkCRP L
l [Pat L]
ps ([RPat L] -> [RPat L]
forall a. [a] -> [a]
reverse [RPat L]
rps [RPat L] -> [RPat L] -> [RPat L]
forall a. [a] -> [a] -> [a]
++ (Pat L -> RPat L) -> [Pat L] -> [RPat L]
forall a b. (a -> b) -> [a] -> [b]
map (\Pat L
q -> L -> Pat L -> RPat L
forall l. l -> Pat l -> RPat l
RPPat (Pat L -> L
forall l. Pat l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Pat L
q) Pat L
q) [Pat L]
qs)]
Pat L
_ -> [Pat L] -> [Pat L] -> [Pat L]
mkCPAux [Pat L]
ps (Pat L
pPat L -> [Pat L] -> [Pat L]
forall a. a -> [a] -> [a]
:[Pat L]
qs)
mkCRP :: L -> [Pat L] -> [RPat L] -> Pat L
mkCRP :: L -> [Pat L] -> [RPat L] -> Pat L
mkCRP L
l [] [RPat L]
rps = L -> [RPat L] -> Pat L
forall l. l -> [RPat l] -> Pat l
PXRPats L
l ([RPat L] -> Pat L) -> [RPat L] -> Pat L
forall a b. (a -> b) -> a -> b
$ [RPat L] -> [RPat L]
forall a. [a] -> [a]
reverse [RPat L]
rps
mkCRP L
_ (Pat L
p:[Pat L]
ps) [RPat L]
rps = case Pat L
p of
(PXRPats L
l [RPat L]
rqs) -> L -> [Pat L] -> [RPat L] -> Pat L
mkCRP L
l [Pat L]
ps ([RPat L] -> [RPat L]
forall a. [a] -> [a]
reverse [RPat L]
rqs [RPat L] -> [RPat L] -> [RPat L]
forall a. [a] -> [a] -> [a]
++ [RPat L]
rps)
Pat L
_ -> L -> [Pat L] -> [RPat L] -> Pat L
mkCRP (Pat L -> L
forall l. Pat l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Pat L
p) [Pat L]
ps (L -> Pat L -> RPat L
forall l. l -> Pat l -> RPat l
RPPat (Pat L -> L
forall l. Pat l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Pat L
p) Pat L
p RPat L -> [RPat L] -> [RPat L]
forall a. a -> [a] -> [a]
: [RPat L]
rps)
checkExpr :: PExp L -> P (S.Exp L)
checkExpr :: PExp L -> P (Exp L)
checkExpr PExp L
e' = case PExp L
e' of
Var L
l QName L
v -> Exp L -> P (Exp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp L -> P (Exp L)) -> Exp L -> P (Exp L)
forall a b. (a -> b) -> a -> b
$ L -> QName L -> Exp L
forall l. l -> QName l -> Exp l
S.Var L
l QName L
v
OverloadedLabel L
l String
v -> Exp L -> P (Exp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp L -> P (Exp L)) -> Exp L -> P (Exp L)
forall a b. (a -> b) -> a -> b
$ L -> String -> Exp L
forall l. l -> String -> Exp l
S.OverloadedLabel L
l String
v
IPVar L
l IPName L
v -> Exp L -> P (Exp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp L -> P (Exp L)) -> Exp L -> P (Exp L)
forall a b. (a -> b) -> a -> b
$ L -> IPName L -> Exp L
forall l. l -> IPName l -> Exp l
S.IPVar L
l IPName L
v
Con L
l QName L
c -> Exp L -> P (Exp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp L -> P (Exp L)) -> Exp L -> P (Exp L)
forall a b. (a -> b) -> a -> b
$ L -> QName L -> Exp L
forall l. l -> QName l -> Exp l
S.Con L
l QName L
c
Lit L
l Literal L
lit -> Exp L -> P (Exp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp L -> P (Exp L)) -> Exp L -> P (Exp L)
forall a b. (a -> b) -> a -> b
$ L -> Literal L -> Exp L
forall l. l -> Literal l -> Exp l
S.Lit L
l Literal L
lit
InfixApp L
l PExp L
e1 QOp L
op PExp L
e2 -> PExp L -> PExp L -> (Exp L -> Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> PExp L -> (Exp L -> Exp L -> a) -> P a
check2Exprs PExp L
e1 PExp L
e2 ((Exp L -> QOp L -> Exp L -> Exp L)
-> QOp L -> Exp L -> Exp L -> Exp L
forall a b c. (a -> b -> c) -> b -> a -> c
flip (L -> Exp L -> QOp L -> Exp L -> Exp L
forall l. l -> Exp l -> QOp l -> Exp l -> Exp l
S.InfixApp L
l) QOp L
op)
App L
l PExp L
e1 PExp L
e2 -> PExp L -> PExp L -> (Exp L -> Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> PExp L -> (Exp L -> Exp L -> a) -> P a
check2Exprs PExp L
e1 PExp L
e2 (L -> Exp L -> Exp L -> Exp L
forall l. l -> Exp l -> Exp l -> Exp l
S.App L
l)
NegApp L
_ (Lit L
_ (PrimWord L
_ Integer
_ String
_))
-> String -> P (Exp L)
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> P (Exp L)) -> String -> P (Exp L)
forall a b. (a -> b) -> a -> b
$ String
"Parse error: negative primitive word literal: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PExp L -> String
forall a. Pretty a => a -> String
prettyPrint PExp L
e'
NegApp L
l PExp L
e -> PExp L -> (Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e (L -> Exp L -> Exp L
forall l. l -> Exp l -> Exp l
S.NegApp L
l)
Lambda L
loc [Pat L]
ps PExp L
e -> PExp L -> (Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e (L -> [Pat L] -> Exp L -> Exp L
forall l. l -> [Pat l] -> Exp l -> Exp l
S.Lambda L
loc [Pat L]
ps)
Let L
l Binds L
bs PExp L
e -> PExp L -> (Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e (L -> Binds L -> Exp L -> Exp L
forall l. l -> Binds l -> Exp l -> Exp l
S.Let L
l Binds L
bs)
If L
l PExp L
e1 PExp L
e2 PExp L
e3 -> PExp L
-> PExp L
-> PExp L
-> (Exp L -> Exp L -> Exp L -> Exp L)
-> P (Exp L)
forall a.
PExp L -> PExp L -> PExp L -> (Exp L -> Exp L -> Exp L -> a) -> P a
check3Exprs PExp L
e1 PExp L
e2 PExp L
e3 (L -> Exp L -> Exp L -> Exp L -> Exp L
forall l. l -> Exp l -> Exp l -> Exp l -> Exp l
S.If L
l)
MultiIf L
l [GuardedRhs L]
alts -> Exp L -> P (Exp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> [GuardedRhs L] -> Exp L
forall l. l -> [GuardedRhs l] -> Exp l
S.MultiIf L
l [GuardedRhs L]
alts)
Case L
l PExp L
e [Alt L]
alts -> do
e1 <- PExp L -> P (Exp L)
checkExpr PExp L
e
return (S.Case l e1 alts)
Do L
l [Stmt L]
stmts -> [Stmt L] -> P ()
forall t. [Stmt t] -> P ()
checkDo [Stmt L]
stmts P () -> P (Exp L) -> P (Exp L)
forall a b. P a -> P b -> P b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Exp L -> P (Exp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> [Stmt L] -> Exp L
forall l. l -> [Stmt l] -> Exp l
S.Do L
l [Stmt L]
stmts)
MDo L
l [Stmt L]
stmts -> [Stmt L] -> P ()
forall t. [Stmt t] -> P ()
checkDo [Stmt L]
stmts P () -> P (Exp L) -> P (Exp L)
forall a b. P a -> P b -> P b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Exp L -> P (Exp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> [Stmt L] -> Exp L
forall l. l -> [Stmt l] -> Exp l
S.MDo L
l [Stmt L]
stmts)
TupleSection L
l Boxed
bx [Maybe (PExp L)]
mes -> if Maybe (PExp L)
forall a. Maybe a
Nothing Maybe (PExp L) -> [Maybe (PExp L)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Maybe (PExp L)]
mes
then [PExp L] -> ([Exp L] -> Exp L) -> P (Exp L)
forall a. [PExp L] -> ([Exp L] -> a) -> P a
checkManyExprs ((Maybe (PExp L) -> PExp L) -> [Maybe (PExp L)] -> [PExp L]
forall a b. (a -> b) -> [a] -> [b]
map Maybe (PExp L) -> PExp L
forall a. HasCallStack => Maybe a -> a
fromJust [Maybe (PExp L)]
mes) (L -> Boxed -> [Exp L] -> Exp L
forall l. l -> Boxed -> [Exp l] -> Exp l
S.Tuple L
l Boxed
bx)
else do KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
TupleSections
mes' <- (Maybe (PExp L) -> P (Maybe (Exp L)))
-> [Maybe (PExp L)] -> P [Maybe (Exp L)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Maybe (PExp L) -> P (Maybe (Exp L))
mCheckExpr [Maybe (PExp L)]
mes
return $ S.TupleSection l bx mes'
UnboxedSum L
l Int
before Int
after PExp L
e -> L -> Int -> Int -> Exp L -> Exp L
forall l. l -> Int -> Int -> Exp l -> Exp l
S.UnboxedSum L
l Int
before Int
after (Exp L -> Exp L) -> P (Exp L) -> P (Exp L)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PExp L -> P (Exp L)
checkExpr PExp L
e
List L
l [PExp L]
es -> [PExp L] -> ([Exp L] -> Exp L) -> P (Exp L)
forall a. [PExp L] -> ([Exp L] -> a) -> P a
checkManyExprs [PExp L]
es (L -> [Exp L] -> Exp L
forall l. l -> [Exp l] -> Exp l
S.List L
l)
ParArray L
l [PExp L]
es -> [PExp L] -> ([Exp L] -> Exp L) -> P (Exp L)
forall a. [PExp L] -> ([Exp L] -> a) -> P a
checkManyExprs [PExp L]
es (L -> [Exp L] -> Exp L
forall l. l -> [Exp l] -> Exp l
S.ParArray L
l)
Paren L
l PExp L
e -> case PExp L
e of
PostOp L
_ PExp L
e1 QOp L
op -> PExp L -> (Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e1 ((Exp L -> QOp L -> Exp L) -> QOp L -> Exp L -> Exp L
forall a b c. (a -> b -> c) -> b -> a -> c
flip (L -> Exp L -> QOp L -> Exp L
forall l. l -> Exp l -> QOp l -> Exp l
S.LeftSection L
l) QOp L
op)
PreOp L
_ QOp L
op PExp L
e2 -> PExp L -> (Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e2 (L -> QOp L -> Exp L -> Exp L
forall l. l -> QOp l -> Exp l -> Exp l
S.RightSection L
l QOp L
op)
PExp L
_ -> PExp L -> (Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e (L -> Exp L -> Exp L
forall l. l -> Exp l -> Exp l
S.Paren L
l)
RecConstr L
l QName L
c [PFieldUpdate L]
fields -> do
fields1 <- (PFieldUpdate L -> P (FieldUpdate L))
-> [PFieldUpdate L] -> P [FieldUpdate L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PFieldUpdate L -> P (FieldUpdate L)
checkField [PFieldUpdate L]
fields
return (S.RecConstr l c fields1)
RecUpdate L
l PExp L
e [PFieldUpdate L]
fields -> do
fields1 <- (PFieldUpdate L -> P (FieldUpdate L))
-> [PFieldUpdate L] -> P [FieldUpdate L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PFieldUpdate L -> P (FieldUpdate L)
checkField [PFieldUpdate L]
fields
e1 <- checkExpr e
return (S.RecUpdate l e1 fields1)
EnumFrom L
l PExp L
e -> PExp L -> (Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e (L -> Exp L -> Exp L
forall l. l -> Exp l -> Exp l
S.EnumFrom L
l)
EnumFromTo L
l PExp L
e1 PExp L
e2 -> PExp L -> PExp L -> (Exp L -> Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> PExp L -> (Exp L -> Exp L -> a) -> P a
check2Exprs PExp L
e1 PExp L
e2 (L -> Exp L -> Exp L -> Exp L
forall l. l -> Exp l -> Exp l -> Exp l
S.EnumFromTo L
l)
EnumFromThen L
l PExp L
e1 PExp L
e2 -> PExp L -> PExp L -> (Exp L -> Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> PExp L -> (Exp L -> Exp L -> a) -> P a
check2Exprs PExp L
e1 PExp L
e2 (L -> Exp L -> Exp L -> Exp L
forall l. l -> Exp l -> Exp l -> Exp l
S.EnumFromThen L
l)
EnumFromThenTo L
l PExp L
e1 PExp L
e2 PExp L
e3 -> PExp L
-> PExp L
-> PExp L
-> (Exp L -> Exp L -> Exp L -> Exp L)
-> P (Exp L)
forall a.
PExp L -> PExp L -> PExp L -> (Exp L -> Exp L -> Exp L -> a) -> P a
check3Exprs PExp L
e1 PExp L
e2 PExp L
e3 (L -> Exp L -> Exp L -> Exp L -> Exp L
forall l. l -> Exp l -> Exp l -> Exp l -> Exp l
S.EnumFromThenTo L
l)
ParArrayFromTo L
l PExp L
e1 PExp L
e2 -> PExp L -> PExp L -> (Exp L -> Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> PExp L -> (Exp L -> Exp L -> a) -> P a
check2Exprs PExp L
e1 PExp L
e2 (L -> Exp L -> Exp L -> Exp L
forall l. l -> Exp l -> Exp l -> Exp l
S.ParArrayFromTo L
l)
ParArrayFromThenTo L
l PExp L
e1 PExp L
e2 PExp L
e3 -> PExp L
-> PExp L
-> PExp L
-> (Exp L -> Exp L -> Exp L -> Exp L)
-> P (Exp L)
forall a.
PExp L -> PExp L -> PExp L -> (Exp L -> Exp L -> Exp L -> a) -> P a
check3Exprs PExp L
e1 PExp L
e2 PExp L
e3 (L -> Exp L -> Exp L -> Exp L -> Exp L
forall l. l -> Exp l -> Exp l -> Exp l -> Exp l
S.ParArrayFromThenTo L
l)
ParComp L
l PExp L
e [[QualStmt L]]
qualss -> do
e1 <- PExp L -> P (Exp L)
checkExpr PExp L
e
case qualss of
[[QualStmt L]
quals] -> Exp L -> P (Exp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Exp L -> [QualStmt L] -> Exp L
forall l. l -> Exp l -> [QualStmt l] -> Exp l
S.ListComp L
l Exp L
e1 [QualStmt L]
quals)
[[QualStmt L]]
_ -> Exp L -> P (Exp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Exp L -> [[QualStmt L]] -> Exp L
forall l. l -> Exp l -> [[QualStmt l]] -> Exp l
S.ParComp L
l Exp L
e1 [[QualStmt L]]
qualss)
ParArrayComp L
l PExp L
e [[QualStmt L]]
qualss -> do
e1 <- PExp L -> P (Exp L)
checkExpr PExp L
e
return (S.ParArrayComp l e1 qualss)
ExpTypeSig L
loc PExp L
e Type L
ty -> do
e1 <- PExp L -> P (Exp L)
checkExpr PExp L
e
return (S.ExpTypeSig loc e1 ty)
BracketExp L
l Bracket L
e -> Exp L -> P (Exp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp L -> P (Exp L)) -> Exp L -> P (Exp L)
forall a b. (a -> b) -> a -> b
$ L -> Bracket L -> Exp L
forall l. l -> Bracket l -> Exp l
S.BracketExp L
l Bracket L
e
SpliceExp L
l Splice L
e -> Exp L -> P (Exp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp L -> P (Exp L)) -> Exp L -> P (Exp L)
forall a b. (a -> b) -> a -> b
$ L -> Splice L -> Exp L
forall l. l -> Splice l -> Exp l
S.SpliceExp L
l Splice L
e
TypQuote L
l QName L
q -> Exp L -> P (Exp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp L -> P (Exp L)) -> Exp L -> P (Exp L)
forall a b. (a -> b) -> a -> b
$ L -> QName L -> Exp L
forall l. l -> QName l -> Exp l
S.TypQuote L
l QName L
q
VarQuote L
l QName L
q -> Exp L -> P (Exp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp L -> P (Exp L)) -> Exp L -> P (Exp L)
forall a b. (a -> b) -> a -> b
$ L -> QName L -> Exp L
forall l. l -> QName l -> Exp l
S.VarQuote L
l QName L
q
QuasiQuote L
l String
n String
q -> Exp L -> P (Exp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp L -> P (Exp L)) -> Exp L -> P (Exp L)
forall a b. (a -> b) -> a -> b
$ L -> String -> String -> Exp L
forall l. l -> String -> String -> Exp l
S.QuasiQuote L
l String
n String
q
XTag L
l XName L
n [ParseXAttr L]
attrs Maybe (PExp L)
mattr [PExp L]
cs -> do attrs1 <- (ParseXAttr L -> P (XAttr L)) -> [ParseXAttr L] -> P [XAttr L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ParseXAttr L -> P (XAttr L)
checkAttr [ParseXAttr L]
attrs
cs1 <- mapM checkExpr cs
mattr1 <- maybe (return Nothing)
(\PExp L
e -> PExp L -> P (Exp L)
checkExpr PExp L
e P (Exp L) -> (Exp L -> P (Maybe (Exp L))) -> P (Maybe (Exp L))
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (Exp L) -> P (Maybe (Exp L))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Exp L) -> P (Maybe (Exp L)))
-> (Exp L -> Maybe (Exp L)) -> Exp L -> P (Maybe (Exp L))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp L -> Maybe (Exp L)
forall a. a -> Maybe a
Just)
mattr
return $ S.XTag l n attrs1 mattr1 cs1
XETag L
l XName L
n [ParseXAttr L]
attrs Maybe (PExp L)
mattr -> do attrs1 <- (ParseXAttr L -> P (XAttr L)) -> [ParseXAttr L] -> P [XAttr L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ParseXAttr L -> P (XAttr L)
checkAttr [ParseXAttr L]
attrs
mattr1 <- maybe (return Nothing)
(\PExp L
e -> PExp L -> P (Exp L)
checkExpr PExp L
e P (Exp L) -> (Exp L -> P (Maybe (Exp L))) -> P (Maybe (Exp L))
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (Exp L) -> P (Maybe (Exp L))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Exp L) -> P (Maybe (Exp L)))
-> (Exp L -> Maybe (Exp L)) -> Exp L -> P (Maybe (Exp L))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp L -> Maybe (Exp L)
forall a. a -> Maybe a
Just)
mattr
return $ S.XETag l n attrs1 mattr1
XPcdata L
l String
p -> Exp L -> P (Exp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp L -> P (Exp L)) -> Exp L -> P (Exp L)
forall a b. (a -> b) -> a -> b
$ L -> String -> Exp L
forall l. l -> String -> Exp l
S.XPcdata L
l String
p
XExpTag L
l PExp L
e -> do e1 <- PExp L -> P (Exp L)
checkExpr PExp L
e
return $ S.XExpTag l e1
XChildTag L
l [PExp L]
es -> do es1 <- (PExp L -> P (Exp L)) -> [PExp L] -> P [Exp L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PExp L -> P (Exp L)
checkExpr [PExp L]
es
return $ S.XChildTag l es1
CorePragma L
l String
s PExp L
e -> PExp L -> (Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e (L -> String -> Exp L -> Exp L
forall l. l -> String -> Exp l -> Exp l
S.CorePragma L
l String
s)
SCCPragma L
l String
s PExp L
e -> PExp L -> (Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e (L -> String -> Exp L -> Exp L
forall l. l -> String -> Exp l -> Exp l
S.SCCPragma L
l String
s)
GenPragma L
l String
s (Int, Int)
xx (Int, Int)
yy PExp L
e -> PExp L -> (Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e (L -> String -> (Int, Int) -> (Int, Int) -> Exp L -> Exp L
forall l. l -> String -> (Int, Int) -> (Int, Int) -> Exp l -> Exp l
S.GenPragma L
l String
s (Int, Int)
xx (Int, Int)
yy)
Proc L
l Pat L
p PExp L
e -> do e1 <- PExp L -> P (Exp L)
checkExpr PExp L
e
return $ S.Proc l p e1
LeftArrApp L
l PExp L
e1 PExp L
e2 -> PExp L -> PExp L -> (Exp L -> Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> PExp L -> (Exp L -> Exp L -> a) -> P a
check2Exprs PExp L
e1 PExp L
e2 (L -> Exp L -> Exp L -> Exp L
forall l. l -> Exp l -> Exp l -> Exp l
S.LeftArrApp L
l)
RightArrApp L
l PExp L
e1 PExp L
e2 -> PExp L -> PExp L -> (Exp L -> Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> PExp L -> (Exp L -> Exp L -> a) -> P a
check2Exprs PExp L
e1 PExp L
e2 (L -> Exp L -> Exp L -> Exp L
forall l. l -> Exp l -> Exp l -> Exp l
S.RightArrApp L
l)
LeftArrHighApp L
l PExp L
e1 PExp L
e2 -> PExp L -> PExp L -> (Exp L -> Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> PExp L -> (Exp L -> Exp L -> a) -> P a
check2Exprs PExp L
e1 PExp L
e2 (L -> Exp L -> Exp L -> Exp L
forall l. l -> Exp l -> Exp l -> Exp l
S.LeftArrHighApp L
l)
RightArrHighApp L
l PExp L
e1 PExp L
e2 -> PExp L -> PExp L -> (Exp L -> Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> PExp L -> (Exp L -> Exp L -> a) -> P a
check2Exprs PExp L
e1 PExp L
e2 (L -> Exp L -> Exp L -> Exp L
forall l. l -> Exp l -> Exp l -> Exp l
S.RightArrHighApp L
l)
ArrOp L
l PExp L
e -> L -> Exp L -> Exp L
forall l. l -> Exp l -> Exp l
S.ArrOp L
l (Exp L -> Exp L) -> P (Exp L) -> P (Exp L)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PExp L -> P (Exp L)
checkExpr PExp L
e
LCase L
l [Alt L]
alts -> Exp L -> P (Exp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp L -> P (Exp L)) -> Exp L -> P (Exp L)
forall a b. (a -> b) -> a -> b
$ L -> [Alt L] -> Exp L
forall l. l -> [Alt l] -> Exp l
S.LCase L
l [Alt L]
alts
TypeApp L
l Type L
ty -> Exp L -> P (Exp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp L -> P (Exp L)) -> Exp L -> P (Exp L)
forall a b. (a -> b) -> a -> b
$ L -> Type L -> Exp L
forall l. l -> Type l -> Exp l
S.TypeApp L
l Type L
ty
PExp L
_ -> String -> P (Exp L)
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> P (Exp L)) -> String -> P (Exp L)
forall a b. (a -> b) -> a -> b
$ String
"Parse error in expression: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PExp L -> String
forall a. Pretty a => a -> String
prettyPrint PExp L
e'
checkAttr :: ParseXAttr L -> P (S.XAttr L)
checkAttr :: ParseXAttr L -> P (XAttr L)
checkAttr (XAttr L
l XName L
n PExp L
v) = do v' <- PExp L -> P (Exp L)
checkExpr PExp L
v
return $ S.XAttr l n v'
checkDo :: [Stmt t] -> P ()
checkDo :: forall t. [Stmt t] -> P ()
checkDo [] = String -> P ()
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Parse error: Last statement in a do-block must be an expression"
checkDo [Qualifier t
_ Exp t
_] = () -> P ()
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkDo (Stmt t
_:[Stmt t]
xs) = [Stmt t] -> P ()
forall t. [Stmt t] -> P ()
checkDo [Stmt t]
xs
check1Expr :: PExp L -> (S.Exp L -> a) -> P a
check1Expr :: forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e1 Exp L -> a
f = do
e1' <- PExp L -> P (Exp L)
checkExpr PExp L
e1
return (f e1')
check2Exprs :: PExp L -> PExp L -> (S.Exp L -> S.Exp L -> a) -> P a
check2Exprs :: forall a. PExp L -> PExp L -> (Exp L -> Exp L -> a) -> P a
check2Exprs PExp L
e1 PExp L
e2 Exp L -> Exp L -> a
f = do
e1' <- PExp L -> P (Exp L)
checkExpr PExp L
e1
e2' <- checkExpr e2
return (f e1' e2')
check3Exprs :: PExp L -> PExp L -> PExp L -> (S.Exp L -> S.Exp L -> S.Exp L -> a) -> P a
check3Exprs :: forall a.
PExp L -> PExp L -> PExp L -> (Exp L -> Exp L -> Exp L -> a) -> P a
check3Exprs PExp L
e1 PExp L
e2 PExp L
e3 Exp L -> Exp L -> Exp L -> a
f = do
e1' <- PExp L -> P (Exp L)
checkExpr PExp L
e1
e2' <- checkExpr e2
e3' <- checkExpr e3
return (f e1' e2' e3')
checkManyExprs :: [PExp L] -> ([S.Exp L] -> a) -> P a
checkManyExprs :: forall a. [PExp L] -> ([Exp L] -> a) -> P a
checkManyExprs [PExp L]
es [Exp L] -> a
f = do
es' <- (PExp L -> P (Exp L)) -> [PExp L] -> P [Exp L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PExp L -> P (Exp L)
checkExpr [PExp L]
es
return (f es')
mCheckExpr :: Maybe (PExp L) -> P (Maybe (S.Exp L))
mCheckExpr :: Maybe (PExp L) -> P (Maybe (Exp L))
mCheckExpr Maybe (PExp L)
Nothing = Maybe (Exp L) -> P (Maybe (Exp L))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Exp L)
forall a. Maybe a
Nothing
mCheckExpr (Just PExp L
e) = PExp L -> P (Exp L)
checkExpr PExp L
e P (Exp L) -> (Exp L -> P (Maybe (Exp L))) -> P (Maybe (Exp L))
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (Exp L) -> P (Maybe (Exp L))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Exp L) -> P (Maybe (Exp L)))
-> (Exp L -> Maybe (Exp L)) -> Exp L -> P (Maybe (Exp L))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp L -> Maybe (Exp L)
forall a. a -> Maybe a
Just
checkRuleExpr :: PExp L -> P (S.Exp L)
checkRuleExpr :: PExp L -> P (Exp L)
checkRuleExpr = PExp L -> P (Exp L)
checkExpr
readTool :: Maybe String -> Maybe Tool
readTool :: Maybe String -> Maybe Tool
readTool = (String -> Tool) -> Maybe String -> Maybe Tool
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Tool
readC
where readC :: String -> Tool
readC String
str = case String
str of
String
"GHC" -> Tool
GHC
String
"HUGS" -> Tool
HUGS
String
"NHC98" -> Tool
NHC98
String
"YHC" -> Tool
YHC
String
"HADDOCK" -> Tool
HADDOCK
String
_ -> String -> Tool
UnknownTool String
str
checkField :: PFieldUpdate L -> P (S.FieldUpdate L)
checkField :: PFieldUpdate L -> P (FieldUpdate L)
checkField (FieldUpdate L
l QName L
n PExp L
e) = PExp L -> (Exp L -> FieldUpdate L) -> P (FieldUpdate L)
forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e (L -> QName L -> Exp L -> FieldUpdate L
forall l. l -> QName l -> Exp l -> FieldUpdate l
S.FieldUpdate L
l QName L
n)
checkField (FieldPun L
l QName L
n) = FieldUpdate L -> P (FieldUpdate L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (FieldUpdate L -> P (FieldUpdate L))
-> FieldUpdate L -> P (FieldUpdate L)
forall a b. (a -> b) -> a -> b
$ L -> QName L -> FieldUpdate L
forall l. l -> QName l -> FieldUpdate l
S.FieldPun L
l QName L
n
checkField (FieldWildcard L
l) = FieldUpdate L -> P (FieldUpdate L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (FieldUpdate L -> P (FieldUpdate L))
-> FieldUpdate L -> P (FieldUpdate L)
forall a b. (a -> b) -> a -> b
$ L -> FieldUpdate L
forall l. l -> FieldUpdate l
S.FieldWildcard L
l
getGConName :: S.Exp L -> P (QName L)
getGConName :: Exp L -> P (QName L)
getGConName (S.Con L
_ QName L
n) = QName L -> P (QName L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return QName L
n
getGConName (S.List L
l []) = QName L -> P (QName L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> QName L
forall l. l -> QName l
list_cons_name L
l)
getGConName Exp L
_ = String -> P (QName L)
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expression in reification is not a name"
checkValDef :: L -> PExp L -> Maybe (S.Type L, S) -> Rhs L -> Maybe (Binds L) -> P (Decl L)
checkValDef :: L
-> PExp L
-> Maybe (Type L, SrcSpan)
-> Rhs L
-> Maybe (Binds L)
-> P (Decl L)
checkValDef L
l PExp L
lhs Maybe (Type L, SrcSpan)
optsig Rhs L
rhs Maybe (Binds L)
whereBinds = do
mlhs <- PExp L -> [PExp L] -> P (Maybe (Name L, [PExp L], Bool, [SrcSpan]))
isFunLhs PExp L
lhs []
let whpt = L -> [SrcSpan]
srcInfoPoints L
l
case mlhs of
Just (Name L
f,[PExp L]
es,Bool
b,[SrcSpan]
pts) -> do
ps <- (PExp L -> P (Pat L)) -> [PExp L] -> P [Pat L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PExp L -> P (Pat L)
checkPattern [PExp L]
es
let l' = L
l { srcInfoPoints = pts ++ whpt }
case optsig of
Maybe (Type L, SrcSpan)
Nothing -> Decl L -> P (Decl L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> [Match L] -> Decl L
forall l. l -> [Match l] -> Decl l
FunBind L
l ([Match L] -> Decl L) -> [Match L] -> Decl L
forall a b. (a -> b) -> a -> b
$
if Bool
b then [L -> Name L -> [Pat L] -> Rhs L -> Maybe (Binds L) -> Match L
forall l.
l -> Name l -> [Pat l] -> Rhs l -> Maybe (Binds l) -> Match l
Match L
l' Name L
f [Pat L]
ps Rhs L
rhs Maybe (Binds L)
whereBinds]
else let (Pat L
a:[Pat L]
bs) = [Pat L]
ps
in [L
-> Pat L
-> Name L
-> [Pat L]
-> Rhs L
-> Maybe (Binds L)
-> Match L
forall l.
l
-> Pat l
-> Name l
-> [Pat l]
-> Rhs l
-> Maybe (Binds l)
-> Match l
InfixMatch L
l' Pat L
a Name L
f [Pat L]
bs Rhs L
rhs Maybe (Binds L)
whereBinds])
Just (Type L, SrcSpan)
_ -> String -> P (Decl L)
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot give an explicit type signature to a function binding"
Maybe (Name L, [PExp L], Bool, [SrcSpan])
Nothing -> do
lhs1 <- PExp L -> P (Pat L)
checkPattern PExp L
lhs
let lhs' = case Maybe (Type L, SrcSpan)
optsig of
Maybe (Type L, SrcSpan)
Nothing -> Pat L
lhs1
Just (Type L
ty, SrcSpan
pt) -> let lp :: L
lp = (Pat L -> L
forall l. Pat l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Pat L
lhs1 L -> L -> L
<++> Type L -> L
forall l. Type l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Type L
ty) L -> [SrcSpan] -> L
<** [SrcSpan
pt]
in L -> Pat L -> Type L -> Pat L
forall l. l -> Pat l -> Type l -> Pat l
PatTypeSig L
lp Pat L
lhs1 Type L
ty
return (PatBind l lhs' rhs whereBinds)
isFunLhs :: PExp L -> [PExp L] -> P (Maybe (Name L, [PExp L], Bool, [S]))
isFunLhs :: PExp L -> [PExp L] -> P (Maybe (Name L, [PExp L], Bool, [SrcSpan]))
isFunLhs (InfixApp L
_ PExp L
l (QVarOp L
loc (UnQual L
_ Name L
op)) PExp L
r) [PExp L]
es
| Name L
op Name L -> Name () -> Bool
forall (a :: * -> *) l1 l2.
(Annotated a, Eq (a ())) =>
a l1 -> a l2 -> Bool
=~= () -> String -> Name ()
forall l. l -> String -> Name l
Symbol () String
"!" = do
exts <- P [KnownExtension]
getExtensions
if BangPatterns `elem` exts
then let (b,bs) = splitBang r []
loc' = L -> L -> L
combSpanInfo L
loc (PExp L -> L
forall l. PExp l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PExp L
b)
in isFunLhs l (BangPat loc' b : bs ++ es)
else return $ Just (op, l:r:es, False, [])
| Bool
otherwise =
let infos :: [SrcSpan]
infos = L -> [SrcSpan]
srcInfoPoints L
loc
op' :: Name L
op' = (L -> L) -> Name L -> Name L
forall l. (l -> l) -> Name l -> Name l
forall (ast :: * -> *) l.
Annotated ast =>
(l -> l) -> ast l -> ast l
amap (\L
s -> L
s { srcInfoPoints = infos }) Name L
op
in (Maybe (Name L, [PExp L], Bool, [SrcSpan])
-> P (Maybe (Name L, [PExp L], Bool, [SrcSpan]))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Name L, [PExp L], Bool, [SrcSpan])
-> P (Maybe (Name L, [PExp L], Bool, [SrcSpan])))
-> Maybe (Name L, [PExp L], Bool, [SrcSpan])
-> P (Maybe (Name L, [PExp L], Bool, [SrcSpan]))
forall a b. (a -> b) -> a -> b
$ (Name L, [PExp L], Bool, [SrcSpan])
-> Maybe (Name L, [PExp L], Bool, [SrcSpan])
forall a. a -> Maybe a
Just (Name L
op', PExp L
lPExp L -> [PExp L] -> [PExp L]
forall a. a -> [a] -> [a]
:PExp L
rPExp L -> [PExp L] -> [PExp L]
forall a. a -> [a] -> [a]
:[PExp L]
es, Bool
False, []))
isFunLhs (App L
_ (Var L
l (UnQual L
_ Name L
f)) PExp L
e) [PExp L]
es = Maybe (Name L, [PExp L], Bool, [SrcSpan])
-> P (Maybe (Name L, [PExp L], Bool, [SrcSpan]))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Name L, [PExp L], Bool, [SrcSpan])
-> P (Maybe (Name L, [PExp L], Bool, [SrcSpan])))
-> Maybe (Name L, [PExp L], Bool, [SrcSpan])
-> P (Maybe (Name L, [PExp L], Bool, [SrcSpan]))
forall a b. (a -> b) -> a -> b
$ (Name L, [PExp L], Bool, [SrcSpan])
-> Maybe (Name L, [PExp L], Bool, [SrcSpan])
forall a. a -> Maybe a
Just (Name L
f, PExp L
ePExp L -> [PExp L] -> [PExp L]
forall a. a -> [a] -> [a]
:[PExp L]
es, Bool
True, L -> [SrcSpan]
srcInfoPoints L
l)
isFunLhs (App L
_ PExp L
f PExp L
e) [PExp L]
es = PExp L -> [PExp L] -> P (Maybe (Name L, [PExp L], Bool, [SrcSpan]))
isFunLhs PExp L
f (PExp L
ePExp L -> [PExp L] -> [PExp L]
forall a. a -> [a] -> [a]
:[PExp L]
es)
isFunLhs (Var L
_ (UnQual L
_ Name L
f)) es :: [PExp L]
es@(PExp L
_:[PExp L]
_) = Maybe (Name L, [PExp L], Bool, [SrcSpan])
-> P (Maybe (Name L, [PExp L], Bool, [SrcSpan]))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Name L, [PExp L], Bool, [SrcSpan])
-> P (Maybe (Name L, [PExp L], Bool, [SrcSpan])))
-> Maybe (Name L, [PExp L], Bool, [SrcSpan])
-> P (Maybe (Name L, [PExp L], Bool, [SrcSpan]))
forall a b. (a -> b) -> a -> b
$ (Name L, [PExp L], Bool, [SrcSpan])
-> Maybe (Name L, [PExp L], Bool, [SrcSpan])
forall a. a -> Maybe a
Just (Name L
f, [PExp L]
es, Bool
True, [])
isFunLhs (Paren L
l PExp L
f) es :: [PExp L]
es@(PExp L
_:[PExp L]
_) = do mlhs <- PExp L -> [PExp L] -> P (Maybe (Name L, [PExp L], Bool, [SrcSpan]))
isFunLhs PExp L
f [PExp L]
es
case mlhs of
Just (Name L
f',[PExp L]
es',Bool
b,[SrcSpan]
pts) ->
let [SrcSpan
x,SrcSpan
y] = L -> [SrcSpan]
srcInfoPoints L
l
in Maybe (Name L, [PExp L], Bool, [SrcSpan])
-> P (Maybe (Name L, [PExp L], Bool, [SrcSpan]))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Name L, [PExp L], Bool, [SrcSpan])
-> P (Maybe (Name L, [PExp L], Bool, [SrcSpan])))
-> Maybe (Name L, [PExp L], Bool, [SrcSpan])
-> P (Maybe (Name L, [PExp L], Bool, [SrcSpan]))
forall a b. (a -> b) -> a -> b
$ (Name L, [PExp L], Bool, [SrcSpan])
-> Maybe (Name L, [PExp L], Bool, [SrcSpan])
forall a. a -> Maybe a
Just (Name L
f',[PExp L]
es',Bool
b,SrcSpan
xSrcSpan -> [SrcSpan] -> [SrcSpan]
forall a. a -> [a] -> [a]
:[SrcSpan]
pts[SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
++[SrcSpan
y])
Maybe (Name L, [PExp L], Bool, [SrcSpan])
_ -> Maybe (Name L, [PExp L], Bool, [SrcSpan])
-> P (Maybe (Name L, [PExp L], Bool, [SrcSpan]))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Name L, [PExp L], Bool, [SrcSpan])
forall a. Maybe a
Nothing
isFunLhs PExp L
_ [PExp L]
_ = Maybe (Name L, [PExp L], Bool, [SrcSpan])
-> P (Maybe (Name L, [PExp L], Bool, [SrcSpan]))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Name L, [PExp L], Bool, [SrcSpan])
forall a. Maybe a
Nothing
checkSigVar :: PExp L -> P (Name L)
checkSigVar :: PExp L -> P (Name L)
checkSigVar (Var L
_ (UnQual L
l Name L
n)) = Name L -> P (Name L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name L -> P (Name L)) -> Name L -> P (Name L)
forall a b. (a -> b) -> a -> b
$ (L -> L) -> Name L -> Name L
forall a b. (a -> b) -> Name a -> Name b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (L -> L -> L
forall a b. a -> b -> a
const L
l) Name L
n
checkSigVar PExp L
e = String -> P (Name L)
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> P (Name L)) -> String -> P (Name L)
forall a b. (a -> b) -> a -> b
$ String
"Left-hand side of type signature is not a variable: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PExp L -> String
forall a. Pretty a => a -> String
prettyPrint PExp L
e
checkExplicitPatSyn :: S -> S -> ([Decl L], [S]) -> S -> P (PatternSynDirection L)
checkExplicitPatSyn :: SrcSpan
-> SrcSpan
-> ([Decl L], [SrcSpan])
-> SrcSpan
-> P (PatternSynDirection L)
checkExplicitPatSyn SrcSpan
whereLoc SrcSpan
openLoc ([Decl L]
decls, [SrcSpan]
semis) SrcSpan
closeLoc =
let l :: L
l = SrcSpan
whereLoc SrcSpan -> SrcSpan -> L
<^^> SrcSpan
closeLoc L -> [SrcSpan] -> L
<** ([SrcSpan
whereLoc, SrcSpan
openLoc] [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
++ [SrcSpan]
semis [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
++ [SrcSpan
closeLoc])
in L -> [Decl L] -> PatternSynDirection L
forall l. l -> [Decl l] -> PatternSynDirection l
S.ExplicitBidirectional L
l ([Decl L] -> PatternSynDirection L)
-> P [Decl L] -> P (PatternSynDirection L)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Decl L -> P (Decl L)) -> [Decl L] -> P [Decl L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Decl L -> P (Decl L)
checkDecls [Decl L]
decls
where
checkDecls :: Decl L -> P (Decl L)
checkDecls :: Decl L -> P (Decl L)
checkDecls p :: Decl L
p@(PatBind L
_ Pat L
pat Rhs L
_ Maybe (Binds L)
_) =
case Pat L
pat of
PApp L
_ QName L
_ [Pat L]
_ -> Decl L -> P (Decl L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return Decl L
p
PInfixApp L
_ Pat L
_ QName L
_ Pat L
_ -> Decl L -> P (Decl L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return Decl L
p
Pat L
_ -> String -> P (Decl L)
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Illegal pattern binding in PatternSynonym"
checkDecls Decl L
_ = String -> P (Decl L)
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"pattern synonym 'where' clause must contain a PatBind"
checkClassBody :: [ClassDecl L] -> P [ClassDecl L]
checkClassBody :: [ClassDecl L] -> P [ClassDecl L]
checkClassBody [ClassDecl L]
decls = do
(ClassDecl L -> P ()) -> [ClassDecl L] -> P ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ClassDecl L -> P ()
checkClassMethodDef [ClassDecl L]
decls
[ClassDecl L] -> P [ClassDecl L]
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return [ClassDecl L]
decls
where checkClassMethodDef :: ClassDecl L -> P ()
checkClassMethodDef (ClsDecl L
_ Decl L
decl) = Decl L -> P ()
checkMethodDef Decl L
decl
checkClassMethodDef ClassDecl L
_ = () -> P ()
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkInstBody :: [InstDecl L] -> P [InstDecl L]
checkInstBody :: [InstDecl L] -> P [InstDecl L]
checkInstBody [InstDecl L]
decls = do
(InstDecl L -> P ()) -> [InstDecl L] -> P ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ InstDecl L -> P ()
checkInstMethodDef [InstDecl L]
decls
[InstDecl L] -> P [InstDecl L]
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return [InstDecl L]
decls
where checkInstMethodDef :: InstDecl L -> P ()
checkInstMethodDef (InsDecl L
_ Decl L
decl) = Decl L -> P ()
checkMethodDef Decl L
decl
checkInstMethodDef InstDecl L
_ = () -> P ()
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkMethodDef :: Decl L -> P ()
checkMethodDef :: Decl L -> P ()
checkMethodDef (PatBind L
_ (PVar L
_ Name L
_) Rhs L
_ Maybe (Binds L)
_) = () -> P ()
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkMethodDef (PatBind L
loc Pat L
_ Rhs L
_ Maybe (Binds L)
_) =
String -> P ()
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"illegal method definition" P () -> SrcLoc -> P ()
forall a. P a -> SrcLoc -> P a
`atSrcLoc` L -> SrcLoc
forall si. SrcInfo si => L -> si
fromSrcInfo L
loc
checkMethodDef Decl L
_ = () -> P ()
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkDefSigDef :: Decl L -> P (Name L,S.Type L,S)
checkDefSigDef :: Decl L -> P (Name L, Type L, SrcSpan)
checkDefSigDef (TypeSig L
loc [Name L
name] Type L
typ) =
let (SrcSpan
b:[SrcSpan]
_) = L -> [SrcSpan]
srcInfoPoints L
loc in (Name L, Type L, SrcSpan) -> P (Name L, Type L, SrcSpan)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name L
name,Type L
typ,SrcSpan
b)
checkDefSigDef (TypeSig L
_ [Name L]
_ Type L
_) =
String -> P (Name L, Type L, SrcSpan)
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"default signature must be for a single name"
checkDefSigDef Decl L
_ =
String -> P (Name L, Type L, SrcSpan)
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"default signature must be a type signature"
checkUnQual :: QName L -> P (Name L)
checkUnQual :: QName L -> P (Name L)
checkUnQual (Qual L
_ ModuleName L
_ Name L
_) = String -> P (Name L)
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Illegal qualified name"
checkUnQual (UnQual L
l Name L
n) = Name L -> P (Name L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name L -> P (Name L)) -> Name L -> P (Name L)
forall a b. (a -> b) -> a -> b
$ (L -> L) -> Name L -> Name L
forall a b. (a -> b) -> Name a -> Name b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (L -> L -> L
forall a b. a -> b -> a
const L
l) Name L
n
checkUnQual (Special L
_ SpecialCon L
_) = String -> P (Name L)
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Illegal special name"
checkQualOrUnQual :: QName L -> P (QName L)
checkQualOrUnQual :: QName L -> P (QName L)
checkQualOrUnQual n :: QName L
n@(Qual L
_ ModuleName L
_ Name L
_) = QName L -> P (QName L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return QName L
n
checkQualOrUnQual n :: QName L
n@(UnQual L
_ Name L
_) = QName L -> P (QName L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return QName L
n
checkQualOrUnQual (Special L
_ SpecialCon L
_) = String -> P (QName L)
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Illegal special name"
checkEqNames :: XName L -> XName L -> P (XName L)
checkEqNames :: XName L -> XName L -> P (XName L)
checkEqNames n :: XName L
n@(XName L
_ String
n1) (XName L
_ String
n2)
| String
n1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
n2 = XName L -> P (XName L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return XName L
n
checkEqNames n :: XName L
n@(XDomName L
_ String
d1 String
n1) (XDomName L
_ String
d2 String
n2)
| String
n1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
n2 Bool -> Bool -> Bool
&& String
d1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
d2 = XName L -> P (XName L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return XName L
n
checkEqNames XName L
n XName L
m = String -> P (XName L)
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> P (XName L)) -> String -> P (XName L)
forall a b. (a -> b) -> a -> b
$ String
"opening tag '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ XName L -> String
forall {l}. XName l -> String
showTag XName L
n String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"' does not match closing tag '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ XName L -> String
forall {l}. XName l -> String
showTag XName L
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
where
showTag :: XName l -> String
showTag (XName l
_ String
n') = String
n'
showTag (XDomName l
_ String
d String
n') = String
d String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n'
checkPrec :: Integer -> P Int
checkPrec :: Integer -> P Int
checkPrec Integer
i | Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
i Bool -> Bool -> Bool
&& Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
9 = Int -> P Int
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
i)
| Bool
otherwise = String -> P Int
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Illegal precedence " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
i)
mkRecConstrOrUpdate :: PExp L -> [PFieldUpdate L] -> P (PExp L)
mkRecConstrOrUpdate :: PExp L -> [PFieldUpdate L] -> P (PExp L)
mkRecConstrOrUpdate (Con L
l QName L
c) [PFieldUpdate L]
fs = PExp L -> P (PExp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> QName L -> [PFieldUpdate L] -> PExp L
forall l. l -> QName l -> [PFieldUpdate l] -> PExp l
RecConstr L
l QName L
c [PFieldUpdate L]
fs)
mkRecConstrOrUpdate PExp L
e fs :: [PFieldUpdate L]
fs@(PFieldUpdate L
_:[PFieldUpdate L]
_) = PExp L -> P (PExp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> PExp L -> [PFieldUpdate L] -> PExp L
forall l. l -> PExp l -> [PFieldUpdate l] -> PExp l
RecUpdate (PExp L -> L
forall l. PExp l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PExp L
e) PExp L
e [PFieldUpdate L]
fs)
mkRecConstrOrUpdate PExp L
_ [PFieldUpdate L]
_ = String -> P (PExp L)
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Empty record update"
updateQNameLoc :: l -> QName l -> QName l
updateQNameLoc :: forall l. l -> QName l -> QName l
updateQNameLoc l
l (Qual l
_ ModuleName l
mn Name l
n) = l -> ModuleName l -> Name l -> QName l
forall l. l -> ModuleName l -> Name l -> QName l
Qual l
l ModuleName l
mn Name l
n
updateQNameLoc l
l (UnQual l
_ Name l
n) = l -> Name l -> QName l
forall l. l -> Name l -> QName l
UnQual l
l Name l
n
updateQNameLoc l
l (Special l
_ SpecialCon l
s) = l -> SpecialCon l -> QName l
forall l. l -> SpecialCon l -> QName l
Special l
l SpecialCon l
s
checkSingleDecl :: [Decl L] -> P (Decl L)
checkSingleDecl :: [Decl L] -> P (Decl L)
checkSingleDecl [Decl L
d] = Decl L -> P (Decl L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return Decl L
d
checkSingleDecl [Decl L]
ds =
String -> P (Decl L)
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> P (Decl L)) -> String -> P (Decl L)
forall a b. (a -> b) -> a -> b
$ String
"Expected a single declaration, found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Decl L] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Decl L]
ds)
checkRevDecls :: [Decl L] -> P [Decl L]
checkRevDecls :: [Decl L] -> P [Decl L]
checkRevDecls = [Decl L] -> [Decl L] -> P [Decl L]
mergeFunBinds []
where
mergeFunBinds :: [Decl L] -> [Decl L] -> P [Decl L]
mergeFunBinds [Decl L]
revDs [] = [Decl L] -> P [Decl L]
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return [Decl L]
revDs
mergeFunBinds [Decl L]
revDs (FunBind L
l' ms1 :: [Match L]
ms1@(Match L
_ Name L
name [Pat L]
ps Rhs L
_ Maybe (Binds L)
_:[Match L]
_):[Decl L]
ds1) =
[Match L] -> [Decl L] -> L -> P [Decl L]
mergeMatches [Match L]
ms1 [Decl L]
ds1 L
l'
where
arity :: Int
arity = [Pat L] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat L]
ps
mergeMatches :: [Match L] -> [Decl L] -> L -> P [Decl L]
mergeMatches [Match L]
ms' (FunBind L
_ ms :: [Match L]
ms@(Match L
loc Name L
name' [Pat L]
ps' Rhs L
_ Maybe (Binds L)
_:[Match L]
_):[Decl L]
ds) L
l
| Name L
name' Name L -> Name L -> Bool
forall (a :: * -> *) l1 l2.
(Annotated a, Eq (a ())) =>
a l1 -> a l2 -> Bool
=~= Name L
name = do
ignoreArity <- P Bool
getIgnoreFunctionArity
if length ps' == arity || ignoreArity
then mergeMatches (ms++ms') ds (loc <++> l)
else fail ("arity mismatch for '" ++ prettyPrint name ++ "'")
`atSrcLoc` fromSrcInfo loc
mergeMatches [Match L]
ms' [Decl L]
ds L
l = [Decl L] -> [Decl L] -> P [Decl L]
mergeFunBinds (L -> [Match L] -> Decl L
forall l. l -> [Match l] -> Decl l
FunBind L
l [Match L]
ms'Decl L -> [Decl L] -> [Decl L]
forall a. a -> [a] -> [a]
:[Decl L]
revDs) [Decl L]
ds
mergeFunBinds [Decl L]
revDs (FunBind L
l' ims1 :: [Match L]
ims1@(InfixMatch L
_ Pat L
_ Name L
name [Pat L]
_ Rhs L
_ Maybe (Binds L)
_:[Match L]
_):[Decl L]
ds1) =
[Match L] -> [Decl L] -> L -> P [Decl L]
mergeInfix [Match L]
ims1 [Decl L]
ds1 L
l'
where
mergeInfix :: [Match L] -> [Decl L] -> L -> P [Decl L]
mergeInfix [Match L]
ims' (FunBind L
_ ims :: [Match L]
ims@(InfixMatch L
loc Pat L
_ Name L
name' [Pat L]
_ Rhs L
_ Maybe (Binds L)
_:[Match L]
_):[Decl L]
ds) L
l
| Name L
name' Name L -> Name L -> Bool
forall (a :: * -> *) l1 l2.
(Annotated a, Eq (a ())) =>
a l1 -> a l2 -> Bool
=~= Name L
name =
[Match L] -> [Decl L] -> L -> P [Decl L]
mergeInfix ([Match L]
ims[Match L] -> [Match L] -> [Match L]
forall a. [a] -> [a] -> [a]
++[Match L]
ims') [Decl L]
ds (L
loc L -> L -> L
<++> L
l)
mergeInfix [Match L]
ms' [Decl L]
ds L
l = [Decl L] -> [Decl L] -> P [Decl L]
mergeFunBinds (L -> [Match L] -> Decl L
forall l. l -> [Match l] -> Decl l
FunBind L
l [Match L]
ms'Decl L -> [Decl L] -> [Decl L]
forall a. a -> [a] -> [a]
:[Decl L]
revDs) [Decl L]
ds
mergeFunBinds [Decl L]
revDs (Decl L
d:[Decl L]
ds) = [Decl L] -> [Decl L] -> P [Decl L]
mergeFunBinds (Decl L
dDecl L -> [Decl L] -> [Decl L]
forall a. a -> [a] -> [a]
:[Decl L]
revDs) [Decl L]
ds
checkRevClsDecls :: [ClassDecl L] -> P [ClassDecl L]
checkRevClsDecls :: [ClassDecl L] -> P [ClassDecl L]
checkRevClsDecls = [ClassDecl L] -> [ClassDecl L] -> P [ClassDecl L]
mergeClsFunBinds []
where
mergeClsFunBinds :: [ClassDecl L] -> [ClassDecl L] -> P [ClassDecl L]
mergeClsFunBinds [ClassDecl L]
revDs [] = [ClassDecl L] -> P [ClassDecl L]
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return [ClassDecl L]
revDs
mergeClsFunBinds [ClassDecl L]
revDs (ClsDecl L
l' (FunBind L
_ ms1 :: [Match L]
ms1@(Match L
_ Name L
name [Pat L]
ps Rhs L
_ Maybe (Binds L)
_:[Match L]
_)):[ClassDecl L]
ds1) =
[Match L] -> [ClassDecl L] -> L -> P [ClassDecl L]
mergeMatches [Match L]
ms1 [ClassDecl L]
ds1 L
l'
where
arity :: Int
arity = [Pat L] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat L]
ps
mergeMatches :: [Match L] -> [ClassDecl L] -> L -> P [ClassDecl L]
mergeMatches [Match L]
ms' (ClsDecl L
_ (FunBind L
_ ms :: [Match L]
ms@(Match L
loc Name L
name' [Pat L]
ps' Rhs L
_ Maybe (Binds L)
_:[Match L]
_)):[ClassDecl L]
ds) L
l
| Name L
name' Name L -> Name L -> Bool
forall (a :: * -> *) l1 l2.
(Annotated a, Eq (a ())) =>
a l1 -> a l2 -> Bool
=~= Name L
name = do
ignoreArity <- P Bool
getIgnoreFunctionArity
if length ps' == arity || ignoreArity
then mergeMatches (ms++ms') ds (loc <++> l)
else fail ("arity mismatch for '" ++ prettyPrint name ++ "'")
`atSrcLoc` fromSrcInfo loc
mergeMatches [Match L]
ms' [ClassDecl L]
ds L
l = [ClassDecl L] -> [ClassDecl L] -> P [ClassDecl L]
mergeClsFunBinds (L -> Decl L -> ClassDecl L
forall l. l -> Decl l -> ClassDecl l
ClsDecl L
l (L -> [Match L] -> Decl L
forall l. l -> [Match l] -> Decl l
FunBind L
l [Match L]
ms')ClassDecl L -> [ClassDecl L] -> [ClassDecl L]
forall a. a -> [a] -> [a]
:[ClassDecl L]
revDs) [ClassDecl L]
ds
mergeClsFunBinds [ClassDecl L]
revDs (ClsDecl L
l' (FunBind L
_ ims1 :: [Match L]
ims1@(InfixMatch L
_ Pat L
_ Name L
name [Pat L]
_ Rhs L
_ Maybe (Binds L)
_:[Match L]
_)):[ClassDecl L]
ds1) =
[Match L] -> [ClassDecl L] -> L -> P [ClassDecl L]
mergeInfix [Match L]
ims1 [ClassDecl L]
ds1 L
l'
where
mergeInfix :: [Match L] -> [ClassDecl L] -> L -> P [ClassDecl L]
mergeInfix [Match L]
ims' (ClsDecl L
_ (FunBind L
_ ims :: [Match L]
ims@(InfixMatch L
loc Pat L
_ Name L
name' [Pat L]
_ Rhs L
_ Maybe (Binds L)
_:[Match L]
_)):[ClassDecl L]
ds) L
l
| Name L
name' Name L -> Name L -> Bool
forall (a :: * -> *) l1 l2.
(Annotated a, Eq (a ())) =>
a l1 -> a l2 -> Bool
=~= Name L
name =
[Match L] -> [ClassDecl L] -> L -> P [ClassDecl L]
mergeInfix ([Match L]
ims[Match L] -> [Match L] -> [Match L]
forall a. [a] -> [a] -> [a]
++[Match L]
ims') [ClassDecl L]
ds (L
loc L -> L -> L
<++> L
l)
mergeInfix [Match L]
ms' [ClassDecl L]
ds L
l = [ClassDecl L] -> [ClassDecl L] -> P [ClassDecl L]
mergeClsFunBinds (L -> Decl L -> ClassDecl L
forall l. l -> Decl l -> ClassDecl l
ClsDecl L
l (L -> [Match L] -> Decl L
forall l. l -> [Match l] -> Decl l
FunBind L
l [Match L]
ms')ClassDecl L -> [ClassDecl L] -> [ClassDecl L]
forall a. a -> [a] -> [a]
:[ClassDecl L]
revDs) [ClassDecl L]
ds
mergeClsFunBinds [ClassDecl L]
revDs (ClassDecl L
d:[ClassDecl L]
ds) = [ClassDecl L] -> [ClassDecl L] -> P [ClassDecl L]
mergeClsFunBinds (ClassDecl L
dClassDecl L -> [ClassDecl L] -> [ClassDecl L]
forall a. a -> [a] -> [a]
:[ClassDecl L]
revDs) [ClassDecl L]
ds
checkRevInstDecls :: [InstDecl L] -> P [InstDecl L]
checkRevInstDecls :: [InstDecl L] -> P [InstDecl L]
checkRevInstDecls = [InstDecl L] -> [InstDecl L] -> P [InstDecl L]
mergeInstFunBinds []
where
mergeInstFunBinds :: [InstDecl L] -> [InstDecl L] -> P [InstDecl L]
mergeInstFunBinds :: [InstDecl L] -> [InstDecl L] -> P [InstDecl L]
mergeInstFunBinds [InstDecl L]
revDs [] = [InstDecl L] -> P [InstDecl L]
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return [InstDecl L]
revDs
mergeInstFunBinds [InstDecl L]
revDs (InsDecl L
l' (FunBind L
_ ms1 :: [Match L]
ms1@(Match L
_ Name L
name [Pat L]
ps Rhs L
_ Maybe (Binds L)
_:[Match L]
_)):[InstDecl L]
ds1) =
[Match L] -> [InstDecl L] -> L -> P [InstDecl L]
mergeMatches [Match L]
ms1 [InstDecl L]
ds1 L
l'
where
arity :: Int
arity = [Pat L] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat L]
ps
mergeMatches :: [Match L] -> [InstDecl L] -> L -> P [InstDecl L]
mergeMatches [Match L]
ms' (InsDecl L
_ (FunBind L
_ ms :: [Match L]
ms@(Match L
loc Name L
name' [Pat L]
ps' Rhs L
_ Maybe (Binds L)
_:[Match L]
_)):[InstDecl L]
ds) L
l
| Name L
name' Name L -> Name L -> Bool
forall (a :: * -> *) l1 l2.
(Annotated a, Eq (a ())) =>
a l1 -> a l2 -> Bool
=~= Name L
name = do
ignoreArity <- P Bool
getIgnoreFunctionArity
if length ps' == arity || ignoreArity
then mergeMatches (ms++ms') ds (loc <++> l)
else fail ("arity mismatch for '" ++ prettyPrint name ++ "'")
`atSrcLoc` fromSrcInfo loc
mergeMatches [Match L]
ms' [InstDecl L]
ds L
l = [InstDecl L] -> [InstDecl L] -> P [InstDecl L]
mergeInstFunBinds (L -> Decl L -> InstDecl L
forall l. l -> Decl l -> InstDecl l
InsDecl L
l (L -> [Match L] -> Decl L
forall l. l -> [Match l] -> Decl l
FunBind L
l [Match L]
ms')InstDecl L -> [InstDecl L] -> [InstDecl L]
forall a. a -> [a] -> [a]
:[InstDecl L]
revDs) [InstDecl L]
ds
mergeInstFunBinds [InstDecl L]
revDs (InsDecl L
l' (FunBind L
_ ims1 :: [Match L]
ims1@(InfixMatch L
_ Pat L
_ Name L
name [Pat L]
_ Rhs L
_ Maybe (Binds L)
_:[Match L]
_)):[InstDecl L]
ds1) =
[Match L] -> [InstDecl L] -> L -> P [InstDecl L]
mergeInfix [Match L]
ims1 [InstDecl L]
ds1 L
l'
where
mergeInfix :: [Match L] -> [InstDecl L] -> L -> P [InstDecl L]
mergeInfix [Match L]
ims' (InsDecl L
_ (FunBind L
_ ims :: [Match L]
ims@(InfixMatch L
loc Pat L
_ Name L
name' [Pat L]
_ Rhs L
_ Maybe (Binds L)
_:[Match L]
_)):[InstDecl L]
ds) L
l
| Name L
name' Name L -> Name L -> Bool
forall (a :: * -> *) l1 l2.
(Annotated a, Eq (a ())) =>
a l1 -> a l2 -> Bool
=~= Name L
name =
[Match L] -> [InstDecl L] -> L -> P [InstDecl L]
mergeInfix ([Match L]
ims[Match L] -> [Match L] -> [Match L]
forall a. [a] -> [a] -> [a]
++[Match L]
ims') [InstDecl L]
ds (L
loc L -> L -> L
<++> L
l)
mergeInfix [Match L]
ms' [InstDecl L]
ds L
l = [InstDecl L] -> [InstDecl L] -> P [InstDecl L]
mergeInstFunBinds (L -> Decl L -> InstDecl L
forall l. l -> Decl l -> InstDecl l
InsDecl L
l (L -> [Match L] -> Decl L
forall l. l -> [Match l] -> Decl l
FunBind L
l [Match L]
ms')InstDecl L -> [InstDecl L] -> [InstDecl L]
forall a. a -> [a] -> [a]
:[InstDecl L]
revDs) [InstDecl L]
ds
mergeInstFunBinds [InstDecl L]
revDs (InstDecl L
d:[InstDecl L]
ds) = [InstDecl L] -> [InstDecl L] -> P [InstDecl L]
mergeInstFunBinds (InstDecl L
dInstDecl L -> [InstDecl L] -> [InstDecl L]
forall a. a -> [a] -> [a]
:[InstDecl L]
revDs) [InstDecl L]
ds
checkDataOrNew :: DataOrNew L -> [QualConDecl L] -> P ()
checkDataOrNew :: DataOrNew L -> [QualConDecl L] -> P ()
checkDataOrNew (DataType L
_) [QualConDecl L]
_ = () -> P ()
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkDataOrNew (NewType L
_) [QualConDecl L
_ Maybe [TyVarBind L]
_ Maybe (Context L)
_ ConDecl L
x] = ConDecl L -> P ()
forall {m :: * -> *} {l}. MonadFail m => ConDecl l -> m ()
cX ConDecl L
x P () -> P () -> P ()
forall a b. P a -> P b -> P b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> P ()
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where cX :: ConDecl l -> m ()
cX (ConDecl l
_ Name l
_ [Type l
_]) = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
cX (RecDecl l
_ Name l
_ [FieldDecl l
_]) = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
cX ConDecl l
_ = String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"newtype declaration constructor must have exactly one parameter."
checkDataOrNew DataOrNew L
_ [QualConDecl L]
_ = String -> P ()
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"newtype declaration must have exactly one constructor."
checkDataOrNewG :: DataOrNew L -> [GadtDecl L] -> P ()
checkDataOrNewG :: DataOrNew L -> [GadtDecl L] -> P ()
checkDataOrNewG (DataType L
_) [GadtDecl L]
_ = () -> P ()
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkDataOrNewG (NewType L
_) [GadtDecl L
_] = () -> P ()
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkDataOrNewG DataOrNew L
_ [GadtDecl L]
_ = String -> P ()
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"newtype declaration must have exactly one constructor."
checkSimpleType :: PType L -> P (DeclHead L)
checkSimpleType :: PType L -> P (DeclHead L)
checkSimpleType = String -> PType L -> P (DeclHead L)
checkSimple String
"test"
bangType :: Maybe (L -> BangType L, S) -> Maybe (Unpackedness L) -> PType L -> PType L
bangType :: Maybe (L -> BangType L, SrcSpan)
-> Maybe (Unpackedness L) -> PType L -> PType L
bangType Maybe (L -> BangType L, SrcSpan)
mstrict Maybe (Unpackedness L)
munpack PType L
ty =
case (Maybe (L -> BangType L, SrcSpan)
mstrict,Maybe (Unpackedness L)
munpack) of
(Maybe (L -> BangType L, SrcSpan)
Nothing, Just Unpackedness L
upack) -> L -> BangType L -> Unpackedness L -> PType L -> PType L
forall l. l -> BangType l -> Unpackedness l -> PType l -> PType l
TyBang (Unpackedness L -> L
forall l. Unpackedness l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Unpackedness L
upack L -> L -> L
<++> PType L -> L
forall l. PType l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PType L
ty) (L -> BangType L
forall l. l -> BangType l
NoStrictAnnot L
noSrcSpan) Unpackedness L
upack PType L
ty
(Just (L -> BangType L
strict, SrcSpan
pos), Maybe (Unpackedness L)
_) ->
L -> BangType L -> Unpackedness L -> PType L -> PType L
forall l. l -> BangType l -> Unpackedness l -> PType l -> PType l
TyBang ((Unpackedness L -> L) -> Maybe (Unpackedness L) -> Maybe L
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Unpackedness L -> L
forall l. Unpackedness l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Maybe (Unpackedness L)
munpack Maybe L -> L -> L
<?+> SrcSpan -> L
noInfoSpan SrcSpan
pos L -> L -> L
<++> PType L -> L
forall l. PType l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PType L
ty) (L -> BangType L
strict (SrcSpan -> L
noInfoSpan SrcSpan
pos))
(Unpackedness L -> Maybe (Unpackedness L) -> Unpackedness L
forall a. a -> Maybe a -> a
fromMaybe (L -> Unpackedness L
forall l. l -> Unpackedness l
NoUnpackPragma L
noSrcSpan) Maybe (Unpackedness L)
munpack) PType L
ty
(Maybe (L -> BangType L, SrcSpan)
Nothing, Maybe (Unpackedness L)
Nothing) -> PType L
ty
checkType :: PType L -> P (S.Type L)
checkType :: PType L -> P (Type L)
checkType PType L
t = PType L -> Bool -> P (Type L)
checkT PType L
t Bool
False
checkT :: PType L -> Bool -> P (S.Type L)
checkT :: PType L -> Bool -> P (Type L)
checkT PType L
t Bool
simple = case PType L
t of
TyForall L
l Maybe [TyVarBind L]
Nothing Maybe (PContext L)
cs PType L
pt -> do
Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
simple (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$ KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
ExplicitForAll
ctxt <- Maybe (PContext L) -> P (Maybe (Context L))
checkContext Maybe (PContext L)
cs
check1Type pt (S.TyForall l Nothing ctxt)
TyForall L
l Maybe [TyVarBind L]
tvs Maybe (PContext L)
cs PType L
pt -> do
KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
ExplicitForAll
ctxt <- Maybe (PContext L) -> P (Maybe (Context L))
checkContext Maybe (PContext L)
cs
check1Type pt (S.TyForall l tvs ctxt)
TyStar L
l -> Type L -> P (Type L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type L -> P (Type L)) -> Type L -> P (Type L)
forall a b. (a -> b) -> a -> b
$ L -> Type L
forall l. l -> Type l
S.TyStar L
l
TyFun L
l PType L
at PType L
rt -> PType L -> PType L -> (Type L -> Type L -> Type L) -> P (Type L)
check2Types PType L
at PType L
rt (L -> Type L -> Type L -> Type L
forall l. l -> Type l -> Type l -> Type l
S.TyFun L
l)
TyTuple L
l Boxed
b [PType L]
pts -> [PType L] -> P [Type L]
checkTypes [PType L]
pts P [Type L] -> ([Type L] -> P (Type L)) -> P (Type L)
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type L -> P (Type L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type L -> P (Type L))
-> ([Type L] -> Type L) -> [Type L] -> P (Type L)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> Boxed -> [Type L] -> Type L
forall l. l -> Boxed -> [Type l] -> Type l
S.TyTuple L
l Boxed
b
TyUnboxedSum L
l [PType L]
es -> [PType L] -> P [Type L]
checkTypes [PType L]
es P [Type L] -> ([Type L] -> P (Type L)) -> P (Type L)
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type L -> P (Type L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type L -> P (Type L))
-> ([Type L] -> Type L) -> [Type L] -> P (Type L)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> [Type L] -> Type L
forall l. l -> [Type l] -> Type l
S.TyUnboxedSum L
l
TyList L
l PType L
pt -> PType L -> (Type L -> Type L) -> P (Type L)
check1Type PType L
pt (L -> Type L -> Type L
forall l. l -> Type l -> Type l
S.TyList L
l)
TyParArray L
l PType L
pt -> PType L -> (Type L -> Type L) -> P (Type L)
check1Type PType L
pt (L -> Type L -> Type L
forall l. l -> Type l -> Type l
S.TyParArray L
l)
TyApp L
l PType L
ft PType L
at -> PType L -> PType L -> (Type L -> Type L -> Type L) -> P (Type L)
check2Types PType L
ft PType L
at (L -> Type L -> Type L -> Type L
forall l. l -> Type l -> Type l -> Type l
S.TyApp L
l)
TyVar L
l Name L
n -> Type L -> P (Type L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type L -> P (Type L)) -> Type L -> P (Type L)
forall a b. (a -> b) -> a -> b
$ L -> Name L -> Type L
forall l. l -> Name l -> Type l
S.TyVar L
l Name L
n
TyCon L
l QName L
n -> do
QName L -> P ()
checkAndWarnTypeOperators QName L
n
Type L -> P (Type L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type L -> P (Type L)) -> Type L -> P (Type L)
forall a b. (a -> b) -> a -> b
$ L -> QName L -> Type L
forall l. l -> QName l -> Type l
S.TyCon L
l QName L
n
TyParen L
l PType L
pt -> PType L -> (Type L -> Type L) -> P (Type L)
check1Type PType L
pt (L -> Type L -> Type L
forall l. l -> Type l -> Type l
S.TyParen L
l)
TyInfix L
l PType L
at MaybePromotedName L
op PType L
bt -> QName L -> P ()
checkAndWarnTypeOperators (MaybePromotedName L -> QName L
forall l. MaybePromotedName l -> QName l
getMaybePromotedQName MaybePromotedName L
op)
P () -> P (Type L) -> P (Type L)
forall a b. P a -> P b -> P b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PType L -> PType L -> (Type L -> Type L -> Type L) -> P (Type L)
check2Types PType L
at PType L
bt ((Type L -> MaybePromotedName L -> Type L -> Type L)
-> MaybePromotedName L -> Type L -> Type L -> Type L
forall a b c. (a -> b -> c) -> b -> a -> c
flip (L -> Type L -> MaybePromotedName L -> Type L -> Type L
forall l. l -> Type l -> MaybePromotedName l -> Type l -> Type l
S.TyInfix L
l) MaybePromotedName L
op)
TyKind L
l PType L
pt Type L
k -> PType L -> (Type L -> Type L) -> P (Type L)
check1Type PType L
pt ((Type L -> Type L -> Type L) -> Type L -> Type L -> Type L
forall a b c. (a -> b -> c) -> b -> a -> c
flip (L -> Type L -> Type L -> Type L
forall l. l -> Type l -> Type l -> Type l
S.TyKind L
l) Type L
k)
TyPromoted L
l Promoted L
p -> Type L -> P (Type L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type L -> P (Type L)) -> Type L -> P (Type L)
forall a b. (a -> b) -> a -> b
$ L -> Promoted L -> Type L
forall l. l -> Promoted l -> Type l
S.TyPromoted L
l Promoted L
p
TyEquals L
l PType L
at PType L
bt -> PType L -> PType L -> (Type L -> Type L -> Type L) -> P (Type L)
check2Types PType L
at PType L
bt (L -> Type L -> Type L -> Type L
forall l. l -> Type l -> Type l -> Type l
S.TyEquals L
l)
TySplice L
l Splice L
s -> do
KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
TemplateHaskell
Type L -> P (Type L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type L -> P (Type L)) -> Type L -> P (Type L)
forall a b. (a -> b) -> a -> b
$ L -> Splice L -> Type L
forall l. l -> Splice l -> Type l
S.TySplice L
l Splice L
s
TyBang L
l BangType L
b Unpackedness L
u PType L
t' -> PType L -> (Type L -> Type L) -> P (Type L)
check1Type PType L
t' (L -> BangType L -> Unpackedness L -> Type L -> Type L
forall l. l -> BangType l -> Unpackedness l -> Type l -> Type l
S.TyBang L
l BangType L
b Unpackedness L
u)
TyWildCard L
l Maybe (Name L)
mn -> Type L -> P (Type L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type L -> P (Type L)) -> Type L -> P (Type L)
forall a b. (a -> b) -> a -> b
$ L -> Maybe (Name L) -> Type L
forall l. l -> Maybe (Name l) -> Type l
S.TyWildCard L
l Maybe (Name L)
mn
TyQuasiQuote L
l String
n String
s -> do
KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
QuasiQuotes
Type L -> P (Type L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type L -> P (Type L)) -> Type L -> P (Type L)
forall a b. (a -> b) -> a -> b
$ L -> String -> String -> Type L
forall l. l -> String -> String -> Type l
S.TyQuasiQuote L
l String
n String
s
PType L
_ -> String -> P (Type L)
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> P (Type L)) -> String -> P (Type L)
forall a b. (a -> b) -> a -> b
$ String
"Parse error in type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PType L -> String
forall a. Pretty a => a -> String
prettyPrint PType L
t
getMaybePromotedQName :: MaybePromotedName l -> QName l
getMaybePromotedQName :: forall l. MaybePromotedName l -> QName l
getMaybePromotedQName (PromotedName l
_ QName l
q) = QName l
q
getMaybePromotedQName (UnpromotedName l
_ QName l
q) = QName l
q
check1Type :: PType L -> (S.Type L -> S.Type L) -> P (S.Type L)
check1Type :: PType L -> (Type L -> Type L) -> P (Type L)
check1Type PType L
pt Type L -> Type L
f = PType L -> Bool -> P (Type L)
checkT PType L
pt Bool
True P (Type L) -> (Type L -> P (Type L)) -> P (Type L)
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type L -> P (Type L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type L -> P (Type L))
-> (Type L -> Type L) -> Type L -> P (Type L)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type L -> Type L
f
check2Types :: PType L -> PType L -> (S.Type L -> S.Type L -> S.Type L) -> P (S.Type L)
check2Types :: PType L -> PType L -> (Type L -> Type L -> Type L) -> P (Type L)
check2Types PType L
at PType L
bt Type L -> Type L -> Type L
f = PType L -> Bool -> P (Type L)
checkT PType L
at Bool
True P (Type L) -> (Type L -> P (Type L)) -> P (Type L)
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type L
a -> PType L -> Bool -> P (Type L)
checkT PType L
bt Bool
True P (Type L) -> (Type L -> P (Type L)) -> P (Type L)
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type L
b -> Type L -> P (Type L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type L -> Type L -> Type L
f Type L
a Type L
b)
checkTypes :: [PType L] -> P [S.Type L]
checkTypes :: [PType L] -> P [Type L]
checkTypes = (PType L -> P (Type L)) -> [PType L] -> P [Type L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((PType L -> Bool -> P (Type L)) -> Bool -> PType L -> P (Type L)
forall a b c. (a -> b -> c) -> b -> a -> c
flip PType L -> Bool -> P (Type L)
checkT Bool
True)
checkTyVar :: Name L -> P (PType L)
checkTyVar :: Name L -> P (PType L)
checkTyVar Name L
n = do
e <- P [KnownExtension]
getExtensions
return $
case n of
Ident L
il (Char
'_':String
ident) | KnownExtension
NamedWildCards KnownExtension -> [KnownExtension] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
e ->
L -> Maybe (Name L) -> PType L
forall l. l -> Maybe (Name l) -> PType l
TyWildCard L
il (Name L -> Maybe (Name L)
forall a. a -> Maybe a
Just (L -> String -> Name L
forall l. l -> String -> Name l
Ident (L -> L
reduceSrcSpanInfo L
il) String
ident))
Name L
_ ->
L -> Name L -> PType L
forall l. l -> Name l -> PType l
TyVar (Name L -> L
forall l. Name l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Name L
n) Name L
n
where
reduceSrcSpanInfo :: L -> L
reduceSrcSpanInfo L
spaninfo =
let ss :: SrcSpan
ss = L -> SrcSpan
srcInfoSpan L
spaninfo
ss' :: SrcSpan
ss' = SrcSpan
ss { srcSpanStartColumn = srcSpanStartColumn ss + 1 }
in L
spaninfo { srcInfoSpan = ss' }
checkKind :: Kind l -> P ()
checkKind :: forall l. Kind l -> P ()
checkKind Kind l
k = case Kind l
k of
S.TyVar l
_ Name l
q | Name l -> Bool
forall {l}. Name l -> Bool
constrKind Name l
q -> [KnownExtension] -> P ()
forall e. (Show e, Enabled e) => [e] -> P ()
checkEnabledOneOf [KnownExtension
ConstraintKinds, KnownExtension
DataKinds]
where constrKind :: Name l -> Bool
constrKind Name l
name = case Name l
name of
Ident l
_ String
n -> String
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Constraint"
Name l
_ -> Bool
False
Kind l
_ -> KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
DataKinds
checkPageModule :: PExp L -> ([ModulePragma L],[S],L) -> P (Module L)
checkPageModule :: PExp L -> ([ModulePragma L], [SrcSpan], L) -> P (Module L)
checkPageModule PExp L
xml ([ModulePragma L]
os,[SrcSpan]
ss,L
inf) = do
mod <- P String
getModuleName
xml' <- checkExpr xml
case xml' of
S.XTag L
l XName L
xn [XAttr L]
ats Maybe (Exp L)
mattr [Exp L]
cs -> Module L -> P (Module L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Module L -> P (Module L)) -> Module L -> P (Module L)
forall a b. (a -> b) -> a -> b
$ L
-> ModuleName L
-> [ModulePragma L]
-> XName L
-> [XAttr L]
-> Maybe (Exp L)
-> [Exp L]
-> Module L
forall l.
l
-> ModuleName l
-> [ModulePragma l]
-> XName l
-> [XAttr l]
-> Maybe (Exp l)
-> [Exp l]
-> Module l
XmlPage (L
infL -> L -> L
<++>L
lL -> [SrcSpan] -> L
<**(L -> [SrcSpan]
srcInfoPoints L
l [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
++ [SrcSpan]
ss)) (L -> String -> ModuleName L
forall l. l -> String -> ModuleName l
ModuleName L
l String
mod) [ModulePragma L]
os XName L
xn [XAttr L]
ats Maybe (Exp L)
mattr [Exp L]
cs
S.XETag L
l XName L
xn [XAttr L]
ats Maybe (Exp L)
mattr -> Module L -> P (Module L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Module L -> P (Module L)) -> Module L -> P (Module L)
forall a b. (a -> b) -> a -> b
$ L
-> ModuleName L
-> [ModulePragma L]
-> XName L
-> [XAttr L]
-> Maybe (Exp L)
-> [Exp L]
-> Module L
forall l.
l
-> ModuleName l
-> [ModulePragma l]
-> XName l
-> [XAttr l]
-> Maybe (Exp l)
-> [Exp l]
-> Module l
XmlPage (L
infL -> L -> L
<++>L
lL -> [SrcSpan] -> L
<**(L -> [SrcSpan]
srcInfoPoints L
l [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
++ [SrcSpan]
ss)) (L -> String -> ModuleName L
forall l. l -> String -> ModuleName l
ModuleName L
l String
mod) [ModulePragma L]
os XName L
xn [XAttr L]
ats Maybe (Exp L)
mattr []
Exp L
_ -> String -> P (Module L)
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unexpected expression; tag is expected"
checkHybridModule :: PExp L -> Module L -> S -> S -> P (Module L)
checkHybridModule :: PExp L -> Module L -> SrcSpan -> SrcSpan -> P (Module L)
checkHybridModule PExp L
xml (Module L
inf Maybe (ModuleHead L)
mh [ModulePragma L]
os [ImportDecl L]
is [Decl L]
ds) SrcSpan
s1 SrcSpan
s2 = do
xml' <- PExp L -> P (Exp L)
checkExpr PExp L
xml
case xml' of
S.XTag L
l XName L
xn [XAttr L]
ats Maybe (Exp L)
mattr [Exp L]
cs -> Module L -> P (Module L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Module L -> P (Module L)) -> Module L -> P (Module L)
forall a b. (a -> b) -> a -> b
$ L
-> Maybe (ModuleHead L)
-> [ModulePragma L]
-> [ImportDecl L]
-> [Decl L]
-> XName L
-> [XAttr L]
-> Maybe (Exp L)
-> [Exp L]
-> Module L
forall l.
l
-> Maybe (ModuleHead l)
-> [ModulePragma l]
-> [ImportDecl l]
-> [Decl l]
-> XName l
-> [XAttr l]
-> Maybe (Exp l)
-> [Exp l]
-> Module l
XmlHybrid (L
infL -> L -> L
<++>L
lL -> [SrcSpan] -> L
<**(SrcSpan
s1 SrcSpan -> [SrcSpan] -> [SrcSpan]
forall a. a -> [a] -> [a]
: L -> [SrcSpan]
srcInfoPoints L
inf [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
++ SrcSpan
s2 SrcSpan -> [SrcSpan] -> [SrcSpan]
forall a. a -> [a] -> [a]
: L -> [SrcSpan]
srcInfoPoints L
l))
Maybe (ModuleHead L)
mh [ModulePragma L]
os [ImportDecl L]
is [Decl L]
ds XName L
xn [XAttr L]
ats Maybe (Exp L)
mattr [Exp L]
cs
S.XETag L
l XName L
xn [XAttr L]
ats Maybe (Exp L)
mattr -> Module L -> P (Module L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Module L -> P (Module L)) -> Module L -> P (Module L)
forall a b. (a -> b) -> a -> b
$ L
-> Maybe (ModuleHead L)
-> [ModulePragma L]
-> [ImportDecl L]
-> [Decl L]
-> XName L
-> [XAttr L]
-> Maybe (Exp L)
-> [Exp L]
-> Module L
forall l.
l
-> Maybe (ModuleHead l)
-> [ModulePragma l]
-> [ImportDecl l]
-> [Decl l]
-> XName l
-> [XAttr l]
-> Maybe (Exp l)
-> [Exp l]
-> Module l
XmlHybrid (L
infL -> L -> L
<++>L
lL -> [SrcSpan] -> L
<**(SrcSpan
s1 SrcSpan -> [SrcSpan] -> [SrcSpan]
forall a. a -> [a] -> [a]
: L -> [SrcSpan]
srcInfoPoints L
inf [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
++ SrcSpan
s2 SrcSpan -> [SrcSpan] -> [SrcSpan]
forall a. a -> [a] -> [a]
: L -> [SrcSpan]
srcInfoPoints L
l))
Maybe (ModuleHead L)
mh [ModulePragma L]
os [ImportDecl L]
is [Decl L]
ds XName L
xn [XAttr L]
ats Maybe (Exp L)
mattr []
Exp L
_ -> String -> P (Module L)
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unexpected expression; tag is expected"
checkHybridModule PExp L
_ Module L
_ SrcSpan
_ SrcSpan
_ = String -> P (Module L)
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Hybrid module expected"
mkDVar :: [String] -> String
mkDVar :: [String] -> String
mkDVar = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"-"
mkTyForall :: L -> Maybe [TyVarBind L] -> Maybe (PContext L) -> PType L -> PType L
mkTyForall :: L
-> Maybe [TyVarBind L] -> Maybe (PContext L) -> PType L -> PType L
mkTyForall L
l Maybe [TyVarBind L]
mtvs Maybe (PContext L)
ctxt PType L
ty =
case (Maybe (PContext L)
ctxt, PType L
ty) of
(Maybe (PContext L)
Nothing, TyForall L
_ Maybe [TyVarBind L]
Nothing Maybe (PContext L)
ctxt2 PType L
ty2) -> L
-> Maybe [TyVarBind L] -> Maybe (PContext L) -> PType L -> PType L
forall l.
l
-> Maybe [TyVarBind l] -> Maybe (PContext l) -> PType l -> PType l
TyForall L
l Maybe [TyVarBind L]
mtvs Maybe (PContext L)
ctxt2 PType L
ty2
(Maybe (PContext L), PType L)
_ -> L
-> Maybe [TyVarBind L] -> Maybe (PContext L) -> PType L -> PType L
forall l.
l
-> Maybe [TyVarBind l] -> Maybe (PContext l) -> PType l -> PType l
TyForall L
l Maybe [TyVarBind L]
mtvs Maybe (PContext L)
ctxt PType L
ty
mkRoleAnnotDecl :: S -> S -> QName L -> [(Maybe String, L)] -> P (Decl L)
mkRoleAnnotDecl :: SrcSpan -> SrcSpan -> QName L -> [(Maybe String, L)] -> P (Decl L)
mkRoleAnnotDecl SrcSpan
l1 SrcSpan
l2 QName L
tycon [(Maybe String, L)]
roles
= do roles' <- ((Maybe String, L) -> P (Role L))
-> [(Maybe String, L)] -> P [Role L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Maybe String, L) -> P (Role L)
forall {m :: * -> *} {l}.
MonadFail m =>
(Maybe String, l) -> m (Role l)
parse_role [(Maybe String, L)]
roles
return (RoleAnnotDecl loc' tycon roles')
where
loc' :: L
loc' =
case [(Maybe String, L)]
roles of
[] -> (SrcSpan
l1 SrcSpan -> SrcSpan -> L
<^^> SrcSpan
l2 L -> L -> L
<++> QName L -> L
forall l. QName l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann QName L
tycon) L -> [SrcSpan] -> L
<** [SrcSpan
l1, SrcSpan
l2]
[(Maybe String, L)]
_ -> (SrcSpan
l1 SrcSpan -> SrcSpan -> L
<^^> SrcSpan
l2 L -> L -> L
<++> QName L -> L
forall l. QName l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann QName L
tycon L -> L -> L
<++> (L -> L -> L) -> [L] -> L
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 L -> L -> L
(<++>) (((Maybe String, L) -> L) -> [(Maybe String, L)] -> [L]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe String, L) -> L
forall a b. (a, b) -> b
snd [(Maybe String, L)]
roles)) L -> [SrcSpan] -> L
<** [SrcSpan
l1, SrcSpan
l2]
possible_roles :: [(String, l -> Role l)]
possible_roles = [ (String
"phantom", l -> Role l
forall l. l -> Role l
S.Phantom)
, (String
"representational", l -> Role l
forall l. l -> Role l
S.Representational)
, (String
"nominal", l -> Role l
forall l. l -> Role l
S.Nominal)]
parse_role :: (Maybe String, l) -> m (Role l)
parse_role (Maybe String
Nothing, l
loc_role) = Role l -> m (Role l)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Role l -> m (Role l)) -> Role l -> m (Role l)
forall a b. (a -> b) -> a -> b
$ l -> Role l
forall l. l -> Role l
S.RoleWildcard l
loc_role
parse_role (Just String
role, l
loc_role)
= case String -> [(String, l -> Role l)] -> Maybe (l -> Role l)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
role [(String, l -> Role l)]
forall {l}. [(String, l -> Role l)]
possible_roles of
Just l -> Role l
found_role -> Role l -> m (Role l)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Role l -> m (Role l)) -> Role l -> m (Role l)
forall a b. (a -> b) -> a -> b
$ l -> Role l
found_role l
loc_role
Maybe (l -> Role l)
Nothing ->
String -> m (Role l)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Illegal role name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
role)
mkAssocType :: S -> PType L -> (Maybe (ResultSig L), Maybe (S, S.Type L), Maybe (InjectivityInfo L)) -> P (ClassDecl L)
mkAssocType :: SrcSpan
-> PType L
-> (Maybe (ResultSig L), Maybe (SrcSpan, Type L),
Maybe (InjectivityInfo L))
-> P (ClassDecl L)
mkAssocType SrcSpan
tyloc PType L
ty (Maybe (ResultSig L)
mres, Maybe (SrcSpan, Type L)
mty, Maybe (InjectivityInfo L)
minj) =
case (Maybe (ResultSig L)
mres,Maybe (SrcSpan, Type L)
mty, Maybe (InjectivityInfo L)
minj) of
(Maybe (ResultSig L)
Nothing, Maybe (SrcSpan, Type L)
Nothing, Maybe (InjectivityInfo L)
Nothing) -> do
dh <- PType L -> P (DeclHead L)
checkSimpleType PType L
ty
return $ ClsTyFam (noInfoSpan tyloc <++> ann ty) dh Nothing Nothing
(Maybe (ResultSig L)
_, Just (SrcSpan
eqloc, Type L
rhsty), Maybe (InjectivityInfo L)
Nothing) -> do
ty' <- PType L -> P (Type L)
checkType PType L
ty
let tyeq = L -> Type L -> Type L -> TypeEqn L
forall l. l -> Type l -> Type l -> TypeEqn l
TypeEqn (PType L -> L
forall l. PType l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PType L
ty L -> L -> L
<++> Type L -> L
forall l. Type l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Type L
rhsty L -> [SrcSpan] -> L
<** [SrcSpan
eqloc]) Type L
ty' Type L
rhsty
return $ ClsTyDef (noInfoSpan tyloc <++> ann ty <** [tyloc]) tyeq
(Just ResultSig L
ressig, Maybe (SrcSpan, Type L)
_, Maybe (InjectivityInfo L)
_) -> do
dh <- PType L -> P (DeclHead L)
checkSimpleType PType L
ty
return $ ClsTyFam (noInfoSpan tyloc <++> ann ressig <** [tyloc]) dh (Just ressig) Nothing
(Maybe (ResultSig L)
Nothing, Just (SrcSpan
eqloc, Type L
rhsty), Just InjectivityInfo L
injinfo) -> do
ressig <- SrcSpan -> Type L -> P (ResultSig L)
checkKTyVar SrcSpan
eqloc Type L
rhsty
dh <- checkSimpleType ty
return $ ClsTyFam (noInfoSpan tyloc <++> ann injinfo <** [tyloc]) dh (Just ressig) minj
(Maybe (ResultSig L), Maybe (SrcSpan, Type L),
Maybe (InjectivityInfo L))
_ -> String -> P (ClassDecl L)
forall a. HasCallStack => String -> a
error String
"mkAssocType"
where
checkKTyVar :: S -> S.Type L -> P (ResultSig L)
checkKTyVar :: SrcSpan -> Type L -> P (ResultSig L)
checkKTyVar SrcSpan
eqloc Type L
rhsty =
case Type L
rhsty of
S.TyVar L
l Name L
n -> ResultSig L -> P (ResultSig L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (ResultSig L -> P (ResultSig L)) -> ResultSig L -> P (ResultSig L)
forall a b. (a -> b) -> a -> b
$ L -> TyVarBind L -> ResultSig L
forall l. l -> TyVarBind l -> ResultSig l
TyVarSig (SrcSpan -> L
noInfoSpan SrcSpan
eqloc L -> L -> L
<++> L
l L -> [SrcSpan] -> L
<** [SrcSpan
eqloc]) (L -> Name L -> TyVarBind L
forall l. l -> Name l -> TyVarBind l
UnkindedVar L
l Name L
n)
S.TyKind L
l (S.TyVar L
_ Name L
n) Type L
k -> ResultSig L -> P (ResultSig L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (ResultSig L -> P (ResultSig L)) -> ResultSig L -> P (ResultSig L)
forall a b. (a -> b) -> a -> b
$ L -> TyVarBind L -> ResultSig L
forall l. l -> TyVarBind l -> ResultSig l
TyVarSig (SrcSpan -> L
noInfoSpan SrcSpan
eqloc L -> L -> L
<++> L
l L -> [SrcSpan] -> L
<** [SrcSpan
eqloc]) (L -> Name L -> Type L -> TyVarBind L
forall l. l -> Name l -> Kind l -> TyVarBind l
KindedVar L
l Name L
n Type L
k)
Type L
_ -> String -> P (ResultSig L)
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Result of type family must be a type variable")
splitTilde :: PType L -> PType L
splitTilde :: PType L -> PType L
splitTilde PType L
t = PType L -> PType L
go PType L
t
where go :: PType L -> PType L
go (TyApp L
loc PType L
t1 PType L
t2)
| TyBang L
_ (LazyTy L
eqloc) (NoUnpackPragma L
_) PType L
t2' <- PType L
t2
= L -> PType L -> PType L -> PType L
forall l. l -> PType l -> PType l -> PType l
TyEquals (L
loc L -> [SrcSpan] -> L
<** [L -> SrcSpan
srcInfoSpan L
eqloc]) (PType L -> PType L
go PType L
t1) PType L
t2'
| Bool
otherwise
= case PType L -> PType L
go PType L
t1 of
TyEquals L
eqloc PType L
tl PType L
tr ->
L -> PType L -> PType L -> PType L
forall l. l -> PType l -> PType l -> PType l
TyEquals (L
eqloc L -> L -> L
<++> PType L -> L
forall l. PType l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PType L
t2 L -> [SrcSpan] -> L
<** L -> [SrcSpan]
srcInfoPoints L
eqloc) PType L
tl (L -> PType L -> PType L -> PType L
forall l. l -> PType l -> PType l -> PType l
TyApp (PType L -> L
forall l. PType l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PType L
tr L -> L -> L
<++> PType L -> L
forall l. PType l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PType L
t2) PType L
tr PType L
t2)
PType L
t' -> L -> PType L -> PType L -> PType L
forall l. l -> PType l -> PType l -> PType l
TyApp L
loc PType L
t' PType L
t2
go PType L
t' = PType L
t'
mkEThingWith :: L -> QName L -> [Either S (CName L)] -> P (ExportSpec L)
mkEThingWith :: L -> QName L -> [Either SrcSpan (CName L)] -> P (ExportSpec L)
mkEThingWith L
loc QName L
qn [Either SrcSpan (CName L)]
mcns = do
Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EWildcard L -> Bool
forall {l}. EWildcard l -> Bool
isWc EWildcard L
wc Bool -> Bool -> Bool
&& Bool -> Bool
not ([CName L] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CName L]
cnames)) (KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
PatternSynonyms)
ExportSpec L -> P (ExportSpec L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExportSpec L -> P (ExportSpec L))
-> ExportSpec L -> P (ExportSpec L)
forall a b. (a -> b) -> a -> b
$ L -> EWildcard L -> QName L -> [CName L] -> ExportSpec L
forall l. l -> EWildcard l -> QName l -> [CName l] -> ExportSpec l
EThingWith L
loc EWildcard L
wc QName L
qn [CName L]
cnames
where
isWc :: EWildcard l -> Bool
isWc (NoWildcard {}) = Bool
False
isWc EWildcard l
_ = Bool
True
wc :: EWildcard L
wc :: EWildcard L
wc = EWildcard L
-> ((Int, Either SrcSpan (CName L)) -> EWildcard L)
-> Maybe (Int, Either SrcSpan (CName L))
-> EWildcard L
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (L -> EWildcard L
forall l. l -> EWildcard l
NoWildcard L
noSrcSpan)
(\(Int
n,Left SrcSpan
s) -> L -> Int -> EWildcard L
forall l. l -> Int -> EWildcard l
EWildcard (SrcSpan -> L
noInfoSpan SrcSpan
s) Int
n)
(Int
-> (Either SrcSpan (CName L) -> Bool)
-> [Either SrcSpan (CName L)]
-> Maybe (Int, Either SrcSpan (CName L))
forall a. Int -> (a -> Bool) -> [a] -> Maybe (Int, a)
findWithIndex Int
0 Either SrcSpan (CName L) -> Bool
forall a b. Either a b -> Bool
checkLeft [Either SrcSpan (CName L)]
mcns)
checkLeft :: Either a b -> Bool
checkLeft :: forall a b. Either a b -> Bool
checkLeft (Left a
_) = Bool
True
checkLeft Either a b
_ = Bool
False
cnames :: [CName L]
cnames = [Either SrcSpan (CName L)] -> [CName L]
forall a b. [Either a b] -> [b]
rights [Either SrcSpan (CName L)]
mcns
findWithIndex :: Int -> (a -> Bool) -> [a] -> Maybe (Int, a)
findWithIndex :: forall a. Int -> (a -> Bool) -> [a] -> Maybe (Int, a)
findWithIndex Int
_ a -> Bool
_ [] = Maybe (Int, a)
forall a. Maybe a
Nothing
findWithIndex Int
n a -> Bool
p (a
x:[a]
xs)
| a -> Bool
p a
x = (Int, a) -> Maybe (Int, a)
forall a. a -> Maybe a
Just (Int
n, a
x)
| Bool
otherwise = Int -> (a -> Bool) -> [a] -> Maybe (Int, a)
forall a. Int -> (a -> Bool) -> [a] -> Maybe (Int, a)
findWithIndex (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) a -> Bool
p [a]
xs
data SumOrTuple l = SSum Int Int (PExp l)
| STuple [Maybe (PExp l)]
mkSumOrTuple :: Boxed -> L -> SumOrTuple L -> P (PExp L)
mkSumOrTuple :: Boxed -> L -> SumOrTuple L -> P (PExp L)
mkSumOrTuple Boxed
Unboxed L
s (SSum Int
before Int
after PExp L
e) = PExp L -> P (PExp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Int -> Int -> PExp L -> PExp L
forall l. l -> Int -> Int -> PExp l -> PExp l
UnboxedSum L
s Int
before Int
after PExp L
e)
mkSumOrTuple Boxed
boxity L
s (STuple [Maybe (PExp L)]
ms) =
PExp L -> P (PExp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (PExp L -> P (PExp L)) -> PExp L -> P (PExp L)
forall a b. (a -> b) -> a -> b
$ L -> Boxed -> [Maybe (PExp L)] -> PExp L
forall l. l -> Boxed -> [Maybe (PExp l)] -> PExp l
TupleSection L
s Boxed
boxity [Maybe (PExp L)]
ms
mkSumOrTuple Boxed
Boxed L
_s (SSum {}) = String -> P (PExp L)
forall a. String -> P a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Boxed sums are not implemented"