{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Language.Haskell.Exts.ParseUtils
-- Copyright   :  (c) Niklas Broberg 2004-2009,
--                (c) The GHC Team, 1997-2000
-- License     :  BSD-style (see the file LICENSE.txt)
--
-- Maintainer  :  Niklas Broberg, d00nibro@chalmers.se
-- Stability   :  stable
-- Portability :  portable
--
-- Utilities for the Haskell-exts parser.
--
-----------------------------------------------------------------------------

module Language.Haskell.Exts.ParseUtils (
      splitTyConApp         -- PType -> P (Name,[Type])
    , checkEnabled          -- (Show e, Enabled e) => e -> P ()
    , checkEnabledOneOf
    , checkToplevel         -- ??
    , checkPatternGuards    -- [Stmt] -> P ()
    , mkRecConstrOrUpdate   -- PExp -> [PFieldUpdate] -> P Exp
    , checkPrec             -- Integer -> P Int
    , checkPContext         -- PType -> P PContext
    , checkContext          -- PContext -> P Context
    , checkAssertion        -- PType -> P PAsst
    , checkDataHeader       -- PType -> P (Context,Name,[TyVarBind])
    , checkClassHeader      -- PType -> P (Context,Name,[TyVarBind])
    , checkInstHeader       -- PType -> P (Context,QName,[Type])
    , checkDeriving         -- [PType] -> P [Deriving]
    , checkPattern          -- PExp -> P Pat
    , checkExpr             -- PExp -> P Exp
    , checkType             -- PType -> P Type
    , checkTyVar            -- Name  -> P PType
    , bangType              -- L -> BangType -> Type -> Type
    , checkKind             -- Kind -> P ()
    , checkValDef           -- SrcLoc -> PExp -> Maybe Type -> Rhs -> Binds -> P Decl
    , checkExplicitPatSyn   --
    , checkClassBody        -- [ClassDecl] -> P [ClassDecl]
    , checkInstBody         -- [InstDecl] -> P [InstDecl]
    , checkUnQual           -- QName -> P Name
    , checkQualOrUnQual     -- QName -> P QName
    , checkSingleDecl       -- [Decl] -> P Decl
    , checkRevDecls         -- [Decl] -> P [Decl]
    , checkRevClsDecls      -- [ClassDecl] -> P [ClassDecl]
    , checkRevInstDecls     -- [InstDecl] -> P [InstDecl]
    , checkDataOrNew        -- DataOrNew -> [QualConDecl] -> P ()
    , checkDataOrNewG       -- DataOrNew -> [GadtDecl] -> P ()
    , checkSimpleType       -- PType -> P (Name, [TyVarBind])
    , checkSigVar           -- PExp -> P Name
    , checkDefSigDef        -- Decl -> P Decl
    , getGConName           -- S.Exp -> P QName
    , mkTyForall            -- Maybe [TyVarBind] -> PContext -> PType -> PType
    , mkRoleAnnotDecl       --
    , mkAssocType
    , mkEThingWith
    , splitTilde
    -- HaRP
    , checkRPattern         -- PExp -> P RPat
    -- Hsx
    , checkEqNames          -- XName -> XName -> P XName
    , checkPageModule
    , checkHybridModule
    , mkDVar                -- [String] -> String
    -- Pragmas
    , checkRuleExpr         -- PExp -> P Exp
    , readTool              -- Maybe String -> Maybe Tool
    -- Helpers
    , updateQNameLoc        -- l -> QName l -> QName l

    , SumOrTuple(..), mkSumOrTuple

    -- Parsed expressions and types
    , PExp(..), PFieldUpdate(..), ParseXAttr(..), PType(..), PContext, PAsst(..)
    , p_unit_con            -- PExp
    , p_tuple_con           -- Boxed -> Int -> PExp
    , p_unboxed_singleton_con   -- PExp
    , 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) = forall (m :: * -> *) a. Monad m => a -> m a
return QName l
qn
pexprToQName (List l
l []) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> SpecialCon l -> QName l
Special l
l (forall l. l -> SpecialCon l
ListCon l
l)
pexprToQName PExp l
_ = 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
            (Name L
n, [PType L]
pts) <- PType L -> [PType L] -> P (Name L, [PType L])
split PType L
t0 []
            [Type L]
ts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PType L -> P (Type L)
checkType [PType L]
pts
            forall (m :: * -> *) a. Monad m => a -> m a
return (Name L
n,[Type L]
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
uforall a. a -> [a] -> [a]
:[PType L]
ts)
    split (TyCon L
_ (UnQual L
_ Name L
t)) [PType L]
ts = 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 (forall l. l -> QName l -> PType l
TyCon L
l (forall l. MaybePromotedName l -> QName l
getMaybePromotedQName MaybePromotedName L
op)) (PType L
aforall a. a -> [a] -> [a]
:PType L
bforall a. a -> [a] -> [a]
:[PType L]
ts)
    split PType L
_ [PType L]
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Illegal data/newtype declaration"

-----------------------------------------------------------------------------
-- Checking for extensions

checkEnabled :: (Show e, Enabled e) => e  -> P ()
checkEnabled :: forall e. (Show e, Enabled e) => e -> P ()
checkEnabled e
e = do
    [KnownExtension]
exts <- P [KnownExtension]
getExtensions
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Enabled a => a -> [KnownExtension] -> Bool
isEnabled e
e [KnownExtension]
exts) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
errorMsg
 where errorMsg :: String
errorMsg = [String] -> String
unwords
          [ forall a. Show a => a -> String
show e
e
          , String
"language extension is not enabled."
          , String
"Please add {-# LANGUAGE " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show e
e 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
    [KnownExtension]
exts <- P [KnownExtension]
getExtensions
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Enabled a => a -> [KnownExtension] -> Bool
`isEnabled` [KnownExtension]
exts) [e]
es) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
errorMsg
  where errorMsg :: String
errorMsg = [String] -> String
unwords
          [ String
"At least one of"
          , (String -> String) -> String
joinOr forall a. a -> a
id
          , String
"language extensions needs to be enabled."
          , String
"Please add:"
          , (String -> String) -> String
joinOr (\String
s -> String
"{-# LANGUAGE " forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ String
" #-}")
          , String
"language pragma at the top of your module."
          ]
        joinOr :: (String -> String) -> String
joinOr String -> String
f = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
intersperse String
" or "  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (String -> String
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall a b. (a -> b) -> a -> b
$ [e]
es

checkPatternGuards :: [Stmt L] -> P ()
checkPatternGuards :: [Stmt L] -> P ()
checkPatternGuards [Qualifier L
_ Exp L
_] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkPatternGuards [Stmt L]
_ = 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
    [KnownExtension]
exts <- P [KnownExtension]
getExtensions
    let isQQ :: Bool
isQQ = case PExp t
e of
            QuasiQuote {} -> forall a. Enabled a => a -> [KnownExtension] -> Bool
isEnabled KnownExtension
QuasiQuotes [KnownExtension]
exts
            PExp t
_ -> Bool
False
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isQQ (forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
TemplateHaskell)

-----------------------------------------------------------------------------
-- Checking contexts

-- Check that a context is syntactically correct. Takes care of
-- checking for MPTCs, TypeOperators, TypeFamilies (for eq constraints)
-- and ImplicitParameters, but leaves checking of the class assertion
-- parameters for later.
checkPContext :: PType L -> P (PContext L)
checkPContext :: PType L -> P (PContext L)
checkPContext (TyTuple L
l Boxed
Boxed [PType L]
ts) =
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PType L -> P (PAsst L)
checkAssertion [PType L]
ts forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. l -> [PAsst l] -> PContext l
CxTuple L
l
checkPContext (TyCon L
l (Special L
_ (UnitCon L
_))) =
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> PContext l
CxEmpty L
l
checkPContext (TyParen L
l PType L
t) = do
    PAsst L
c <- PType L -> P (PAsst L)
checkAssertion PType L
t
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> PAsst l -> PContext l
CxSingle L
l (forall l. l -> PAsst l -> PAsst l
ParenA L
l PAsst L
c)
checkPContext t :: PType L
t@(TyEquals L
tp PType L
_ PType L
_) = do
  forall e. (Show e, Enabled e) => [e] -> P ()
checkEnabledOneOf [KnownExtension
TypeFamilies, KnownExtension
GADTs]
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> PAsst l -> PContext l
CxSingle L
tp forall a b. (a -> b) -> a -> b
$ forall l. l -> PType l -> PAsst l
TypeA L
tp PType L
t

checkPContext PType L
t = do
    PAsst L
c <- PType L -> P (PAsst L)
checkAssertion PType L
t
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> PAsst l -> PContext l
CxSingle (forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PAsst L
c) PAsst L
c

------------------------------------------------------------------------------------------------------------------- WORKING HERE

-- Check a single assertion according to the above, still leaving
-- the class assertion parameters for later.
checkAssertion :: PType L -> P (PAsst L)
-- We cannot even get here unless ImplicitParameters is enabled.
checkAssertion :: PType L -> P (PAsst L)
checkAssertion (TyParen L
l PType L
asst) = do
    PAsst L
asst' <- PType L -> P (PAsst L)
checkAssertion PType L
asst
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> PAsst l -> PAsst l
ParenA L
l PAsst L
asst'
checkAssertion (TyPred L
_ PAsst L
p) = PAsst L -> P (PAsst L)
checkAAssertion PAsst L
p
-- We cannot even get here unless TypeFamilies or GADTs is enabled.
-- N.B.: this is called only when the equality assertion is part of a
-- tuple
checkAssertion PType L
t' = do
        PType L
t'' <- (L -> L) -> [PType L] -> PType L -> P (PType L)
checkAssertion' forall a. a -> a
id [] PType L
t'
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> PType l -> PAsst l
TypeA (forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PType L
t'') PType L
t''
    where   -- class assertions must have at least one argument
            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
_) = 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
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length [PType L]
ts forall a. Ord a => a -> a -> Bool
< Int
1) forall a b. (a -> b) -> a -> b
$ forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
FlexibleContexts
                QName L -> P ()
checkAndWarnTypeOperators QName L
c
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ L -> PType L -> [PType L] -> PType L
tyApps (L -> L
fl L
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) =
                -- no check on t at this stage
                (L -> L) -> [PType L] -> PType L -> P (PType L)
checkAssertion' (forall a b. a -> b -> a
const (L -> L
fl L
l)) (PType L
tforall 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
                -- infix operators require TypeOperators
                QName L -> P ()
checkAndWarnTypeOperators (forall l. MaybePromotedName l -> QName l
getMaybePromotedQName MaybePromotedName L
op)
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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' (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 -- Dict :: cxt => Dict cxt
                forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
ConstraintKinds
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ L -> PType L -> [PType L] -> PType L
tyApps (L -> L
fl L
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)
_) = forall (m :: * -> *) a. Monad m => a -> m a
return PType L
t
            checkAssertion' L -> L
_ [PType L]
_ PType L
t = do
                forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
QuantifiedConstraints -- anything goes
                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 (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
    PAsst L
a' <- PAsst L -> P (PAsst L)
checkAAssertion PAsst L
a
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> PAsst l -> PAsst l
ParenA L
l PAsst L
a'
checkAAssertion PAsst L
p = forall (m :: * -> *) a. Monad m => a -> m a
return PAsst L
p

-- Check class/instance declaration for multiparams
checkMultiParam :: PType L -> P ()
checkMultiParam :: PType L -> P ()
checkMultiParam = forall {l}. [PType l] -> PType l -> P ()
checkMultiParam' []
    where
        checkMultiParam' :: [PType l] -> PType l -> P ()
checkMultiParam' [PType l]
ts (TyCon l
_ QName l
_) =
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length [PType l]
ts forall a. Eq a => a -> a -> Bool
/= Int
1) forall a b. (a -> b) -> a -> b
$ 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
tforall a. a -> [a] -> [a]
:[PType l]
ts) PType l
a
        checkMultiParam' [PType l]
_ (TyInfix l
_ PType l
_ MaybePromotedName l
_ PType l
_) = 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
_ = 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)) = forall a. a -> Maybe a
Just String
s
getSymbol (Qual L
_ ModuleName L
_ (Symbol L
_ String
s)) = forall a. a -> Maybe a
Just String
s
getSymbol QName L
_                       = forall a. Maybe a
Nothing

-- | Checks whether the parameter is a symbol, and gives a nice warning for
-- "." if ExplicitForAll/TypeOperators are not enabled.
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 forall a. Eq a => a -> a -> Bool
== String
"."  -> forall e. (Show e, Enabled e) => [e] -> P ()
checkEnabledOneOf [KnownExtension
ExplicitForAll, KnownExtension
TypeOperators]
               | Bool
otherwise -> forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
TypeOperators
        Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- Checks simple contexts for class and instance
-- headers. If FlexibleContexts is enabled then
-- anything goes, otherwise only tyvars are allowed.
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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l. l -> Context l
S.CxEmpty L
l
    CxSingle L
l PAsst L
a -> PAsst L -> P (Asst L)
checkAsst PAsst L
a forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. l -> Asst l -> Context l
S.CxSingle L
l
    CxTuple L
l [PAsst L]
as -> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PAsst L -> P (Asst L)
checkAsst [PAsst L]
as forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. l -> [Asst l] -> Context l
S.CxTuple L
l
checkSContext Maybe (PContext L)
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

-- Checks ordinary contexts for sigtypes and data type
-- declarations. If FlexibleContexts is enabled then
-- anything goes, otherwise only tyvars OR tyvars
-- applied to types are allowed.
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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall l. l -> Context l
S.CxEmpty L
l
    CxSingle L
l PAsst L
a -> PAsst L -> P (Asst L)
checkAsst PAsst L
a forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. l -> Asst l -> Context l
S.CxSingle L
l
    CxTuple L
l [PAsst L]
as -> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PAsst L -> P (Asst L)
checkAsst [PAsst L]
as forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. l -> [Asst l] -> Context l
S.CxTuple L
l
checkContext Maybe (PContext L)
_ = forall (m :: * -> *) a. Monad m => a -> m a
return 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
                Type L
t <- PType L -> P (Type L)
checkType PType L
pt
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> Type l -> Asst l
S.TypeA L
l Type L
t
      IParam L
l IPName L
ipn PType L
pt -> do
                Type L
t <- PType L -> P (Type L)
checkType PType L
pt
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> IPName l -> Type l -> Asst l
S.IParam L
l IPName L
ipn Type L
t
      ParenA L
l PAsst L
a      -> do
                Asst L
a' <- PAsst L -> P (Asst L)
checkAsst PAsst L
a
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> Asst l -> Asst l
S.ParenA L
l Asst L
a'

-----------------------------------------------------------------------------
-- Checking Headers


checkDataHeader :: PType L -> P (Maybe (S.Context L), DeclHead L)
checkDataHeader :: PType L -> P (Maybe (Context L), DeclHead L)
checkDataHeader (TyForall L
_ Maybe [TyVarBind L]
Nothing Maybe (PContext L)
cs PType L
t) = do
    DeclHead L
dh <- String -> PType L -> P (DeclHead L)
checkSimple String
"data/newtype" PType L
t
    Maybe (Context L)
cs' <- Maybe (PContext L) -> P (Maybe (Context L))
checkContext Maybe (PContext L)
cs
    forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Context L)
cs',DeclHead L
dh)
checkDataHeader PType L
t = do
    DeclHead L
dh <- String -> PType L -> P (DeclHead L)
checkSimple String
"data/newtype" PType L
t
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing,DeclHead L
dh)

checkClassHeader :: PType L -> P (Maybe (S.Context L), DeclHead L)
checkClassHeader :: PType L -> P (Maybe (Context L), DeclHead L)
checkClassHeader (TyForall L
_ Maybe [TyVarBind L]
Nothing Maybe (PContext L)
cs PType L
t) = do
    PType L -> P ()
checkMultiParam PType L
t
    DeclHead L
dh <- String -> PType L -> P (DeclHead L)
checkSimple String
"class" PType L
t
    Maybe (Context L)
cs' <- Maybe (PContext L) -> P (Maybe (Context L))
checkSContext Maybe (PContext L)
cs
    forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Context L)
cs',DeclHead L
dh)
checkClassHeader PType L
t = do
    PType L -> P ()
checkMultiParam PType L
t
    DeclHead L
dh <- String -> PType L -> P (DeclHead L)
checkSimple String
"class" PType L
t
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing,DeclHead L
dh)

checkSimple :: String -> PType L -> P (DeclHead L)
--checkSimple kw (TyApp _ l t) xs | isTyVarBind t = checkSimple kw l (toTyVarBind t : xs)

checkSimple :: String -> PType L -> P (DeclHead L)
checkSimple String
kw (TyApp L
l PType L
h PType L
t) = do
  TyVarBind L
tvb <- String -> PType L -> P (TyVarBind L)
mkTyVarBind String
kw PType L
t
  DeclHead L
h' <- String -> PType L -> P (DeclHead L)
checkSimple String
kw PType L
h
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> DeclHead l -> TyVarBind l -> DeclHead l
DHApp L
l DeclHead L
h' TyVarBind L
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) <- forall l. MaybePromotedName l -> QName l
getMaybePromotedQName MaybePromotedName L
mq
  = do
       QName L -> P ()
checkAndWarnTypeOperators QName L
c
       TyVarBind L
tv1 <- String -> PType L -> P (TyVarBind L)
mkTyVarBind String
kw PType L
t1
       TyVarBind L
tv2 <- String -> PType L -> P (TyVarBind L)
mkTyVarBind String
kw PType L
t2
       forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> DeclHead l -> TyVarBind l -> DeclHead l
DHApp L
l (forall l. l -> TyVarBind l -> Name l -> DeclHead l
DHInfix L
l TyVarBind L
tv1 Name L
t) TyVarBind L
tv2
checkSimple String
_kw (TyCon L
_ c :: QName L
c@(UnQual L
l Name L
t)) = do
    QName L -> P ()
checkAndWarnTypeOperators QName L
c
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> Name l -> DeclHead l
DHead L
l Name L
t)
checkSimple String
kw (TyParen L
l PType L
t) = do
    DeclHead L
dh <- String -> PType L -> P (DeclHead L)
checkSimple String
kw PType L
t
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> DeclHead l -> DeclHead l
DHParen L
l DeclHead L
dh)
checkSimple String
kw PType L
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Illegal " forall a. [a] -> [a] -> [a]
++ String
kw 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) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> Name l -> Kind l -> TyVarBind l
KindedVar L
l Name L
n Type L
k)
mkTyVarBind String
kw PType L
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Illegal " forall a. [a] -> [a] -> [a]
++ String
kw forall a. [a] -> [a] -> [a]
++ String
" declaration")

{-
isTyVarBind :: PType L -> Bool
isTyVarBind (TyVar _ _) = True
--isTyVarBind (TyCon _ (UnQual _ n@(Symbol _ _))) = True
isTyVarBind (TyKind _ (TyVar _ _) _) = True
isTyVarBind _ = False

toTyVarBind :: PType L -> TyVarBind L
toTyVarBind (TyVar l n) = UnkindedVar l n
toTyVarBind (TyKind l (TyVar _ n) k) = KindedVar l n k
-}

checkInstHeader :: PType L -> P (InstRule L)
checkInstHeader :: PType L -> P (InstRule L)
checkInstHeader (TyParen L
l PType L
t) = PType L -> P (InstRule L)
checkInstHeader PType L
t forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
    Maybe (Context L)
cs' <- Maybe (PContext L) -> P (Maybe (Context L))
checkSContext Maybe (PContext L)
cs
    PType L -> P ()
checkMultiParam PType L
t
    Maybe L
-> Maybe [TyVarBind L]
-> Maybe (Context L)
-> PType L
-> P (InstRule L)
checkInsts (forall a. a -> Maybe a
Just L
l) Maybe [TyVarBind L]
mtvs Maybe (Context L)
cs' PType L
t
checkInstHeader PType L
t = PType L -> P ()
checkMultiParam PType L
t 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 forall a. Maybe a
Nothing forall a. Maybe a
Nothing 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 forall a. Maybe a
Nothing Maybe [TyVarBind L]
mtvs Maybe (Context L)
mctxt PType L
t forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
    InstHead L
t' <- PType L -> P (InstHead L)
checkInstsGuts PType L
t
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l.
l
-> Maybe [TyVarBind l]
-> Maybe (Context l)
-> InstHead l
-> InstRule l
IRule (forall a. a -> Maybe a -> a
fromMaybe (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Maybe (Context L)
mctxt Maybe L -> L -> L
<?+> forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann InstHead L
t') Maybe L
l1) Maybe [TyVarBind L]
mtvs Maybe (Context L)
mctxt InstHead L
t'

checkInstsGuts :: PType L -> P (InstHead L)
checkInstsGuts :: PType L -> P (InstHead L)
checkInstsGuts (TyApp L
l PType L
h PType L
t) = do
    Type L
t' <- PType L -> P (Type L)
checkType PType L
t
    InstHead L
h' <- PType L -> P (InstHead L)
checkInstsGuts PType L
h
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> InstHead l -> Type l -> InstHead l
IHApp L
l InstHead L
h' Type L
t'
checkInstsGuts (TyCon L
l QName L
c) = do
    QName L -> P ()
checkAndWarnTypeOperators QName L
c
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 (forall l. MaybePromotedName l -> QName l
getMaybePromotedQName MaybePromotedName L
op)
    [Type L
ta,Type L
tb] <- [PType L] -> P [Type L]
checkTypes [PType L
a,PType L
b]
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> InstHead l -> Type l -> InstHead l
IHApp L
l (forall l. l -> Type l -> QName l -> InstHead l
IHInfix L
l Type L
ta (forall l. MaybePromotedName l -> QName l
getMaybePromotedQName MaybePromotedName L
op)) Type L
tb
checkInstsGuts (TyParen L
l PType L
t) = PType L -> P (InstHead L)
checkInstsGuts PType L
t forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. l -> InstHead l -> InstHead l
IHParen L
l
checkInstsGuts PType L
_ = 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 = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe L
-> Maybe [TyVarBind L]
-> Maybe (Context L)
-> PType L
-> P (InstRule L)
checkInsts forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing)

-----------------------------------------------------------------------------
-- Checking Patterns.

-- We parse patterns as expressions and check for valid patterns below,
-- converting the expression into a pattern at the same time.

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' = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl L -> L -> L
combSpanInfo L
l (forall a b. (a -> b) -> [a] -> [b]
map forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann [Pat L]
args)
  forall (m :: * -> *) a. Monad m => a -> m a
return (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
    Pat L
x' <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
x []
    PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
f (Pat L
x'forall a. a -> [a] -> [a]
:[Pat L]
args)
checkPat (InfixApp L
_ PExp L
l QOp L
op PExp L
r) [Pat L]
args
    | QOp L
op forall (a :: * -> *) l1 l2.
(Annotated a, Eq (a ())) =>
a l1 -> a l2 -> Bool
=~= forall l. l -> QName l -> QOp l
QVarOp () (forall l. l -> Name l -> QName l
UnQual () (forall l. l -> String -> Name l
Symbol () String
"!")) = do
        -- We must have BangPatterns on
        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 []
        [Pat L]
ps <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PExp L -> P (Pat L)
checkPattern (forall l. l -> PExp l -> PExp l
BangPat (forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann QOp L
op) PExp L
eforall a. a -> [a] -> [a]
:[PExp L]
es)
        PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
l ([Pat L]
psforall a. [a] -> [a] -> [a]
++[Pat L]
args)
checkPat PExp L
e' [] = case PExp L
e' of
    Var L
_ (UnQual L
l Name L
x)   -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> Name l -> Pat l
PVar L
l Name L
x)
    Var L
_ (Special L
l (ExprHole L
_)) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> Pat l
PWildCard L
l)
    Lit L
l Literal L
lit            -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> Sign l -> Literal l -> Pat l
PLit L
l (forall l. l -> Sign l
Signless L
l2) Literal L
lit)
            where l2 :: L
l2 = SrcSpan -> L
noInfoSpan forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> SrcSpan
srcInfoSpan 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
                    Pat L
l' <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
l []
                    Pat L
r' <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
r []
                    forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> Pat l -> QName l -> Pat l -> Pat l
PInfixApp L
loc Pat L
l' QName L
c Pat L
r')
            QVarOp L
ppos (UnQual L
_ (Symbol L
_ String
"+")) -> do
                    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
                            forall (m :: * -> *) a. Monad m => a -> m a
return (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)
_ -> forall a. String -> P a
patFail String
""
            QOp L
_ -> forall a. String -> P a
patFail String
""
    TupleSection L
l Boxed
bx [Maybe (PExp L)]
mes    ->
            if forall a. Maybe a
Nothing forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Maybe (PExp L)]
mes
             then do [Pat L]
ps <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\PExp L
e -> PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []) (forall a b. (a -> b) -> [a] -> [b]
map forall a. HasCallStack => Maybe a -> a
fromJust [Maybe (PExp L)]
mes)
                     forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> Boxed -> [Pat l] -> Pat l
PTuple L
l Boxed
bx [Pat L]
ps)
             else 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 ->
      forall l. l -> Int -> Int -> Pat l -> Pat l
PUnboxedSum L
l Int
b Int
a 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
                  [RPat L]
ps <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PExp L -> P (RPat L)
checkRPattern [PExp L]
es
                  if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all RPat L -> Bool
isStdPat [RPat L]
ps
                    then forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. l -> [Pat l] -> Pat l
PList L
l forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map RPat L -> Pat L
stripRP [RPat L]
ps
                    -- we don't allow truly regular patterns unless the extension is enabled
                    else forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
RegularPatterns forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> [RPat l] -> Pat l
PRPat L
l forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map RPat L -> RPat L
fixRPOpPrec [RPat L]
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) = 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) = forall l. l -> Pat l -> Pat l
PParen L
l' (RPat L -> Pat L
stripRP RPat L
p)
                  stripRP RPat 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
                  Pat L
p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
                  forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> Pat l -> Pat l
PParen L
l Pat L
p)
    AsPat L
l Name L
n PExp L
e    -> do
                  Pat L
p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
                  forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> Name l -> Pat l -> Pat l
PAsPat L
l Name L
n Pat L
p)
    WildCard L
l   -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> Pat l
PWildCard L
l)
    IrrPat L
l PExp L
e   -> do
                  Pat L
p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
                  forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> Pat l -> Pat l
PIrrPat L
l Pat L
p)
    ViewPat L
l PExp L
e Pat L
p  -> do
                  Exp L
e1 <- PExp L -> P (Exp L)
checkExpr PExp L
e
                  forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> Exp l -> Pat l -> Pat l
PViewPat L
l Exp L
e1 Pat L
p)
    RecConstr L
l QName L
c [PFieldUpdate L]
fs   -> do
                  [PatField L]
fs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PFieldUpdate L -> P (PatField L)
checkPatField [PFieldUpdate L]
fs
                  forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> QName l -> [PatField l] -> Pat l
PRec L
l QName L
c [PatField L]
fs')
    NegApp L
l (Lit L
_ Literal L
lit) ->
                  let siSign :: SrcSpan
siSign = forall a. [a] -> a
last forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> [SrcSpan]
srcInfoPoints forall a b. (a -> b) -> a -> b
$ L
l
                      lSign :: L
lSign = SrcSpan -> [SrcSpan] -> L
infoSpan SrcSpan
siSign [SrcSpan
siSign]
                  in do
                    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Literal a -> Bool
isNegatableLiteral forall a b. (a -> b) -> a -> b
$ Literal L
lit) (forall a. String -> P a
patFail forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> String
prettyPrint PExp L
e')
                    forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> Sign l -> Literal l -> Pat l
PLit L
l (forall l. l -> Sign l
Negative L
lSign) Literal L
lit)
    ExpTypeSig L
l PExp L
e Type L
t -> do
                  -- patterns cannot have signatures unless ScopedTypeVariables is enabled.
                  forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
ScopedTypeVariables
                  Pat L
p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
                  forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> Pat l -> Type l -> Pat l
PatTypeSig L
l Pat L
p Type L
t)

    -- Hsx
    XTag L
l XName L
n [ParseXAttr L]
attrs Maybe (PExp L)
mattr [PExp L]
cs -> do
                  [PXAttr L]
pattrs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ParseXAttr L -> P (PXAttr L)
checkPAttr [ParseXAttr L]
attrs
                  [Pat L]
pcs    <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\PExp L
c -> PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
c []) [PExp L]
cs
                  Maybe (Pat L)
mpattr <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
                              (\PExp L
e -> do Pat L
p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
                                        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Pat L
p)
                              Maybe (PExp L)
mattr
                  let cps :: [Pat L]
cps = [Pat L] -> [Pat L]
mkChildrenPat [Pat L]
pcs
                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l.
l -> XName l -> [PXAttr l] -> Maybe (Pat l) -> [Pat l] -> Pat l
PXTag L
l XName L
n [PXAttr L]
pattrs Maybe (Pat L)
mpattr [Pat L]
cps
    XETag L
l XName L
n [ParseXAttr L]
attrs Maybe (PExp L)
mattr -> do
                  [PXAttr L]
pattrs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ParseXAttr L -> P (PXAttr L)
checkPAttr [ParseXAttr L]
attrs
                  Maybe (Pat L)
mpattr <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
                              (\PExp L
e -> do Pat L
p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
                                        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Pat L
p)
                              Maybe (PExp L)
mattr
                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> XName l -> [PXAttr l] -> Maybe (Pat l) -> Pat l
PXETag L
l XName L
n [PXAttr L]
pattrs Maybe (Pat L)
mpattr
    XPcdata L
l String
pcdata   -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> String -> Pat l
PXPcdata L
l String
pcdata
    XExpTag L
l PExp L
e -> do
            Pat L
p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> Pat l -> Pat l
PXPatTag L
l Pat L
p
    XRPats L
l [PExp L]
es -> do
            [RPat L]
rps <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PExp L -> P (RPat L)
checkRPattern [PExp L]
es
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> [RPat l] -> Pat l
PXRPats L
l forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map RPat L -> RPat L
fixRPOpPrec [RPat L]
rps)

    -- Template Haskell
    SpliceExp L
l Splice L
e -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> Splice l -> Pat l
PSplice L
l Splice L
e
    QuasiQuote L
l String
n String
q -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> String -> String -> Pat l
PQuasiQuote L
l String
n String
q

    -- BangPatterns
    BangPat L
l PExp L
e -> do
        Pat L
p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> Pat l -> Pat l
PBangPat L
l Pat L
p

    PreOp L
l (QVarOp L
_ (UnQual L
_ (Symbol L
_ String
"!"))) PExp L
e -> do
        forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
BangPatterns
        Pat L
p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> Pat l -> Pat l
PBangPat L
l Pat L
p

    PExp L
e -> forall a. String -> P a
patFail forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> String
prettyPrint PExp L
e

checkPat PExp L
e [Pat L]
_ = forall a. String -> P a
patFail forall a b. (a -> b) -> a -> b
$ 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
xforall 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
    Pat L
p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> QName l -> Pat l -> PatField l
PFieldPat L
l QName L
n Pat L
p)
checkPatField (FieldPun L
l QName L
n) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> QName l -> PatField l
PFieldPun L
l QName L
n)
checkPatField (FieldWildcard L
l) = forall (m :: * -> *) a. Monad m => a -> m a
return (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 Pat L
p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
v []
                              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> XName l -> Pat l -> PXAttr l
PXAttr L
l XName L
n Pat L
p

patFail :: String -> P a
patFail :: forall a. String -> P a
patFail String
s = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Parse error in pattern: " 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
        [RPat L]
rps <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PExp L -> P (RPat L)
checkRPattern [PExp L]
es
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> [RPat l] -> RPat l
RPSeq L
l [RPat L]
rps
    PostOp L
l PExp L
e QOp L
op -> do
        RPatOp L
rpop <- QOp L -> P (RPatOp L)
checkRPatOp QOp L
op
        RPat L
rp   <- PExp L -> P (RPat L)
checkRPattern PExp L
e
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> RPat l -> RPatOp l -> RPat l
RPOp L
l RPat L
rp RPatOp L
rpop
    GuardRP L
l PExp L
e [Stmt L]
gs -> do
        Pat L
rp <- PExp L -> P (Pat L)
checkPattern PExp L
e
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> Pat l -> [Stmt l] -> RPat l
RPGuard L
l Pat L
rp [Stmt L]
gs
    EitherRP L
l PExp L
e1 PExp L
e2 -> do
        RPat L
rp1 <- PExp L -> P (RPat L)
checkRPattern PExp L
e1
        RPat L
rp2 <- PExp L -> P (RPat L)
checkRPattern PExp L
e2
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> RPat l -> RPat l -> RPat l
RPEither L
l RPat L
rp1 RPat L
rp2
    CAsRP L
l Name L
n PExp L
e -> do
        RPat L
rp <- PExp L -> P (RPat L)
checkRPattern PExp L
e
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> Name l -> RPat l -> RPat l
RPCAs L
l Name L
n RPat L
rp
    AsPat L
l Name L
n PExp L
e  -> do
        RPat L
rp <- PExp L -> P (RPat L)
checkRPattern PExp L
e
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> Name l -> RPat l -> RPat l
RPAs L
l Name L
n RPat L
rp
    Paren L
l PExp L
e -> do
        RPat L
rp <- PExp L -> P (RPat L)
checkRPattern PExp L
e
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> RPat l -> RPat l
RPParen L
l RPat L
rp
    PExp L
_          -> do
        Pat L
p <- PExp L -> P (Pat L)
checkPattern PExp L
e'
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> Pat l -> RPat l
RPPat (forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Pat L
p) Pat L
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
"*"  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> RPatOp l
RPStar L
l
     String
"*!" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> RPatOp l
RPStarG L
l
     String
"+"  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> RPatOp l
RPPlus L
l
     String
"+!" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> RPatOp l
RPPlusG L
l
     String
"?"  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> RPatOp l
RPOpt L
l
     String
"?!" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> RPatOp l
RPOptG L
l
     String
_    -> forall a b. Pretty a => a -> P b
rpOpFail QOp L
o
checkRPatOp QOp L
o = 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 = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unrecognized regular pattern operator: " forall a. [a] -> [a] -> [a]
++ 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 (forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall l. l -> RPat l -> RPatOp l -> RPat l
RPOp L
l) RPatOp L
rpop)
    RPEither L
l RPat L
rp1 RPat L
rp2  -> 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         -> forall l. l -> [RPat l] -> RPat l
RPSeq L
l forall a b. (a -> b) -> a -> b
$ 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        -> forall l. l -> Name l -> RPat l -> RPat l
RPCAs L
l Name L
n forall a b. (a -> b) -> a -> b
$ RPat L -> RPat L
fixRPOpPrec RPat L
rp
    RPAs L
l Name L
n RPat L
rp         -> forall l. l -> Name l -> RPat l -> RPat l
RPAs L
l Name L
n forall a b. (a -> b) -> a -> b
$ RPat L -> RPat L
fixRPOpPrec RPat L
rp
    RPParen L
l RPat L
rp        -> forall l. l -> RPat l -> RPat l
RPParen L
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip (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 (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 (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 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. RPat L -> RPat L
f 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 = 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 (forall a. [a] -> [a]
reverse [RPat L]
rps forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (\Pat L
q -> forall l. l -> Pat l -> RPat l
RPPat (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
pforall 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 = forall l. l -> [RPat l] -> Pat l
PXRPats L
l forall a b. (a -> b) -> a -> b
$ 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 (forall a. [a] -> [a]
reverse [RPat L]
rqs forall a. [a] -> [a] -> [a]
++ [RPat L]
rps)
            Pat L
_               -> L -> [Pat L] -> [RPat L] -> Pat L
mkCRP (forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Pat L
p) [Pat L]
ps (forall l. l -> Pat l -> RPat l
RPPat (forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Pat L
p) Pat L
p forall a. a -> [a] -> [a]
: [RPat L]
rps)

-----------------------------------------------------------------------------
-- Check Expression Syntax

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               -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> QName l -> Exp l
S.Var L
l QName L
v
    OverloadedLabel L
l String
v   -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> String -> Exp l
S.OverloadedLabel L
l String
v
    IPVar L
l IPName L
v             -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> IPName l -> Exp l
S.IPVar L
l IPName L
v
    Con L
l QName L
c               -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> QName l -> Exp l
S.Con L
l QName L
c
    Lit L
l Literal L
lit             -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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   -> forall a. PExp L -> PExp L -> (Exp L -> Exp L -> a) -> P a
check2Exprs PExp L
e1 PExp L
e2 (forall a b c. (a -> b -> c) -> b -> a -> c
flip (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           -> forall a. PExp L -> PExp L -> (Exp L -> Exp L -> a) -> P a
check2Exprs PExp L
e1 PExp L
e2 (forall l. l -> Exp l -> Exp l -> Exp l
S.App L
l)
    NegApp L
_ (Lit L
_ (PrimWord L
_ Integer
_ String
_))
                          -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Parse error: negative primitive word literal: " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyPrint PExp L
e'
    NegApp L
l PExp L
e            -> forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e (forall l. l -> Exp l -> Exp l
S.NegApp L
l)
    Lambda L
loc [Pat L]
ps PExp L
e       -> forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e (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            -> forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e (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         -> 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 (forall l. l -> Exp l -> Exp l -> Exp l -> Exp l
S.If L
l)
    MultiIf L
l [GuardedRhs L]
alts        -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> [GuardedRhs l] -> Exp l
S.MultiIf L
l [GuardedRhs L]
alts)
    Case L
l PExp L
e [Alt L]
alts         -> do
                     Exp L
e1 <- PExp L -> P (Exp L)
checkExpr PExp L
e
                     forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> Exp l -> [Alt l] -> Exp l
S.Case L
l Exp L
e1 [Alt L]
alts)
    Do L
l [Stmt L]
stmts            -> forall t. [Stmt t] -> P ()
checkDo [Stmt L]
stmts forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> [Stmt l] -> Exp l
S.Do L
l [Stmt L]
stmts)
    MDo L
l [Stmt L]
stmts           -> forall t. [Stmt t] -> P ()
checkDo [Stmt L]
stmts forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> [Stmt l] -> Exp l
S.MDo L
l [Stmt L]
stmts)
    TupleSection L
l Boxed
bx [Maybe (PExp L)]
mes -> if forall a. Maybe a
Nothing forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Maybe (PExp L)]
mes
                             then forall a. [PExp L] -> ([Exp L] -> a) -> P a
checkManyExprs (forall a b. (a -> b) -> [a] -> [b]
map forall a. HasCallStack => Maybe a -> a
fromJust [Maybe (PExp L)]
mes) (forall l. l -> Boxed -> [Exp l] -> Exp l
S.Tuple L
l Boxed
bx)
                             else do forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
TupleSections
                                     [Maybe (Exp L)]
mes' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Maybe (PExp L) -> P (Maybe (Exp L))
mCheckExpr [Maybe (PExp L)]
mes
                                     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> Boxed -> [Maybe (Exp l)] -> Exp l
S.TupleSection L
l Boxed
bx [Maybe (Exp L)]
mes'
    UnboxedSum L
l Int
before Int
after PExp L
e -> forall l. l -> Int -> Int -> Exp l -> Exp l
S.UnboxedSum L
l Int
before Int
after 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         -> forall a. [PExp L] -> ([Exp L] -> a) -> P a
checkManyExprs [PExp L]
es (forall l. l -> [Exp l] -> Exp l
S.List L
l)
    ParArray L
l [PExp L]
es     -> forall a. [PExp L] -> ([Exp L] -> a) -> P a
checkManyExprs [PExp L]
es (forall l. l -> [Exp l] -> Exp l
S.ParArray L
l)
    -- Since we don't parse things as left or right sections, we need to mangle them into that.
    Paren L
l PExp L
e         -> case PExp L
e of
                          PostOp L
_ PExp L
e1 QOp L
op -> forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e1 (forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall l. l -> Exp l -> QOp l -> Exp l
S.LeftSection L
l) QOp L
op)
                          PreOp  L
_ QOp L
op PExp L
e2 -> forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e2 (forall l. l -> QOp l -> Exp l -> Exp l
S.RightSection L
l QOp L
op)
                          PExp L
_            -> forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e (forall l. l -> Exp l -> Exp l
S.Paren L
l)
    RecConstr L
l QName L
c [PFieldUpdate L]
fields      -> do
                     [FieldUpdate L]
fields1 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PFieldUpdate L -> P (FieldUpdate L)
checkField [PFieldUpdate L]
fields
                     forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> QName l -> [FieldUpdate l] -> Exp l
S.RecConstr L
l QName L
c [FieldUpdate L]
fields1)
    RecUpdate L
l PExp L
e [PFieldUpdate L]
fields      -> do
                     [FieldUpdate L]
fields1 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PFieldUpdate L -> P (FieldUpdate L)
checkField [PFieldUpdate L]
fields
                     Exp L
e1 <- PExp L -> P (Exp L)
checkExpr PExp L
e
                     forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> Exp l -> [FieldUpdate l] -> Exp l
S.RecUpdate L
l Exp L
e1 [FieldUpdate L]
fields1)
    EnumFrom L
l PExp L
e          -> forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e (forall l. l -> Exp l -> Exp l
S.EnumFrom L
l)
    EnumFromTo L
l PExp L
e1 PExp L
e2    -> forall a. PExp L -> PExp L -> (Exp L -> Exp L -> a) -> P a
check2Exprs PExp L
e1 PExp L
e2 (forall l. l -> Exp l -> Exp l -> Exp l
S.EnumFromTo L
l)
    EnumFromThen L
l PExp L
e1 PExp L
e2      -> forall a. PExp L -> PExp L -> (Exp L -> Exp L -> a) -> P a
check2Exprs PExp L
e1 PExp L
e2 (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 -> 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 (forall l. l -> Exp l -> Exp l -> Exp l -> Exp l
S.EnumFromThenTo L
l)
    ParArrayFromTo L
l PExp L
e1 PExp L
e2    -> forall a. PExp L -> PExp L -> (Exp L -> Exp L -> a) -> P a
check2Exprs PExp L
e1 PExp L
e2 (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 -> 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 (forall l. l -> Exp l -> Exp l -> Exp l -> Exp l
S.ParArrayFromThenTo L
l)
    -- a parallel list comprehension, which could be just a simple one
    ParComp L
l PExp L
e [[QualStmt L]]
qualss        -> do
                     Exp L
e1 <- PExp L -> P (Exp L)
checkExpr PExp L
e
                     case [[QualStmt L]]
qualss of
                      [[QualStmt L]
quals] -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> Exp l -> [QualStmt l] -> Exp l
S.ListComp L
l Exp L
e1 [QualStmt L]
quals)
                      [[QualStmt L]]
_       -> forall (m :: * -> *) a. Monad m => a -> m a
return (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
                     Exp L
e1 <- PExp L -> P (Exp L)
checkExpr PExp L
e
                     forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> Exp l -> [[QualStmt l]] -> Exp l
S.ParArrayComp L
l Exp L
e1 [[QualStmt L]]
qualss)
    ExpTypeSig L
loc PExp L
e Type L
ty     -> do
                     Exp L
e1 <- PExp L -> P (Exp L)
checkExpr PExp L
e
                     forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> Exp l -> Type l -> Exp l
S.ExpTypeSig L
loc Exp L
e1 Type L
ty)

    --Template Haskell
    BracketExp L
l Bracket L
e        -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> Bracket l -> Exp l
S.BracketExp L
l Bracket L
e
    SpliceExp L
l Splice L
e         -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> Splice l -> Exp l
S.SpliceExp L
l Splice L
e
    TypQuote L
l QName L
q          -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> QName l -> Exp l
S.TypQuote L
l QName L
q
    VarQuote L
l QName L
q          -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> QName l -> Exp l
S.VarQuote L
l QName L
q
    QuasiQuote L
l String
n String
q      -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> String -> String -> Exp l
S.QuasiQuote L
l String
n String
q

    -- Hsx
    XTag L
l XName L
n [ParseXAttr L]
attrs Maybe (PExp L)
mattr [PExp L]
cs -> do [XAttr L]
attrs1 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ParseXAttr L -> P (XAttr L)
checkAttr [ParseXAttr L]
attrs
                                  [Exp L]
cs1 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PExp L -> P (Exp L)
checkExpr [PExp L]
cs
                                  Maybe (Exp L)
mattr1 <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
                                              (\PExp L
e -> PExp L -> P (Exp L)
checkExpr PExp L
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just)
                                              Maybe (PExp L)
mattr
                                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l.
l -> XName l -> [XAttr l] -> Maybe (Exp l) -> [Exp l] -> Exp l
S.XTag L
l XName L
n [XAttr L]
attrs1 Maybe (Exp L)
mattr1 [Exp L]
cs1
    XETag L
l XName L
n [ParseXAttr L]
attrs Maybe (PExp L)
mattr   -> do [XAttr L]
attrs1 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ParseXAttr L -> P (XAttr L)
checkAttr [ParseXAttr L]
attrs
                                  Maybe (Exp L)
mattr1 <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
                                              (\PExp L
e -> PExp L -> P (Exp L)
checkExpr PExp L
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just)
                                              Maybe (PExp L)
mattr
                                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> XName l -> [XAttr l] -> Maybe (Exp l) -> Exp l
S.XETag L
l XName L
n [XAttr L]
attrs1 Maybe (Exp L)
mattr1
    XPcdata L
l String
p       -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> String -> Exp l
S.XPcdata L
l String
p
    XExpTag L
l PExp L
e       -> do Exp L
e1 <- PExp L -> P (Exp L)
checkExpr PExp L
e
                            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> Exp l -> Exp l
S.XExpTag L
l Exp L
e1
    XChildTag L
l [PExp L]
es    -> do [Exp L]
es1 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PExp L -> P (Exp L)
checkExpr [PExp L]
es
                            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> [Exp l] -> Exp l
S.XChildTag L
l [Exp L]
es1
    -- Pragmas
    CorePragma L
l String
s PExp L
e  -> forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e (forall l. l -> String -> Exp l -> Exp l
S.CorePragma L
l String
s)
    SCCPragma  L
l String
s PExp L
e  -> forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e (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 -> forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e (forall l. l -> String -> (Int, Int) -> (Int, Int) -> Exp l -> Exp l
S.GenPragma L
l String
s (Int, Int)
xx (Int, Int)
yy)
--    UnknownExpPragma n s -> return $ S.UnknownExpPragma n s

    -- Arrows
    Proc L
l Pat L
p PExp L
e              -> do Exp L
e1 <- PExp L -> P (Exp L)
checkExpr PExp L
e
                                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> Pat l -> Exp l -> Exp l
S.Proc L
l Pat L
p Exp L
e1
    LeftArrApp L
l PExp L
e1 PExp L
e2      -> forall a. PExp L -> PExp L -> (Exp L -> Exp L -> a) -> P a
check2Exprs PExp L
e1 PExp L
e2 (forall l. l -> Exp l -> Exp l -> Exp l
S.LeftArrApp L
l)
    RightArrApp L
l PExp L
e1 PExp L
e2     -> forall a. PExp L -> PExp L -> (Exp L -> Exp L -> a) -> P a
check2Exprs PExp L
e1 PExp L
e2 (forall l. l -> Exp l -> Exp l -> Exp l
S.RightArrApp L
l)
    LeftArrHighApp L
l PExp L
e1 PExp L
e2  -> forall a. PExp L -> PExp L -> (Exp L -> Exp L -> a) -> P a
check2Exprs PExp L
e1 PExp L
e2 (forall l. l -> Exp l -> Exp l -> Exp l
S.LeftArrHighApp L
l)
    RightArrHighApp L
l PExp L
e1 PExp L
e2 -> forall a. PExp L -> PExp L -> (Exp L -> Exp L -> a) -> P a
check2Exprs PExp L
e1 PExp L
e2 (forall l. l -> Exp l -> Exp l -> Exp l
S.RightArrHighApp L
l)
    ArrOp L
l PExp L
e               -> forall l. l -> Exp l -> Exp l
S.ArrOp L
l forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PExp L -> P (Exp L)
checkExpr PExp L
e

    -- LamdaCase
    LCase L
l [Alt L]
alts -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> [Alt l] -> Exp l
S.LCase L
l [Alt L]
alts

    -- Hole
    TypeApp L
l Type L
ty   -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> Type l -> Exp l
S.TypeApp L
l Type L
ty

    PExp L
_             -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Parse error in expression: " forall a. [a] -> [a] -> [a]
++ 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 Exp L
v' <- PExp L -> P (Exp L)
checkExpr PExp L
v
                             forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> XName l -> Exp l -> XAttr l
S.XAttr L
l XName L
n Exp L
v'

checkDo :: [Stmt t] -> P ()
checkDo :: forall t. [Stmt t] -> P ()
checkDo [] = 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
_] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkDo (Stmt t
_:[Stmt t]
xs) = forall t. [Stmt t] -> P ()
checkDo [Stmt t]
xs

-- type signature for polymorphic recursion!!
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
    Exp L
e1' <- PExp L -> P (Exp L)
checkExpr PExp L
e1
    forall (m :: * -> *) a. Monad m => a -> m a
return (Exp L -> a
f Exp L
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
    Exp L
e1' <- PExp L -> P (Exp L)
checkExpr PExp L
e1
    Exp L
e2' <- PExp L -> P (Exp L)
checkExpr PExp L
e2
    forall (m :: * -> *) a. Monad m => a -> m a
return (Exp L -> Exp L -> a
f Exp L
e1' Exp L
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
    Exp L
e1' <- PExp L -> P (Exp L)
checkExpr PExp L
e1
    Exp L
e2' <- PExp L -> P (Exp L)
checkExpr PExp L
e2
    Exp L
e3' <- PExp L -> P (Exp L)
checkExpr PExp L
e3
    forall (m :: * -> *) a. Monad m => a -> m a
return (Exp L -> Exp L -> Exp L -> a
f Exp L
e1' Exp L
e2' Exp L
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
    [Exp L]
es' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PExp L -> P (Exp L)
checkExpr [PExp L]
es
    forall (m :: * -> *) a. Monad m => a -> m a
return ([Exp L] -> a
f [Exp L]
es')

mCheckExpr :: Maybe (PExp L) -> P (Maybe (S.Exp L))
mCheckExpr :: Maybe (PExp L) -> P (Maybe (Exp L))
mCheckExpr Maybe (PExp L)
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
mCheckExpr (Just PExp L
e) = PExp L -> P (Exp L)
checkExpr PExp L
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = 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) = forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e (forall l. l -> QName l -> Exp l -> FieldUpdate l
S.FieldUpdate L
l QName L
n)
checkField (FieldPun L
l QName L
n) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> QName l -> FieldUpdate l
S.FieldPun L
l QName L
n
checkField (FieldWildcard L
l) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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) = forall (m :: * -> *) a. Monad m => a -> m a
return QName L
n
getGConName (S.List L
l []) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> QName l
list_cons_name L
l)
getGConName Exp L
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expression in reification is not a name"

-----------------------------------------------------------------------------
-- Check Equation Syntax

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
    Maybe (Name L, [PExp L], Bool, [SrcSpan])
mlhs <- PExp L -> [PExp L] -> P (Maybe (Name L, [PExp L], Bool, [SrcSpan]))
isFunLhs PExp L
lhs []
    let whpt :: [SrcSpan]
whpt = L -> [SrcSpan]
srcInfoPoints L
l
    case Maybe (Name L, [PExp L], Bool, [SrcSpan])
mlhs of
     Just (Name L
f,[PExp L]
es,Bool
b,[SrcSpan]
pts) -> do
            [Pat L]
ps <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PExp L -> P (Pat L)
checkPattern [PExp L]
es
            let l' :: L
l' = L
l { srcInfoPoints :: [SrcSpan]
srcInfoPoints = [SrcSpan]
pts forall a. [a] -> [a] -> [a]
++ [SrcSpan]
whpt }
            case Maybe (Type L, SrcSpan)
optsig of -- only pattern bindings can have signatures
                Maybe (Type L, SrcSpan)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> [Match l] -> Decl l
FunBind L
l forall a b. (a -> b) -> a -> b
$
                            if Bool
b then [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 [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)
_  -> 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
            Pat L
lhs1 <- PExp L -> P (Pat L)
checkPattern PExp L
lhs
            let lhs' :: Pat L
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 = (forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Pat L
lhs1 L -> L -> L
<++> forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Type L
ty) L -> [SrcSpan] -> L
<** [SrcSpan
pt]
                                         in forall l. l -> Pat l -> Type l -> Pat l
PatTypeSig L
lp Pat L
lhs1 Type L
ty
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> Pat l -> Rhs l -> Maybe (Binds l) -> Decl l
PatBind L
l Pat L
lhs' Rhs L
rhs Maybe (Binds L)
whereBinds)

-- A variable binding is parsed as a PatBind.

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 forall (a :: * -> *) l1 l2.
(Annotated a, Eq (a ())) =>
a l1 -> a l2 -> Bool
=~= forall l. l -> String -> Name l
Symbol () String
"!" = do
        [KnownExtension]
exts <- P [KnownExtension]
getExtensions
        if KnownExtension
BangPatterns forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts
         then let (PExp L
b,[PExp L]
bs) = PExp L -> [PExp L] -> (PExp L, [PExp L])
splitBang PExp L
r []
                  loc' :: L
loc' = L -> L -> L
combSpanInfo L
loc (forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PExp L
b)
               in PExp L -> [PExp L] -> P (Maybe (Name L, [PExp L], Bool, [SrcSpan]))
isFunLhs PExp L
l (forall l. l -> PExp l -> PExp l
BangPat L
loc' PExp L
b forall a. a -> [a] -> [a]
: [PExp L]
bs forall a. [a] -> [a] -> [a]
++ [PExp L]
es)
         else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Name L
op, PExp L
lforall a. a -> [a] -> [a]
:PExp L
rforall a. a -> [a] -> [a]
:[PExp L]
es, Bool
False, []) -- It's actually a definition of the operator !
    | Bool
otherwise =
        let infos :: [SrcSpan]
infos = L -> [SrcSpan]
srcInfoPoints L
loc
            op' :: Name L
op'   = forall (ast :: * -> *) l.
Annotated ast =>
(l -> l) -> ast l -> ast l
amap (\L
s -> L
s { srcInfoPoints :: [SrcSpan]
srcInfoPoints = [SrcSpan]
infos }) Name L
op
        in (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Name L
op', PExp L
lforall a. a -> [a] -> [a]
:PExp L
rforall 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 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Name L
f, PExp L
eforall 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
eforall a. a -> [a] -> [a]
:[PExp L]
es)
isFunLhs (Var L
_ (UnQual L
_ Name L
f)) es :: [PExp L]
es@(PExp L
_:[PExp L]
_) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 Maybe (Name L, [PExp L], Bool, [SrcSpan])
mlhs <- PExp L -> [PExp L] -> P (Maybe (Name L, [PExp L], Bool, [SrcSpan]))
isFunLhs PExp L
f [PExp L]
es
                                   case Maybe (Name L, [PExp L], Bool, [SrcSpan])
mlhs of
                                    Just (Name L
f',[PExp L]
es',Bool
b,[SrcSpan]
pts) ->
                                       let [SrcSpan
x,SrcSpan
y] = L -> [SrcSpan]
srcInfoPoints L
l
                                        in forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Name L
f',[PExp L]
es',Bool
b,SrcSpan
xforall a. a -> [a] -> [a]
:[SrcSpan]
ptsforall a. [a] -> [a] -> [a]
++[SrcSpan
y])
                                    Maybe (Name L, [PExp L], Bool, [SrcSpan])
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
isFunLhs PExp L
_ [PExp L]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

-- Separating between signature declarations and value definitions in
-- a post-processing step

checkSigVar :: PExp L -> P (Name L)
checkSigVar :: PExp L -> P (Name L)
checkSigVar (Var L
_ (UnQual L
l Name L
n)) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const L
l) Name L
n
checkSigVar PExp L
e = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Left-hand side of type signature is not a variable: " forall a. [a] -> [a] -> [a]
++ 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] forall a. [a] -> [a] -> [a]
++ [SrcSpan]
semis forall a. [a] -> [a] -> [a]
++ [SrcSpan
closeLoc])
  in  forall l. l -> [Decl l] -> PatternSynDirection l
S.ExplicitBidirectional L
l  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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]
_        -> forall (m :: * -> *) a. Monad m => a -> m a
return Decl L
p
        PInfixApp L
_ Pat L
_ QName L
_ Pat L
_ ->  forall (m :: * -> *) a. Monad m => a -> m a
return Decl L
p
        Pat L
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Illegal pattern binding in PatternSynonym"
    checkDecls Decl L
_                 = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"pattern synonym 'where' clause must contain a PatBind"

-----------------------------------------------------------------------------
-- In a class or instance body, a pattern binding must be of a variable.

checkClassBody :: [ClassDecl L] -> P [ClassDecl L]
checkClassBody :: [ClassDecl L] -> P [ClassDecl L]
checkClassBody [ClassDecl L]
decls = do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ClassDecl L -> P ()
checkClassMethodDef [ClassDecl L]
decls
    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
_ = 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
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ InstDecl L -> P ()
checkInstMethodDef [InstDecl L]
decls
    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
_ = 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)
_) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkMethodDef (PatBind L
loc Pat L
_ Rhs L
_ Maybe (Binds L)
_) =
    forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"illegal method definition" forall a. P a -> SrcLoc -> P a
`atSrcLoc` forall si. SrcInfo si => L -> si
fromSrcInfo L
loc
checkMethodDef Decl L
_ = 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 forall (m :: * -> *) a. Monad m => a -> m a
return (Name L
name,Type L
typ,SrcSpan
b)
checkDefSigDef (TypeSig L
_ [Name L]
_ Type L
_) =
    forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"default signature must be for a single name"
checkDefSigDef Decl L
_ =
    forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"default signature must be a type signature"

-----------------------------------------------------------------------------
-- Check that an identifier or symbol is unqualified.
-- For occasions when doing this in the grammar would cause conflicts.

checkUnQual :: QName L -> P (Name L)
checkUnQual :: QName L -> P (Name L)
checkUnQual (Qual  L
_ ModuleName L
_ Name L
_) = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Illegal qualified name"
checkUnQual (UnQual  L
l Name L
n) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const L
l) Name L
n
checkUnQual (Special L
_ SpecialCon L
_) = 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
_) = forall (m :: * -> *) a. Monad m => a -> m a
return QName L
n
checkQualOrUnQual n :: QName L
n@(UnQual  L
_ Name L
_) = forall (m :: * -> *) a. Monad m => a -> m a
return QName L
n
checkQualOrUnQual (Special L
_ SpecialCon L
_)   = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Illegal special name"

-----------------------------------------------------------------------------
-- Check that two xml tag names are equal
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 forall a. Eq a => a -> a -> Bool
== String
n2  = 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 forall a. Eq a => a -> a -> Bool
== String
n2 Bool -> Bool -> Bool
&& String
d1 forall a. Eq a => a -> a -> Bool
== String
d2 = forall (m :: * -> *) a. Monad m => a -> m a
return XName L
n
checkEqNames XName L
n XName L
m = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"opening tag '" forall a. [a] -> [a] -> [a]
++ forall {l}. XName l -> String
showTag XName L
n forall a. [a] -> [a] -> [a]
++
                   String
"' does not match closing tag '" forall a. [a] -> [a] -> [a]
++ forall {l}. XName l -> String
showTag XName L
m 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 forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ String
n'


-----------------------------------------------------------------------------
-- Miscellaneous utilities

checkPrec :: Integer -> P Int
checkPrec :: Integer -> P Int
checkPrec Integer
i | Integer
0 forall a. Ord a => a -> a -> Bool
<= Integer
i Bool -> Bool -> Bool
&& Integer
i forall a. Ord a => a -> a -> Bool
<= Integer
9 = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Num a => Integer -> a
fromInteger Integer
i)
            | Bool
otherwise        = forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Illegal precedence " forall a. [a] -> [a] -> [a]
++ 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       = forall (m :: * -> *) a. Monad m => a -> m a
return (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]
_) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> PExp l -> [PFieldUpdate l] -> PExp l
RecUpdate (forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PExp L
e) PExp L
e [PFieldUpdate L]
fs)
mkRecConstrOrUpdate PExp L
_         [PFieldUpdate L]
_        = 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) = 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)  = forall l. l -> Name l -> QName l
UnQual l
l Name l
n
updateQNameLoc l
l (Special l
_ SpecialCon l
s) = forall l. l -> SpecialCon l -> QName l
Special l
l SpecialCon l
s

-----------------------------------------------------------------------------
-- For standalone top level Decl parser, check that we actually only
-- parsed one Decl. This is needed since we parse matches of the same
-- FunBind as multiple separate declarations, and merge them after.
-- This should be called *after* checkRevDecls.

checkSingleDecl :: [Decl L] -> P (Decl L)
checkSingleDecl :: [Decl L] -> P (Decl L)
checkSingleDecl [Decl L
d] = forall (m :: * -> *) a. Monad m => a -> m a
return Decl L
d
checkSingleDecl [Decl L]
ds =
    forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Expected a single declaration, found " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Decl L]
ds)


-- Reverse a list of declarations, merging adjacent FunBinds of the
-- same name and checking that their arities match.

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 [] = 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 = 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' forall (a :: * -> *) l1 l2.
(Annotated a, Eq (a ())) =>
a l1 -> a l2 -> Bool
=~= Name L
name = do
            Bool
ignoreArity <- P Bool
getIgnoreFunctionArity
            if forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat L]
ps' forall a. Eq a => a -> a -> Bool
== Int
arity Bool -> Bool -> Bool
|| Bool
ignoreArity
              then [Match L] -> [Decl L] -> L -> P [Decl L]
mergeMatches ([Match L]
msforall a. [a] -> [a] -> [a]
++[Match L]
ms') [Decl L]
ds (L
loc L -> L -> L
<++> L
l)
              else forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"arity mismatch for '" forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyPrint Name L
name forall a. [a] -> [a] -> [a]
++ String
"'")
                    forall a. P a -> SrcLoc -> P a
`atSrcLoc` forall si. SrcInfo si => L -> si
fromSrcInfo L
loc
        mergeMatches [Match L]
ms' [Decl L]
ds L
l = [Decl L] -> [Decl L] -> P [Decl L]
mergeFunBinds (forall l. l -> [Match l] -> Decl l
FunBind L
l [Match L]
ms'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' 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]
imsforall 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 (forall l. l -> [Match l] -> Decl l
FunBind L
l [Match L]
ms'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
dforall 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 [] = 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 = 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' forall (a :: * -> *) l1 l2.
(Annotated a, Eq (a ())) =>
a l1 -> a l2 -> Bool
=~= Name L
name = do
            Bool
ignoreArity <- P Bool
getIgnoreFunctionArity
            if forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat L]
ps' forall a. Eq a => a -> a -> Bool
== Int
arity Bool -> Bool -> Bool
|| Bool
ignoreArity
              then [Match L] -> [ClassDecl L] -> L -> P [ClassDecl L]
mergeMatches ([Match L]
msforall a. [a] -> [a] -> [a]
++[Match L]
ms') [ClassDecl L]
ds (L
loc L -> L -> L
<++> L
l)
              else forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"arity mismatch for '" forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyPrint Name L
name forall a. [a] -> [a] -> [a]
++ String
"'")
                    forall a. P a -> SrcLoc -> P a
`atSrcLoc` forall si. SrcInfo si => L -> si
fromSrcInfo L
loc
        mergeMatches [Match L]
ms' [ClassDecl L]
ds L
l = [ClassDecl L] -> [ClassDecl L] -> P [ClassDecl L]
mergeClsFunBinds (forall l. l -> Decl l -> ClassDecl l
ClsDecl L
l (forall l. l -> [Match l] -> Decl l
FunBind L
l [Match L]
ms')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' 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]
imsforall 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 (forall l. l -> Decl l -> ClassDecl l
ClsDecl L
l (forall l. l -> [Match l] -> Decl l
FunBind L
l [Match L]
ms')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
dforall 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 [] = 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 = 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' forall (a :: * -> *) l1 l2.
(Annotated a, Eq (a ())) =>
a l1 -> a l2 -> Bool
=~= Name L
name = do
            Bool
ignoreArity <- P Bool
getIgnoreFunctionArity
            if forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat L]
ps' forall a. Eq a => a -> a -> Bool
== Int
arity Bool -> Bool -> Bool
|| Bool
ignoreArity
              then [Match L] -> [InstDecl L] -> L -> P [InstDecl L]
mergeMatches ([Match L]
msforall a. [a] -> [a] -> [a]
++[Match L]
ms') [InstDecl L]
ds (L
loc L -> L -> L
<++> L
l)
              else forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"arity mismatch for '" forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyPrint Name L
name forall a. [a] -> [a] -> [a]
++ String
"'")
                    forall a. P a -> SrcLoc -> P a
`atSrcLoc` forall si. SrcInfo si => L -> si
fromSrcInfo L
loc
        mergeMatches [Match L]
ms' [InstDecl L]
ds L
l = [InstDecl L] -> [InstDecl L] -> P [InstDecl L]
mergeInstFunBinds (forall l. l -> Decl l -> InstDecl l
InsDecl L
l (forall l. l -> [Match l] -> Decl l
FunBind L
l [Match L]
ms')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' 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]
imsforall 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 (forall l. l -> Decl l -> InstDecl l
InsDecl L
l (forall l. l -> [Match l] -> Decl l
FunBind L
l [Match L]
ms')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
dforall a. a -> [a] -> [a]
:[InstDecl L]
revDs) [InstDecl L]
ds

----------------------------------------------------------------
-- Check that newtype declarations have
-- the right number (1) of constructors

checkDataOrNew :: DataOrNew L -> [QualConDecl L] -> P ()
checkDataOrNew :: DataOrNew L -> [QualConDecl L] -> P ()
checkDataOrNew (DataType L
_) [QualConDecl L]
_  = forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkDataOrNew (NewType L
_) [QualConDecl L
_ Maybe [TyVarBind L]
_ Maybe (Context L)
_ ConDecl L
x] = forall {m :: * -> *} {l}. MonadFail m => ConDecl l -> m ()
cX ConDecl L
x forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where cX :: ConDecl l -> m ()
cX (ConDecl l
_ Name l
_ [Type l
_]) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
        cX (RecDecl l
_ Name l
_ [FieldDecl l
_]) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
        cX ConDecl l
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"newtype declaration constructor must have exactly one parameter."
checkDataOrNew DataOrNew L
_        [QualConDecl L]
_  = 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]
_  = forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkDataOrNewG (NewType L
_) [GadtDecl L
_] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkDataOrNewG DataOrNew L
_        [GadtDecl L]
_  = 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"

---------------------------------------
-- Check actual types

-- | Add a strictness/unpack annotation on a type.
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) -> forall l. l -> BangType l -> Unpackedness l -> PType l -> PType l
TyBang (forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Unpackedness L
upack L -> L -> L
<++> forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PType L
ty) (forall l. l -> BangType l
NoStrictAnnot L
noSrcSpan) Unpackedness L
upack PType L
ty
    (Just (L -> BangType L
strict, SrcSpan
pos), Maybe (Unpackedness L)
_)  ->
      forall l. l -> BangType l -> Unpackedness l -> PType l -> PType l
TyBang (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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
<++> forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PType L
ty) (L -> BangType L
strict (SrcSpan -> L
noInfoSpan SrcSpan
pos))
        (forall a. a -> Maybe a -> a
fromMaybe (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
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
simple forall a b. (a -> b) -> a -> b
$ forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
ExplicitForAll
            Maybe (Context L)
ctxt <- Maybe (PContext L) -> P (Maybe (Context L))
checkContext Maybe (PContext L)
cs
            PType L -> (Type L -> Type L) -> P (Type L)
check1Type PType L
pt (forall l.
l -> Maybe [TyVarBind l] -> Maybe (Context l) -> Type l -> Type l
S.TyForall L
l forall a. Maybe a
Nothing Maybe (Context L)
ctxt)
    TyForall L
l Maybe [TyVarBind L]
tvs Maybe (PContext L)
cs PType L
pt -> do
            forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
ExplicitForAll
            Maybe (Context L)
ctxt <- Maybe (PContext L) -> P (Maybe (Context L))
checkContext Maybe (PContext L)
cs
            PType L -> (Type L -> Type L) -> P (Type L)
check1Type PType L
pt (forall l.
l -> Maybe [TyVarBind l] -> Maybe (Context l) -> Type l -> Type l
S.TyForall L
l Maybe [TyVarBind L]
tvs Maybe (Context L)
ctxt)
    TyStar  L
l         -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 (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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (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 (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 (forall l. l -> Type l -> Type l -> Type l
S.TyApp L
l)
    TyVar   L
l Name L
n       -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 (forall l. l -> Type l -> Type l
S.TyParen L
l)
    -- Here we know that t will be used as an actual type (and not a data constructor)
    -- so we can check that TypeOperators are enabled.
    TyInfix L
l PType L
at MaybePromotedName L
op PType L
bt -> QName L -> P ()
checkAndWarnTypeOperators (forall l. MaybePromotedName l -> QName l
getMaybePromotedQName MaybePromotedName L
op)
                           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 (forall a b c. (a -> b -> c) -> b -> a -> c
flip (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 (forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall l. l -> Type l -> Type l -> Type l
S.TyKind L
l) Type L
k)

    TyPromoted L
l Promoted L
p -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 (forall l. l -> Type l -> Type l -> Type l
S.TyEquals L
l)
    TySplice L
l Splice L
s        -> do
                              forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
TemplateHaskell
                              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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' (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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> Maybe (Name l) -> Type l
S.TyWildCard L
l Maybe (Name L)
mn
    TyQuasiQuote L
l String
n String
s -> do
                              forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
QuasiQuotes
                              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> String -> String -> Type l
S.TyQuasiQuote L
l String
n String
s
    PType L
_   -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Parse error in type: " forall a. [a] -> [a] -> [a]
++ 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return 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 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type L
b -> 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 = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (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
  [KnownExtension]
e <- P [KnownExtension]
getExtensions
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    case Name L
n of
      Ident L
il (Char
'_':String
ident) | KnownExtension
NamedWildCards forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
e ->
        forall l. l -> Maybe (Name l) -> PType l
TyWildCard L
il (forall a. a -> Maybe a
Just (forall l. l -> String -> Name l
Ident (L -> L
reduceSrcSpanInfo L
il) String
ident))
      Name L
_ ->
        forall l. l -> Name l -> PType l
TyVar (forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Name L
n) Name L
n
  where
    -- Reduces the length of the SrcSpanInfo by 1 so that it just covers the identifier.
    reduceSrcSpanInfo :: L -> L
reduceSrcSpanInfo L
spaninfo =
      let ss :: SrcSpan
ss = L -> SrcSpan
srcInfoSpan L
spaninfo
          ss' :: SrcSpan
ss' = SrcSpan
ss { srcSpanStartColumn :: Int
srcSpanStartColumn = SrcSpan -> Int
srcSpanStartColumn SrcSpan
ss forall a. Num a => a -> a -> a
+ Int
1 }
      in  L
spaninfo { srcInfoSpan :: SrcSpan
srcInfoSpan = SrcSpan
ss' }
---------------------------------------
-- Check kinds

-- ConstraintKinds allow the kind "Constraint", but not "Nat", etc. Specifically
-- test for that.
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 | forall {l}. Name l -> Bool
constrKind Name l
q -> 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 forall a. Eq a => a -> a -> Bool
== String
"Constraint"
                    Name l
_                      -> Bool
False

        Kind l
_ -> forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
DataKinds

---------------------------------------
-- Converting a complete page

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
    String
mod <- P String
getModuleName
    Exp L
xml' <- PExp L -> P (Exp L)
checkExpr PExp L
xml
    case Exp L
xml' of
        S.XTag  L
l XName L
xn [XAttr L]
ats Maybe (Exp L)
mattr [Exp L]
cs -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 forall a. [a] -> [a] -> [a]
++ [SrcSpan]
ss)) (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    -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 forall a. [a] -> [a] -> [a]
++ [SrcSpan]
ss)) (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
_ -> 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
    Exp L
xml' <- PExp L -> P (Exp L)
checkExpr PExp L
xml
    case Exp L
xml' of
        S.XTag  L
l XName L
xn [XAttr L]
ats Maybe (Exp L)
mattr [Exp L]
cs -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 forall a. a -> [a] -> [a]
: L -> [SrcSpan]
srcInfoPoints L
inf forall a. [a] -> [a] -> [a]
++ SrcSpan
s2 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    -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 forall a. a -> [a] -> [a]
: L -> [SrcSpan]
srcInfoPoints L
inf forall a. [a] -> [a] -> [a]
++ SrcSpan
s2 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
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unexpected expression; tag is expected"
checkHybridModule PExp L
_ Module L
_ SrcSpan
_ SrcSpan
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Hybrid module expected"

---------------------------------------
-- Handle dash-identifiers

mkDVar :: [String] -> String
mkDVar :: [String] -> String
mkDVar = forall a. [a] -> [[a]] -> [a]
intercalate String
"-"

---------------------------------------
-- Combine adjacent for-alls.
--
-- A valid type must have one for-all at the top of the type, or of the fn arg types

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) -> 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)
_                                       -> 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

-- Make a role annotation

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 [Role L]
roles' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *} {l}.
MonadFail m =>
(Maybe String, l) -> m (Role l)
parse_role [(Maybe String, L)]
roles
       forall (m :: * -> *) a. Monad m => a -> m a
return (forall l. l -> QName l -> [Role l] -> Decl l
RoleAnnotDecl L
loc' QName L
tycon [Role L]
roles')
  where
    loc' :: L
loc' =
      case [(Maybe String, L)]
roles of
        [] -> (SrcSpan
l1 SrcSpan -> SrcSpan -> L
<^^> SrcSpan
l2 L -> 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
<++> forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann QName L
tycon L -> L -> L
<++> forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 L -> L -> L
(<++>) (forall a b. (a -> b) -> [a] -> [b]
map 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", forall l. l -> Role l
S.Phantom)
                     , (String
"representational", forall l. l -> Role l
S.Representational)
                     , (String
"nominal", forall l. l -> Role l
S.Nominal)]

    parse_role :: (Maybe String, l) -> m (Role l)
parse_role (Maybe String
Nothing, l
loc_role) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> Role l
S.RoleWildcard l
loc_role
    parse_role (Just String
role, l
loc_role)
      = case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
role forall {l}. [(String, l -> Role l)]
possible_roles of
          Just l -> Role l
found_role -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ l -> Role l
found_role l
loc_role
          Maybe (l -> Role l)
Nothing         ->
            forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Illegal role name " 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
    -- No additional information
    (Maybe (ResultSig L)
Nothing, Maybe (SrcSpan, Type L)
Nothing, Maybe (InjectivityInfo L)
Nothing) -> do
      DeclHead L
dh <- PType L -> P (DeclHead L)
checkSimpleType PType L
ty
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l.
l
-> DeclHead l
-> Maybe (ResultSig l)
-> Maybe (InjectivityInfo l)
-> ClassDecl l
ClsTyFam (SrcSpan -> L
noInfoSpan SrcSpan
tyloc L -> L -> L
<++> forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PType L
ty) DeclHead L
dh forall a. Maybe a
Nothing forall a. Maybe a
Nothing
    -- Type default
    (Maybe (ResultSig L)
_, Just (SrcSpan
eqloc, Type L
rhsty), Maybe (InjectivityInfo L)
Nothing) -> do
      Type L
ty' <- PType L -> P (Type L)
checkType PType L
ty
      let tyeq :: TypeEqn L
tyeq = forall l. l -> Type l -> Type l -> TypeEqn l
TypeEqn (forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PType L
ty L -> 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
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> TypeEqn l -> ClassDecl l
ClsTyDef (SrcSpan -> L
noInfoSpan SrcSpan
tyloc L -> L -> L
<++> forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PType L
ty L -> [SrcSpan] -> L
<** [SrcSpan
tyloc]) TypeEqn L
tyeq
    -- Declaration with kind sig
    (Just ResultSig L
ressig, Maybe (SrcSpan, Type L)
_, Maybe (InjectivityInfo L)
_) -> do
      DeclHead L
dh <- PType L -> P (DeclHead L)
checkSimpleType PType L
ty
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l.
l
-> DeclHead l
-> Maybe (ResultSig l)
-> Maybe (InjectivityInfo l)
-> ClassDecl l
ClsTyFam (SrcSpan -> L
noInfoSpan SrcSpan
tyloc L -> L -> L
<++> forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann ResultSig L
ressig L -> [SrcSpan] -> L
<** [SrcSpan
tyloc]) DeclHead L
dh (forall a. a -> Maybe a
Just ResultSig L
ressig) forall a. Maybe a
Nothing
    -- Decl with inj info
    (Maybe (ResultSig L)
Nothing, Just (SrcSpan
eqloc, Type L
rhsty), Just InjectivityInfo L
injinfo) -> do
      ResultSig L
ressig <- SrcSpan -> Type L -> P (ResultSig L)
checkKTyVar SrcSpan
eqloc Type L
rhsty
      DeclHead L
dh <- PType L -> P (DeclHead L)
checkSimpleType PType L
ty
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l.
l
-> DeclHead l
-> Maybe (ResultSig l)
-> Maybe (InjectivityInfo l)
-> ClassDecl l
ClsTyFam (SrcSpan -> L
noInfoSpan SrcSpan
tyloc L -> L -> L
<++> forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann InjectivityInfo L
injinfo L -> [SrcSpan] -> L
<** [SrcSpan
tyloc]) DeclHead L
dh (forall a. a -> Maybe a
Just ResultSig L
ressig) Maybe (InjectivityInfo L)
minj
    (Maybe (ResultSig L), Maybe (SrcSpan, Type L),
 Maybe (InjectivityInfo 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> TyVarBind l -> ResultSig l
TyVarSig (SrcSpan -> L
noInfoSpan SrcSpan
eqloc L -> L -> L
<++> L
l L -> [SrcSpan] -> L
<** [SrcSpan
eqloc]) (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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> TyVarBind l -> ResultSig l
TyVarSig (SrcSpan -> L
noInfoSpan SrcSpan
eqloc L -> L -> L
<++> L
l L -> [SrcSpan] -> L
<** [SrcSpan
eqloc]) (forall l. l -> Name l -> Kind l -> TyVarBind l
KindedVar L
l Name L
n Type L
k)
       Type L
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Result of type family must be a type variable")

-- | Transform btype with strict_mark's into HsEqTy's
-- (((~a) ~b) c) ~d ==> ((~a) ~ (b c)) ~ d
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
          = 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 ->
                forall l. l -> PType l -> PType l -> PType l
TyEquals (L
eqloc L -> 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 (forall l. l -> PType l -> PType l -> PType l
TyApp (forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PType L
tr L -> L -> L
<++> forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PType L
t2) PType L
tr PType L
t2)
              PType L
t' -> 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'

-- Expects the arguments in the right order
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
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall {l}. EWildcard l -> Bool
isWc EWildcard L
wc Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CName L]
cnames)) (forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
PatternSynonyms)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall l. l -> EWildcard l
NoWildcard L
noSrcSpan)
               (\(Int
n,Left SrcSpan
s) -> forall l. l -> Int -> EWildcard l
EWildcard (SrcSpan -> L
noInfoSpan SrcSpan
s) Int
n)
               (forall a. Int -> (a -> Bool) -> [a] -> Maybe (Int, a)
findWithIndex Int
0 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 = 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
_ [] = forall a. Maybe a
Nothing
    findWithIndex Int
n a -> Bool
p (a
x:[a]
xs)
      | a -> Bool
p a
x = forall a. a -> Maybe a
Just (Int
n, a
x)
      | Bool
otherwise = forall a. Int -> (a -> Bool) -> [a] -> Maybe (Int, a)
findWithIndex (Int
n 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) = forall (m :: * -> *) a. Monad m => a -> m a
return (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) =
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l. l -> Boxed -> [Maybe (PExp l)] -> PExp l
TupleSection L
s Boxed
boxity [Maybe (PExp L)]
ms
mkSumOrTuple Boxed
Boxed L
_s (SSum {}) = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Boxed sums are not implemented"