{-# 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) = QName l -> P (QName l)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return QName l
qn
pexprToQName (List l
l []) = QName l -> P (QName l)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName l -> P (QName l)) -> QName l -> P (QName l)
forall a b. (a -> b) -> a -> b
$ l -> SpecialCon l -> QName l
forall l. l -> SpecialCon l -> QName l
Special l
l (l -> SpecialCon l
forall l. l -> SpecialCon l
ListCon l
l)
pexprToQName PExp l
_ = [Char] -> P (QName l)
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail [Char]
"pexprToQName"

splitTyConApp :: PType L -> P (Name L, [S.Type L])
splitTyConApp :: PType L -> P (Name L, [Type L])
splitTyConApp PType L
t0 = do
            (n, pts) <- PType L -> [PType L] -> P (Name L, [PType L])
split PType L
t0 []
            ts <- mapM checkType pts
            return (n,ts)
 where
    split :: PType L -> [PType L] -> P (Name L, [PType L])
    split :: PType L -> [PType L] -> P (Name L, [PType L])
split (TyApp L
_ PType L
t PType L
u) [PType L]
ts = PType L -> [PType L] -> P (Name L, [PType L])
split PType L
t (PType L
uPType L -> [PType L] -> [PType L]
forall a. a -> [a] -> [a]
:[PType L]
ts)
    split (TyCon L
_ (UnQual L
_ Name L
t)) [PType L]
ts = (Name L, [PType L]) -> P (Name L, [PType L])
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name L
t,[PType L]
ts)
    split (TyInfix L
l PType L
a MaybePromotedName L
op PType L
b) [PType L]
ts = PType L -> [PType L] -> P (Name L, [PType L])
split (L -> QName L -> PType L
forall l. l -> QName l -> PType l
TyCon L
l (MaybePromotedName L -> QName L
forall l. MaybePromotedName l -> QName l
getMaybePromotedQName MaybePromotedName L
op)) (PType L
aPType L -> [PType L] -> [PType L]
forall a. a -> [a] -> [a]
:PType L
bPType L -> [PType L] -> [PType L]
forall a. a -> [a] -> [a]
:[PType L]
ts)
    split PType L
_ [PType L]
_ = [Char] -> P (Name L, [PType L])
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail [Char]
"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
    exts <- P [KnownExtension]
getExtensions
    unless (isEnabled e exts) $ fail errorMsg
 where errorMsg :: [Char]
errorMsg = [[Char]] -> [Char]
unwords
          [ e -> [Char]
forall a. Show a => a -> [Char]
show e
e
          , [Char]
"language extension is not enabled."
          , [Char]
"Please add {-# LANGUAGE " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ e -> [Char]
forall a. Show a => a -> [Char]
show e
e [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++  [Char]
" #-}"
          , [Char]
"pragma at the top of your module."
          ]

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

checkPatternGuards :: [Stmt L] -> P ()
checkPatternGuards :: [Stmt L] -> P ()
checkPatternGuards [Qualifier L
_ Exp L
_] = () -> P ()
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkPatternGuards [Stmt L]
_ = KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
PatternGuards

checkToplevel :: PExp t -> P ()
checkToplevel :: forall t. PExp t -> P ()
checkToplevel PExp t
e = do
    exts <- P [KnownExtension]
getExtensions
    let isQQ = case PExp t
e of
            QuasiQuote {} -> KnownExtension -> [KnownExtension] -> Bool
forall a. Enabled a => a -> [KnownExtension] -> Bool
isEnabled KnownExtension
QuasiQuotes [KnownExtension]
exts
            PExp t
_ -> Bool
False
    unless isQQ (checkEnabled TemplateHaskell)

-----------------------------------------------------------------------------
-- 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) =
    (PType L -> P (PAsst L)) -> [PType L] -> P [PAsst L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PType L -> P (PAsst L)
checkAssertion [PType L]
ts P [PAsst L] -> ([PAsst L] -> P (PContext L)) -> P (PContext L)
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PContext L -> P (PContext L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (PContext L -> P (PContext L))
-> ([PAsst L] -> PContext L) -> [PAsst L] -> P (PContext L)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> [PAsst L] -> PContext L
forall l. l -> [PAsst l] -> PContext l
CxTuple L
l
checkPContext (TyCon L
l (Special L
_ (UnitCon L
_))) =
    PContext L -> P (PContext L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (PContext L -> P (PContext L)) -> PContext L -> P (PContext L)
forall a b. (a -> b) -> a -> b
$ L -> PContext L
forall l. l -> PContext l
CxEmpty L
l
checkPContext (TyParen L
l PType L
t) = do
    c <- PType L -> P (PAsst L)
checkAssertion PType L
t
    return $ CxSingle l (ParenA l c)
checkPContext t :: PType L
t@(TyEquals L
tp PType L
_ PType L
_) = do
  [KnownExtension] -> P ()
forall e. (Show e, Enabled e) => [e] -> P ()
checkEnabledOneOf [KnownExtension
TypeFamilies, KnownExtension
GADTs]
  PContext L -> P (PContext L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (PContext L -> P (PContext L)) -> PContext L -> P (PContext L)
forall a b. (a -> b) -> a -> b
$ L -> PAsst L -> PContext L
forall l. l -> PAsst l -> PContext l
CxSingle L
tp (PAsst L -> PContext L) -> PAsst L -> PContext L
forall a b. (a -> b) -> a -> b
$ L -> PType L -> PAsst L
forall l. l -> PType l -> PAsst l
TypeA L
tp PType L
t

checkPContext PType L
t = do
    c <- PType L -> P (PAsst L)
checkAssertion PType L
t
    return $ CxSingle (ann c) c

------------------------------------------------------------------------------------------------------------------- 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
    asst' <- PType L -> P (PAsst L)
checkAssertion PType L
asst
    return $ ParenA l asst'
checkAssertion (TyPred L
_ PAsst L
p) = PAsst L -> P (PAsst L)
checkAAssertion PAsst L
p
-- 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
        t'' <- (L -> L) -> [PType L] -> PType L -> P (PType L)
checkAssertion' L -> L
forall a. a -> a
id [] PType L
t'
        return $ TypeA (ann t'') t''
    where   -- 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
_) = PType L -> P (PType L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return PType L
t
            checkAssertion' L -> L
fl [PType L]
ts (TyCon L
l QName L
c) = do
                Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([PType L] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PType L]
ts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1) (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$ KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
FlexibleContexts
                QName L -> P ()
checkAndWarnTypeOperators QName L
c
                PType L -> P (PType L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (PType L -> P (PType L)) -> PType L -> P (PType L)
forall a b. (a -> b) -> a -> b
$ L -> PType L -> [PType L] -> PType L
tyApps (L -> L
fl L
l) (L -> QName L -> PType L
forall l. l -> QName l -> PType l
TyCon (L -> L
fl L
l) QName L
c) [PType L]
ts
            checkAssertion' L -> L
fl [PType L]
ts (TyApp L
l PType L
a PType L
t) =
                -- no check on t at this stage
                (L -> L) -> [PType L] -> PType L -> P (PType L)
checkAssertion' (L -> L -> L
forall a b. a -> b -> a
const (L -> L
fl L
l)) (PType L
tPType L -> [PType L] -> [PType L]
forall a. a -> [a] -> [a]
:[PType L]
ts) PType L
a
            checkAssertion' L -> L
fl [PType L]
_ (TyInfix L
l PType L
a MaybePromotedName L
op PType L
b) = do
                -- infix operators require TypeOperators
                QName L -> P ()
checkAndWarnTypeOperators (MaybePromotedName L -> QName L
forall l. MaybePromotedName l -> QName l
getMaybePromotedQName MaybePromotedName L
op)
                PType L -> P (PType L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (PType L -> P (PType L)) -> PType L -> P (PType L)
forall a b. (a -> b) -> a -> b
$ L -> PType L -> MaybePromotedName L -> PType L -> PType L
forall l. l -> PType l -> MaybePromotedName l -> PType l -> PType l
TyInfix (L -> L
fl L
l) PType L
a MaybePromotedName L
op PType L
b
            checkAssertion' L -> L
fl [PType L]
ts (TyParen L
l PType L
t) =
                (L -> L) -> [PType L] -> PType L -> P (PType L)
checkAssertion' (L -> L -> L
forall a b. a -> b -> a
const (L -> L
fl L
l)) [PType L]
ts PType L
t
            checkAssertion' L -> L
fl [PType L]
ts (TyVar L
l Name L
t) = do -- Dict :: cxt => Dict cxt
                KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
ConstraintKinds
                PType L -> P (PType L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (PType L -> P (PType L)) -> PType L -> P (PType L)
forall a b. (a -> b) -> a -> b
$ L -> PType L -> [PType L] -> PType L
tyApps (L -> L
fl L
l) (L -> Name L -> PType L
forall l. l -> Name l -> PType l
TyVar (L -> L
fl L
l) Name L
t) [PType L]
ts
            checkAssertion' L -> L
_ [PType L]
_ t :: PType L
t@(TyWildCard L
_ Maybe (Name L)
_) = PType L -> P (PType L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return PType L
t
            checkAssertion' L -> L
_ [PType L]
_ PType L
t = do
                KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
QuantifiedConstraints -- anything goes
                PType L -> P (PType L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return PType L
t
            tyApps :: L -> PType L -> [PType L] -> PType L
            tyApps :: L -> PType L -> [PType L] -> PType L
tyApps L
_ PType L
c [] = PType L
c
            tyApps L
l PType L
c (PType L
a:[PType L]
aa) = L -> PType L -> [PType L] -> PType L
tyApps L
l (L -> PType L -> PType L -> PType L
forall l. l -> PType l -> PType l -> PType l
TyApp L
l PType L
c PType L
a) [PType L]
aa

checkAAssertion :: PAsst L -> P (PAsst L)
checkAAssertion :: PAsst L -> P (PAsst L)
checkAAssertion (TypeA L
_ PType L
t) = PType L -> P (PAsst L)
checkAssertion PType L
t
checkAAssertion (ParenA L
l PAsst L
a) = do
    a' <- PAsst L -> P (PAsst L)
checkAAssertion PAsst L
a
    return $ ParenA l a'
checkAAssertion PAsst L
p = PAsst L -> P (PAsst L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return PAsst L
p

-- Check class/instance declaration for multiparams
checkMultiParam :: PType L -> P ()
checkMultiParam :: PType L -> P ()
checkMultiParam = [PType L] -> PType L -> P ()
forall {l}. [PType l] -> PType l -> P ()
checkMultiParam' []
    where
        checkMultiParam' :: [PType l] -> PType l -> P ()
checkMultiParam' [PType l]
ts (TyCon l
_ QName l
_) =
            Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([PType l] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PType l]
ts Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1) (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$ KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
MultiParamTypeClasses
        checkMultiParam' [PType l]
ts (TyApp l
_ PType l
a PType l
t) = [PType l] -> PType l -> P ()
checkMultiParam' (PType l
tPType l -> [PType l] -> [PType l]
forall a. a -> [a] -> [a]
:[PType l]
ts) PType l
a
        checkMultiParam' [PType l]
_ (TyInfix l
_ PType l
_ MaybePromotedName l
_ PType l
_) = KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
MultiParamTypeClasses
        checkMultiParam' [PType l]
ts (TyParen l
_ PType l
t) = [PType l] -> PType l -> P ()
checkMultiParam' [PType l]
ts PType l
t
        checkMultiParam' [PType l]
_ PType l
_ = () -> P ()
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

getSymbol :: QName L -> Maybe String
getSymbol :: QName L -> Maybe [Char]
getSymbol (UnQual L
_ (Symbol L
_ [Char]
s)) = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
s
getSymbol (Qual L
_ ModuleName L
_ (Symbol L
_ [Char]
s)) = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
s
getSymbol QName L
_                       = Maybe [Char]
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 [Char]
getSymbol QName L
c of
        Just [Char]
s | [Char]
s [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"."  -> [KnownExtension] -> P ()
forall e. (Show e, Enabled e) => [e] -> P ()
checkEnabledOneOf [KnownExtension
ExplicitForAll, KnownExtension
TypeOperators]
               | Bool
otherwise -> KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
TypeOperators
        Maybe [Char]
Nothing -> () -> P ()
forall a. a -> P a
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 -> Maybe (Context L) -> P (Maybe (Context L))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Context L) -> P (Maybe (Context L)))
-> Maybe (Context L) -> P (Maybe (Context L))
forall a b. (a -> b) -> a -> b
$ Context L -> Maybe (Context L)
forall a. a -> Maybe a
Just (Context L -> Maybe (Context L)) -> Context L -> Maybe (Context L)
forall a b. (a -> b) -> a -> b
$ L -> Context L
forall l. l -> Context l
S.CxEmpty L
l
    CxSingle L
l PAsst L
a -> PAsst L -> P (Asst L)
checkAsst PAsst L
a P (Asst L)
-> (Asst L -> P (Maybe (Context L))) -> P (Maybe (Context L))
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (Context L) -> P (Maybe (Context L))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Context L) -> P (Maybe (Context L)))
-> (Asst L -> Maybe (Context L)) -> Asst L -> P (Maybe (Context L))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context L -> Maybe (Context L)
forall a. a -> Maybe a
Just (Context L -> Maybe (Context L))
-> (Asst L -> Context L) -> Asst L -> Maybe (Context L)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> Asst L -> Context L
forall l. l -> Asst l -> Context l
S.CxSingle L
l
    CxTuple L
l [PAsst L]
as -> (PAsst L -> P (Asst L)) -> [PAsst L] -> P [Asst L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PAsst L -> P (Asst L)
checkAsst [PAsst L]
as P [Asst L]
-> ([Asst L] -> P (Maybe (Context L))) -> P (Maybe (Context L))
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (Context L) -> P (Maybe (Context L))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Context L) -> P (Maybe (Context L)))
-> ([Asst L] -> Maybe (Context L))
-> [Asst L]
-> P (Maybe (Context L))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context L -> Maybe (Context L)
forall a. a -> Maybe a
Just (Context L -> Maybe (Context L))
-> ([Asst L] -> Context L) -> [Asst L] -> Maybe (Context L)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> [Asst L] -> Context L
forall l. l -> [Asst l] -> Context l
S.CxTuple L
l
checkSContext Maybe (PContext L)
_ = Maybe (Context L) -> P (Maybe (Context L))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Context L)
forall a. Maybe a
Nothing

-- 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 -> Maybe (Context L) -> P (Maybe (Context L))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Context L) -> P (Maybe (Context L)))
-> Maybe (Context L) -> P (Maybe (Context L))
forall a b. (a -> b) -> a -> b
$ Context L -> Maybe (Context L)
forall a. a -> Maybe a
Just (Context L -> Maybe (Context L)) -> Context L -> Maybe (Context L)
forall a b. (a -> b) -> a -> b
$ L -> Context L
forall l. l -> Context l
S.CxEmpty L
l
    CxSingle L
l PAsst L
a -> PAsst L -> P (Asst L)
checkAsst PAsst L
a P (Asst L)
-> (Asst L -> P (Maybe (Context L))) -> P (Maybe (Context L))
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (Context L) -> P (Maybe (Context L))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Context L) -> P (Maybe (Context L)))
-> (Asst L -> Maybe (Context L)) -> Asst L -> P (Maybe (Context L))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context L -> Maybe (Context L)
forall a. a -> Maybe a
Just (Context L -> Maybe (Context L))
-> (Asst L -> Context L) -> Asst L -> Maybe (Context L)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> Asst L -> Context L
forall l. l -> Asst l -> Context l
S.CxSingle L
l
    CxTuple L
l [PAsst L]
as -> (PAsst L -> P (Asst L)) -> [PAsst L] -> P [Asst L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PAsst L -> P (Asst L)
checkAsst [PAsst L]
as P [Asst L]
-> ([Asst L] -> P (Maybe (Context L))) -> P (Maybe (Context L))
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (Context L) -> P (Maybe (Context L))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Context L) -> P (Maybe (Context L)))
-> ([Asst L] -> Maybe (Context L))
-> [Asst L]
-> P (Maybe (Context L))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context L -> Maybe (Context L)
forall a. a -> Maybe a
Just (Context L -> Maybe (Context L))
-> ([Asst L] -> Context L) -> [Asst L] -> Maybe (Context L)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> [Asst L] -> Context L
forall l. l -> [Asst l] -> Context l
S.CxTuple L
l
checkContext Maybe (PContext L)
_ = Maybe (Context L) -> P (Maybe (Context L))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Context L)
forall a. Maybe a
Nothing

checkAsst :: PAsst L -> P (S.Asst L)
checkAsst :: PAsst L -> P (Asst L)
checkAsst PAsst L
asst =
    case PAsst L
asst of
      TypeA L
l PType L
pt -> do
                t <- PType L -> P (Type L)
checkType PType L
pt
                return $ S.TypeA l t
      IParam L
l IPName L
ipn PType L
pt -> do
                t <- PType L -> P (Type L)
checkType PType L
pt
                return $ S.IParam l ipn t
      ParenA L
l PAsst L
a      -> do
                a' <- PAsst L -> P (Asst L)
checkAsst PAsst L
a
                return $ S.ParenA l a'

-----------------------------------------------------------------------------
-- 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
    dh <- [Char] -> PType L -> P (DeclHead L)
checkSimple [Char]
"data/newtype" PType L
t
    cs' <- checkContext cs
    return (cs',dh)
checkDataHeader PType L
t = do
    dh <- [Char] -> PType L -> P (DeclHead L)
checkSimple [Char]
"data/newtype" PType L
t
    return (Nothing,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
    dh <- [Char] -> PType L -> P (DeclHead L)
checkSimple [Char]
"class" PType L
t
    cs' <- checkSContext cs
    return (cs',dh)
checkClassHeader PType L
t = do
    PType L -> P ()
checkMultiParam PType L
t
    dh <- [Char] -> PType L -> P (DeclHead L)
checkSimple [Char]
"class" PType L
t
    return (Nothing,dh)

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

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

mkTyVarBind :: String -> PType L -> P (TyVarBind L)
mkTyVarBind :: [Char] -> PType L -> P (TyVarBind L)
mkTyVarBind [Char]
_ (TyVar L
l Name L
n) = TyVarBind L -> P (TyVarBind L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyVarBind L -> P (TyVarBind L)) -> TyVarBind L -> P (TyVarBind L)
forall a b. (a -> b) -> a -> b
$ L -> Name L -> TyVarBind L
forall l. l -> Name l -> TyVarBind l
UnkindedVar L
l Name L
n
mkTyVarBind [Char]
_ (TyKind L
l (TyVar L
_ Name L
n) Type L
k) = TyVarBind L -> P (TyVarBind L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyVarBind L -> P (TyVarBind L)) -> TyVarBind L -> P (TyVarBind L)
forall a b. (a -> b) -> a -> b
$ L -> Name L -> Type L -> TyVarBind L
forall l. l -> Name l -> Kind l -> TyVarBind l
KindedVar L
l Name L
n Type L
k
mkTyVarBind [Char]
_ (TyCon L
l c :: QName L
c@(UnQual L
_ n :: Name L
n@(Symbol L
_ [Char]
_))) = QName L -> P ()
checkAndWarnTypeOperators QName L
c P () -> P (TyVarBind L) -> P (TyVarBind L)
forall a b. P a -> P b -> P b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TyVarBind L -> P (TyVarBind L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Name L -> TyVarBind L
forall l. l -> Name l -> TyVarBind l
UnkindedVar L
l Name L
n)
mkTyVarBind [Char]
_ (TyKind L
l (TyCon L
_ c :: QName L
c@(UnQual L
_ n :: Name L
n@(Symbol L
_ [Char]
_))) Type L
k) = QName L -> P ()
checkAndWarnTypeOperators QName L
c P () -> P (TyVarBind L) -> P (TyVarBind L)
forall a b. P a -> P b -> P b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TyVarBind L -> P (TyVarBind L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Name L -> Type L -> TyVarBind L
forall l. l -> Name l -> Kind l -> TyVarBind l
KindedVar L
l Name L
n Type L
k)
mkTyVarBind [Char]
kw PType L
_ = [Char] -> P (TyVarBind L)
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail ([Char]
"Illegal " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
kw [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" 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 P (InstRule L) -> (InstRule L -> P (InstRule L)) -> P (InstRule L)
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InstRule L -> P (InstRule L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstRule L -> P (InstRule L))
-> (InstRule L -> InstRule L) -> InstRule L -> P (InstRule L)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> InstRule L -> InstRule L
forall l. l -> InstRule l -> InstRule l
IParen L
l
checkInstHeader (TyForall L
l Maybe [TyVarBind L]
mtvs Maybe (PContext L)
cs PType L
t) = do
    cs' <- Maybe (PContext L) -> P (Maybe (Context L))
checkSContext Maybe (PContext L)
cs
    checkMultiParam t
    checkInsts (Just l) mtvs cs' t
checkInstHeader PType L
t = PType L -> P ()
checkMultiParam PType L
t P () -> P (InstRule L) -> P (InstRule L)
forall a b. P a -> P b -> P b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe L
-> Maybe [TyVarBind L]
-> Maybe (Context L)
-> PType L
-> P (InstRule L)
checkInsts Maybe L
forall a. Maybe a
Nothing Maybe [TyVarBind L]
forall a. Maybe a
Nothing Maybe (Context L)
forall a. Maybe a
Nothing PType L
t


checkInsts :: Maybe L -> Maybe [TyVarBind L] -> Maybe (S.Context L) -> PType L -> P (InstRule L)
checkInsts :: Maybe L
-> Maybe [TyVarBind L]
-> Maybe (Context L)
-> PType L
-> P (InstRule L)
checkInsts Maybe L
_ Maybe [TyVarBind L]
mtvs Maybe (Context L)
mctxt (TyParen L
l PType L
t) = Maybe L
-> Maybe [TyVarBind L]
-> Maybe (Context L)
-> PType L
-> P (InstRule L)
checkInsts Maybe L
forall a. Maybe a
Nothing Maybe [TyVarBind L]
mtvs Maybe (Context L)
mctxt PType L
t P (InstRule L) -> (InstRule L -> P (InstRule L)) -> P (InstRule L)
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InstRule L -> P (InstRule L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstRule L -> P (InstRule L))
-> (InstRule L -> InstRule L) -> InstRule L -> P (InstRule L)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> InstRule L -> InstRule L
forall l. l -> InstRule l -> InstRule l
IParen L
l
checkInsts Maybe L
l1 Maybe [TyVarBind L]
mtvs Maybe (Context L)
mctxt PType L
t = do
    t' <- PType L -> P (InstHead L)
checkInstsGuts PType L
t
    return $ IRule (fromMaybe (fmap ann mctxt <?+> ann t') l1) mtvs mctxt t'

checkInstsGuts :: PType L -> P (InstHead L)
checkInstsGuts :: PType L -> P (InstHead L)
checkInstsGuts (TyApp L
l PType L
h PType L
t) = do
    t' <- PType L -> P (Type L)
checkType PType L
t
    h' <- checkInstsGuts h
    return $ IHApp l h' t'
checkInstsGuts (TyCon L
l QName L
c) = do
    QName L -> P ()
checkAndWarnTypeOperators QName L
c
    InstHead L -> P (InstHead L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstHead L -> P (InstHead L)) -> InstHead L -> P (InstHead L)
forall a b. (a -> b) -> a -> b
$ L -> QName L -> InstHead L
forall l. l -> QName l -> InstHead l
IHCon L
l QName L
c
checkInstsGuts (TyInfix L
l PType L
a MaybePromotedName L
op PType L
b) = do
    QName L -> P ()
checkAndWarnTypeOperators (MaybePromotedName L -> QName L
forall l. MaybePromotedName l -> QName l
getMaybePromotedQName MaybePromotedName L
op)
    [ta,tb] <- [PType L] -> P [Type L]
checkTypes [PType L
a,PType L
b]
    return $ IHApp l (IHInfix l ta (getMaybePromotedQName op)) tb
checkInstsGuts (TyParen L
l PType L
t) = PType L -> P (InstHead L)
checkInstsGuts PType L
t P (InstHead L) -> (InstHead L -> P (InstHead L)) -> P (InstHead L)
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InstHead L -> P (InstHead L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstHead L -> P (InstHead L))
-> (InstHead L -> InstHead L) -> InstHead L -> P (InstHead L)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> InstHead L -> InstHead L
forall l. l -> InstHead l -> InstHead l
IHParen L
l
checkInstsGuts PType L
_ = [Char] -> P (InstHead L)
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail [Char]
"Illegal instance declaration"

checkDeriving :: [PType L] -> P [InstRule L]
checkDeriving :: [PType L] -> P [InstRule L]
checkDeriving = (PType L -> P (InstRule L)) -> [PType L] -> P [InstRule L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Maybe L
-> Maybe [TyVarBind L]
-> Maybe (Context L)
-> PType L
-> P (InstRule L)
checkInsts Maybe L
forall a. Maybe a
Nothing Maybe [TyVarBind L]
forall a. Maybe a
Nothing Maybe (Context L)
forall a. Maybe a
Nothing)

-----------------------------------------------------------------------------
-- 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' = (L -> L -> L) -> L -> [L] -> L
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl L -> L -> L
combSpanInfo L
l ((Pat L -> L) -> [Pat L] -> [L]
forall a b. (a -> b) -> [a] -> [b]
map Pat L -> L
forall l. Pat l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann [Pat L]
args)
  Pat L -> P (Pat L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> QName L -> [Pat L] -> Pat L
forall l. l -> QName l -> [Pat l] -> Pat l
PApp L
l' QName L
c [Pat L]
args)
checkPat (App L
_ PExp L
f PExp L
x) [Pat L]
args = do
    x' <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
x []
    checkPat f (x':args)
checkPat (InfixApp L
_ PExp L
l QOp L
op PExp L
r) [Pat L]
args
    | QOp L
op QOp L -> QOp () -> Bool
forall (a :: * -> *) l1 l2.
(Annotated a, Eq (a ())) =>
a l1 -> a l2 -> Bool
=~= () -> QName () -> QOp ()
forall l. l -> QName l -> QOp l
QVarOp () (() -> Name () -> QName ()
forall l. l -> Name l -> QName l
UnQual () (() -> [Char] -> Name ()
forall l. l -> [Char] -> Name l
Symbol () [Char]
"!")) = do
        -- We must have BangPatterns on
        KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
BangPatterns
        let (PExp L
e,[PExp L]
es) = PExp L -> [PExp L] -> (PExp L, [PExp L])
splitBang PExp L
r []
        ps <- (PExp L -> P (Pat L)) -> [PExp L] -> P [Pat L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PExp L -> P (Pat L)
checkPattern (L -> PExp L -> PExp L
forall l. l -> PExp l -> PExp l
BangPat (QOp L -> L
forall l. QOp l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann QOp L
op) PExp L
ePExp L -> [PExp L] -> [PExp L]
forall a. a -> [a] -> [a]
:[PExp L]
es)
        checkPat l (ps++args)
checkPat PExp L
e' [] = case PExp L
e' of
    Var L
_ (UnQual L
l Name L
x)   -> Pat L -> P (Pat L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Name L -> Pat L
forall l. l -> Name l -> Pat l
PVar L
l Name L
x)
    Var L
_ (Special L
l (ExprHole L
_)) -> Pat L -> P (Pat L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Pat L
forall l. l -> Pat l
PWildCard L
l)
    Lit L
l Literal L
lit            -> Pat L -> P (Pat L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Sign L -> Literal L -> Pat L
forall l. l -> Sign l -> Literal l -> Pat l
PLit L
l (L -> Sign L
forall l. l -> Sign l
Signless L
l2) Literal L
lit)
            where l2 :: L
l2 = SrcSpan -> L
noInfoSpan (SrcSpan -> L) -> (L -> SrcSpan) -> L -> L
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> SrcSpan
srcInfoSpan (L -> L) -> L -> L
forall a b. (a -> b) -> a -> b
$ L
l
    InfixApp L
loc PExp L
l QOp L
op PExp L
r  ->
        case QOp L
op of
            QConOp L
_ QName L
c -> do
                    l' <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
l []
                    r' <- checkPat r []
                    return (PInfixApp loc l' c r')
            QVarOp L
ppos (UnQual L
_ (Symbol L
_ [Char]
"+")) -> do
                    KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
NPlusKPatterns
                    case (PExp L
l,PExp L
r) of
                        (Var L
_ (UnQual L
_ n :: Name L
n@(Ident L
_ [Char]
_)), Lit L
_ (Int L
kpos Integer
k [Char]
_)) -> do
                            let pp :: SrcSpan
pp = L -> SrcSpan
srcInfoSpan L
ppos
                                kp :: SrcSpan
kp = L -> SrcSpan
srcInfoSpan L
kpos
                            Pat L -> P (Pat L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Name L -> Integer -> Pat L
forall l. l -> Name l -> Integer -> Pat l
PNPlusK (L
loc L -> [SrcSpan] -> L
<** [SrcSpan
pp,SrcSpan
kp]) Name L
n Integer
k)
                        (PExp L, PExp L)
_ -> [Char] -> P (Pat L)
forall a. [Char] -> P a
patFail [Char]
""
            QOp L
_ -> [Char] -> P (Pat L)
forall a. [Char] -> P a
patFail [Char]
""
    TupleSection L
l Boxed
bx [Maybe (PExp L)]
mes    ->
            if Maybe (PExp L)
forall a. Maybe a
Nothing Maybe (PExp L) -> [Maybe (PExp L)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Maybe (PExp L)]
mes
             then do ps <- (PExp L -> P (Pat L)) -> [PExp L] -> P [Pat L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\PExp L
e -> PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []) ((Maybe (PExp L) -> PExp L) -> [Maybe (PExp L)] -> [PExp L]
forall a b. (a -> b) -> [a] -> [b]
map Maybe (PExp L) -> PExp L
forall a. HasCallStack => Maybe a -> a
fromJust [Maybe (PExp L)]
mes)
                     return (PTuple l bx ps)
             else [Char] -> P (Pat L)
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail [Char]
"Illegal tuple section in pattern"
    UnboxedSum L
l Int
b Int
a PExp L
e ->
      L -> Int -> Int -> Pat L -> Pat L
forall l. l -> Int -> Int -> Pat l -> Pat l
PUnboxedSum L
l Int
b Int
a (Pat L -> Pat L) -> P (Pat L) -> P (Pat L)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PExp L -> P (Pat L)
checkPattern PExp L
e

    List L
l [PExp L]
es      -> do
                  ps <- (PExp L -> P (RPat L)) -> [PExp L] -> P [RPat L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PExp L -> P (RPat L)
checkRPattern [PExp L]
es
                  if all isStdPat ps
                    then return . PList l $ map stripRP ps
                    -- we don't allow truly regular patterns unless the extension is enabled
                    else checkEnabled RegularPatterns >> return (PRPat l $ map fixRPOpPrec ps)
            where isStdPat :: RPat L -> Bool
                  isStdPat :: RPat L -> Bool
isStdPat (RPPat L
_ Pat L
_) = Bool
True
                  isStdPat (RPAs L
_ Name L
_ RPat L
p) = RPat L -> Bool
isStdPat RPat L
p
                  isStdPat (RPParen L
_ RPat L
p) = RPat L -> Bool
isStdPat RPat L
p
                  isStdPat RPat L
_           = Bool
False
                  stripRP :: RPat L -> Pat L
                  stripRP :: RPat L -> Pat L
stripRP (RPPat  L
_ Pat L
p) = Pat L
p
                  stripRP (RPAs L
l' Name L
n RPat L
p) = L -> Name L -> Pat L -> Pat L
forall l. l -> Name l -> Pat l -> Pat l
PAsPat L
l' Name L
n (RPat L -> Pat L
stripRP RPat L
p)
                  stripRP (RPParen L
l' RPat L
p) = L -> Pat L -> Pat L
forall l. l -> Pat l -> Pat l
PParen L
l' (RPat L -> Pat L
stripRP RPat L
p)
                  stripRP RPat L
_           = [Char] -> Pat L
forall a. HasCallStack => [Char] -> a
error [Char]
"cannot strip RP wrapper if not all patterns are base"

    Paren L
l PExp L
e      -> do
                  p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
                  return (PParen l p)
    AsPat L
l Name L
n PExp L
e    -> do
                  p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
                  return (PAsPat l n p)
    WildCard L
l   -> Pat L -> P (Pat L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Pat L
forall l. l -> Pat l
PWildCard L
l)
    IrrPat L
l PExp L
e   -> do
                  p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
                  return (PIrrPat l p)
    ViewPat L
l PExp L
e Pat L
p  -> do
                  e1 <- PExp L -> P (Exp L)
checkExpr PExp L
e
                  return (PViewPat l e1 p)
    RecConstr L
l QName L
c [PFieldUpdate L]
fs   -> do
                  fs' <- (PFieldUpdate L -> P (PatField L))
-> [PFieldUpdate L] -> P [PatField L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PFieldUpdate L -> P (PatField L)
checkPatField [PFieldUpdate L]
fs
                  return (PRec l c fs')
    NegApp L
l (Lit L
_ Literal L
lit) ->
                  let siSign :: SrcSpan
siSign = [SrcSpan] -> SrcSpan
forall a. HasCallStack => [a] -> a
last ([SrcSpan] -> SrcSpan) -> (L -> [SrcSpan]) -> L -> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> [SrcSpan]
srcInfoPoints (L -> SrcSpan) -> L -> SrcSpan
forall a b. (a -> b) -> a -> b
$ L
l
                      lSign :: L
lSign = SrcSpan -> [SrcSpan] -> L
infoSpan SrcSpan
siSign [SrcSpan
siSign]
                  in do
                    Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> (Literal L -> Bool) -> Literal L -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Literal L -> Bool
forall a. Literal a -> Bool
isNegatableLiteral (Literal L -> Bool) -> Literal L -> Bool
forall a b. (a -> b) -> a -> b
$ Literal L
lit) ([Char] -> P ()
forall a. [Char] -> P a
patFail ([Char] -> P ()) -> [Char] -> P ()
forall a b. (a -> b) -> a -> b
$ PExp L -> [Char]
forall a. Pretty a => a -> [Char]
prettyPrint PExp L
e')
                    Pat L -> P (Pat L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Sign L -> Literal L -> Pat L
forall l. l -> Sign l -> Literal l -> Pat l
PLit L
l (L -> Sign L
forall l. l -> Sign l
Negative L
lSign) Literal L
lit)
    ExpTypeSig L
l PExp L
e Type L
t -> do
                  -- patterns cannot have signatures unless ScopedTypeVariables is enabled.
                  KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
ScopedTypeVariables
                  p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
                  return (PatTypeSig l p t)

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

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

    -- BangPatterns
    BangPat L
l PExp L
e -> do
        p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
        return $ PBangPat l p

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

    PExp L
e -> [Char] -> P (Pat L)
forall a. [Char] -> P a
patFail ([Char] -> P (Pat L)) -> [Char] -> P (Pat L)
forall a b. (a -> b) -> a -> b
$ PExp L -> [Char]
forall a. Pretty a => a -> [Char]
prettyPrint PExp L
e

checkPat PExp L
e [Pat L]
_ = [Char] -> P (Pat L)
forall a. [Char] -> P a
patFail ([Char] -> P (Pat L)) -> [Char] -> P (Pat L)
forall a b. (a -> b) -> a -> b
$ PExp L -> [Char]
forall a. Pretty a => a -> [Char]
prettyPrint PExp L
e

isNegatableLiteral :: Literal a -> Bool
isNegatableLiteral :: forall a. Literal a -> Bool
isNegatableLiteral (Int a
_ Integer
_ [Char]
_) = Bool
True
isNegatableLiteral (Frac a
_ Rational
_ [Char]
_) = Bool
True
isNegatableLiteral (PrimInt a
_ Integer
_ [Char]
_) = Bool
True
isNegatableLiteral (PrimFloat a
_ Rational
_ [Char]
_) = Bool
True
isNegatableLiteral (PrimDouble a
_ Rational
_ [Char]
_) = Bool
True
isNegatableLiteral Literal a
_ = Bool
False

splitBang :: PExp L -> [PExp L] -> (PExp L, [PExp L])
splitBang :: PExp L -> [PExp L] -> (PExp L, [PExp L])
splitBang (App L
_ PExp L
f PExp L
x) [PExp L]
es = PExp L -> [PExp L] -> (PExp L, [PExp L])
splitBang PExp L
f (PExp L
xPExp L -> [PExp L] -> [PExp L]
forall a. a -> [a] -> [a]
:[PExp L]
es)
splitBang PExp L
e [PExp L]
es = (PExp L
e, [PExp L]
es)

checkPatField :: PFieldUpdate L -> P (PatField L)
checkPatField :: PFieldUpdate L -> P (PatField L)
checkPatField (FieldUpdate L
l QName L
n PExp L
e) = do
    p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
    return (PFieldPat l n p)
checkPatField (FieldPun L
l QName L
n) = PatField L -> P (PatField L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> QName L -> PatField L
forall l. l -> QName l -> PatField l
PFieldPun L
l QName L
n)
checkPatField (FieldWildcard L
l) = PatField L -> P (PatField L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> PatField L
forall l. l -> PatField l
PFieldWildcard L
l)

checkPAttr :: ParseXAttr L -> P (PXAttr L)
checkPAttr :: ParseXAttr L -> P (PXAttr L)
checkPAttr (XAttr L
l XName L
n PExp L
v) = do p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
v []
                              return $ PXAttr l n p

patFail :: String -> P a
patFail :: forall a. [Char] -> P a
patFail [Char]
s = [Char] -> P a
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail ([Char] -> P a) -> [Char] -> P a
forall a b. (a -> b) -> a -> b
$ [Char]
"Parse error in pattern: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s

checkRPattern :: PExp L -> P (RPat L)
checkRPattern :: PExp L -> P (RPat L)
checkRPattern PExp L
e' = case PExp L
e' of
    SeqRP L
l [PExp L]
es -> do
        rps <- (PExp L -> P (RPat L)) -> [PExp L] -> P [RPat L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PExp L -> P (RPat L)
checkRPattern [PExp L]
es
        return $ RPSeq l rps
    PostOp L
l PExp L
e QOp L
op -> do
        rpop <- QOp L -> P (RPatOp L)
checkRPatOp QOp L
op
        rp   <- checkRPattern e
        return $ RPOp l rp rpop
    GuardRP L
l PExp L
e [Stmt L]
gs -> do
        rp <- PExp L -> P (Pat L)
checkPattern PExp L
e
        return $ RPGuard l rp gs
    EitherRP L
l PExp L
e1 PExp L
e2 -> do
        rp1 <- PExp L -> P (RPat L)
checkRPattern PExp L
e1
        rp2 <- checkRPattern e2
        return $ RPEither l rp1 rp2
    CAsRP L
l Name L
n PExp L
e -> do
        rp <- PExp L -> P (RPat L)
checkRPattern PExp L
e
        return $ RPCAs l n rp
    AsPat L
l Name L
n PExp L
e  -> do
        rp <- PExp L -> P (RPat L)
checkRPattern PExp L
e
        return $ RPAs l n rp
    Paren L
l PExp L
e -> do
        rp <- PExp L -> P (RPat L)
checkRPattern PExp L
e
        return $ RPParen l rp
    PExp L
_          -> do
        p <- PExp L -> P (Pat L)
checkPattern PExp L
e'
        return $ RPPat (ann p) p

checkRPatOp :: QOp L -> P (RPatOp L)
checkRPatOp :: QOp L -> P (RPatOp L)
checkRPatOp o :: QOp L
o@(QVarOp L
l (UnQual L
_ (Symbol L
_ [Char]
sym))) =
    case [Char]
sym of
     [Char]
"*"  -> RPatOp L -> P (RPatOp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (RPatOp L -> P (RPatOp L)) -> RPatOp L -> P (RPatOp L)
forall a b. (a -> b) -> a -> b
$ L -> RPatOp L
forall l. l -> RPatOp l
RPStar L
l
     [Char]
"*!" -> RPatOp L -> P (RPatOp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (RPatOp L -> P (RPatOp L)) -> RPatOp L -> P (RPatOp L)
forall a b. (a -> b) -> a -> b
$ L -> RPatOp L
forall l. l -> RPatOp l
RPStarG L
l
     [Char]
"+"  -> RPatOp L -> P (RPatOp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (RPatOp L -> P (RPatOp L)) -> RPatOp L -> P (RPatOp L)
forall a b. (a -> b) -> a -> b
$ L -> RPatOp L
forall l. l -> RPatOp l
RPPlus L
l
     [Char]
"+!" -> RPatOp L -> P (RPatOp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (RPatOp L -> P (RPatOp L)) -> RPatOp L -> P (RPatOp L)
forall a b. (a -> b) -> a -> b
$ L -> RPatOp L
forall l. l -> RPatOp l
RPPlusG L
l
     [Char]
"?"  -> RPatOp L -> P (RPatOp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (RPatOp L -> P (RPatOp L)) -> RPatOp L -> P (RPatOp L)
forall a b. (a -> b) -> a -> b
$ L -> RPatOp L
forall l. l -> RPatOp l
RPOpt L
l
     [Char]
"?!" -> RPatOp L -> P (RPatOp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (RPatOp L -> P (RPatOp L)) -> RPatOp L -> P (RPatOp L)
forall a b. (a -> b) -> a -> b
$ L -> RPatOp L
forall l. l -> RPatOp l
RPOptG L
l
     [Char]
_    -> QOp L -> P (RPatOp L)
forall a b. Pretty a => a -> P b
rpOpFail QOp L
o
checkRPatOp QOp L
o = QOp L -> P (RPatOp L)
forall a b. Pretty a => a -> P b
rpOpFail QOp L
o

rpOpFail :: Pretty a => a -> P b
rpOpFail :: forall a b. Pretty a => a -> P b
rpOpFail a
sym = [Char] -> P b
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail ([Char] -> P b) -> [Char] -> P b
forall a b. (a -> b) -> a -> b
$ [Char]
"Unrecognized regular pattern operator: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Pretty a => a -> [Char]
prettyPrint a
sym

fixRPOpPrec :: RPat L -> RPat L
fixRPOpPrec :: RPat L -> RPat L
fixRPOpPrec RPat L
rp' = case RPat L
rp' of
    RPOp L
l RPat L
rp RPatOp L
rpop      -> RPat L -> (RPat L -> RPat L) -> RPat L
fPrecOp RPat L
rp ((RPat L -> RPatOp L -> RPat L) -> RPatOp L -> RPat L -> RPat L
forall a b c. (a -> b -> c) -> b -> a -> c
flip (L -> RPat L -> RPatOp L -> RPat L
forall l. l -> RPat l -> RPatOp l -> RPat l
RPOp L
l) RPatOp L
rpop)
    RPEither L
l RPat L
rp1 RPat L
rp2  -> L -> RPat L -> RPat L -> RPat L
forall l. l -> RPat l -> RPat l -> RPat l
RPEither L
l (RPat L -> RPat L
fixRPOpPrec RPat L
rp1) (RPat L -> RPat L
fixRPOpPrec RPat L
rp2)
    RPSeq L
l [RPat L]
rps         -> L -> [RPat L] -> RPat L
forall l. l -> [RPat l] -> RPat l
RPSeq L
l ([RPat L] -> RPat L) -> [RPat L] -> RPat L
forall a b. (a -> b) -> a -> b
$ (RPat L -> RPat L) -> [RPat L] -> [RPat L]
forall a b. (a -> b) -> [a] -> [b]
map RPat L -> RPat L
fixRPOpPrec [RPat L]
rps
    RPCAs L
l Name L
n RPat L
rp        -> L -> Name L -> RPat L -> RPat L
forall l. l -> Name l -> RPat l -> RPat l
RPCAs L
l Name L
n (RPat L -> RPat L) -> RPat L -> RPat L
forall a b. (a -> b) -> a -> b
$ RPat L -> RPat L
fixRPOpPrec RPat L
rp
    RPAs L
l Name L
n RPat L
rp         -> L -> Name L -> RPat L -> RPat L
forall l. l -> Name l -> RPat l -> RPat l
RPAs L
l Name L
n (RPat L -> RPat L) -> RPat L -> RPat L
forall a b. (a -> b) -> a -> b
$ RPat L -> RPat L
fixRPOpPrec RPat L
rp
    RPParen L
l RPat L
rp        -> L -> RPat L -> RPat L
forall l. l -> RPat l -> RPat l
RPParen L
l (RPat L -> RPat L) -> RPat L -> RPat L
forall a b. (a -> b) -> a -> b
$ RPat L -> RPat L
fixRPOpPrec RPat L
rp
    RPat L
_                   -> RPat L
rp'

  where fPrecOp :: RPat L -> (RPat L -> RPat L) -> RPat L
        fPrecOp :: RPat L -> (RPat L -> RPat L) -> RPat L
fPrecOp (RPOp L
l RPat L
rp RPatOp L
rpop) RPat L -> RPat L
f = RPat L -> (RPat L -> RPat L) -> RPat L
fPrecOp RPat L
rp (RPat L -> RPat L
f (RPat L -> RPat L) -> (RPat L -> RPat L) -> RPat L -> RPat L
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RPat L -> RPatOp L -> RPat L) -> RPatOp L -> RPat L -> RPat L
forall a b c. (a -> b -> c) -> b -> a -> c
flip (L -> RPat L -> RPatOp L -> RPat L
forall l. l -> RPat l -> RPatOp l -> RPat l
RPOp L
l) RPatOp L
rpop)
        fPrecOp (RPCAs L
l Name L
n RPat L
rp) RPat L -> RPat L
f = RPat L -> (RPat L -> RPat L) -> (RPat L -> RPat L) -> RPat L
fPrecAs RPat L
rp RPat L -> RPat L
f (L -> Name L -> RPat L -> RPat L
forall l. l -> Name l -> RPat l -> RPat l
RPCAs L
l Name L
n)
        fPrecOp (RPAs  L
l Name L
n RPat L
rp) RPat L -> RPat L
f = RPat L -> (RPat L -> RPat L) -> (RPat L -> RPat L) -> RPat L
fPrecAs RPat L
rp RPat L -> RPat L
f (L -> Name L -> RPat L -> RPat L
forall l. l -> Name l -> RPat l -> RPat l
RPAs  L
l Name L
n)
        fPrecOp RPat L
rp RPat L -> RPat L
f = RPat L -> RPat L
f (RPat L -> RPat L) -> RPat L -> RPat L
forall a b. (a -> b) -> a -> b
$ RPat L -> RPat L
fixRPOpPrec RPat L
rp
        fPrecAs :: RPat L -> (RPat L -> RPat L) -> (RPat L -> RPat L) -> RPat L
        fPrecAs :: RPat L -> (RPat L -> RPat L) -> (RPat L -> RPat L) -> RPat L
fPrecAs (RPCAs L
l Name L
n RPat L
rp) RPat L -> RPat L
f RPat L -> RPat L
g = RPat L -> (RPat L -> RPat L) -> (RPat L -> RPat L) -> RPat L
fPrecAs RPat L
rp RPat L -> RPat L
f (RPat L -> RPat L
g (RPat L -> RPat L) -> (RPat L -> RPat L) -> RPat L -> RPat L
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> Name L -> RPat L -> RPat L
forall l. l -> Name l -> RPat l -> RPat l
RPCAs L
l Name L
n)
        fPrecAs (RPAs  L
l Name L
n RPat L
rp) RPat L -> RPat L
f RPat L -> RPat L
g = RPat L -> (RPat L -> RPat L) -> (RPat L -> RPat L) -> RPat L
fPrecAs RPat L
rp RPat L -> RPat L
f (RPat L -> RPat L
g (RPat L -> RPat L) -> (RPat L -> RPat L) -> RPat L -> RPat L
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> Name L -> RPat L -> RPat L
forall l. l -> Name l -> RPat l -> RPat l
RPAs  L
l Name L
n)
        fPrecAs RPat L
rp RPat L -> RPat L
f RPat L -> RPat L
g = RPat L -> RPat L
g (RPat L -> RPat L) -> (RPat L -> RPat L) -> RPat L -> RPat L
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RPat L -> RPat L
f (RPat L -> RPat L) -> RPat L -> RPat L
forall a b. (a -> b) -> a -> b
$ RPat L -> RPat L
fixRPOpPrec RPat L
rp


mkChildrenPat :: [Pat L] -> [Pat L]
mkChildrenPat :: [Pat L] -> [Pat L]
mkChildrenPat [Pat L]
ps' = [Pat L] -> [Pat L] -> [Pat L]
mkCPAux [Pat L]
ps' []
  where mkCPAux :: [Pat L] -> [Pat L] -> [Pat L]
        mkCPAux :: [Pat L] -> [Pat L] -> [Pat L]
mkCPAux [] [Pat L]
qs = [Pat L] -> [Pat L]
forall a. [a] -> [a]
reverse [Pat L]
qs
        mkCPAux (Pat L
p:[Pat L]
ps) [Pat L]
qs = case Pat L
p of
            (PRPat L
l [RPat L]
rps) -> [L -> [Pat L] -> [RPat L] -> Pat L
mkCRP L
l [Pat L]
ps ([RPat L] -> [RPat L]
forall a. [a] -> [a]
reverse [RPat L]
rps [RPat L] -> [RPat L] -> [RPat L]
forall a. [a] -> [a] -> [a]
++ (Pat L -> RPat L) -> [Pat L] -> [RPat L]
forall a b. (a -> b) -> [a] -> [b]
map (\Pat L
q -> L -> Pat L -> RPat L
forall l. l -> Pat l -> RPat l
RPPat (Pat L -> L
forall l. Pat l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Pat L
q) Pat L
q) [Pat L]
qs)]
            Pat L
_             -> [Pat L] -> [Pat L] -> [Pat L]
mkCPAux [Pat L]
ps (Pat L
pPat L -> [Pat L] -> [Pat L]
forall a. a -> [a] -> [a]
:[Pat L]
qs)

        mkCRP :: L -> [Pat L] -> [RPat L] -> Pat L
        mkCRP :: L -> [Pat L] -> [RPat L] -> Pat L
mkCRP L
l [] [RPat L]
rps = L -> [RPat L] -> Pat L
forall l. l -> [RPat l] -> Pat l
PXRPats L
l ([RPat L] -> Pat L) -> [RPat L] -> Pat L
forall a b. (a -> b) -> a -> b
$ [RPat L] -> [RPat L]
forall a. [a] -> [a]
reverse [RPat L]
rps
        mkCRP L
_ (Pat L
p:[Pat L]
ps) [RPat L]
rps = case Pat L
p of
            (PXRPats L
l [RPat L]
rqs) -> L -> [Pat L] -> [RPat L] -> Pat L
mkCRP L
l [Pat L]
ps ([RPat L] -> [RPat L]
forall a. [a] -> [a]
reverse [RPat L]
rqs [RPat L] -> [RPat L] -> [RPat L]
forall a. [a] -> [a] -> [a]
++ [RPat L]
rps)
            Pat L
_               -> L -> [Pat L] -> [RPat L] -> Pat L
mkCRP (Pat L -> L
forall l. Pat l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Pat L
p) [Pat L]
ps (L -> Pat L -> RPat L
forall l. l -> Pat l -> RPat l
RPPat (Pat L -> L
forall l. Pat l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Pat L
p) Pat L
p RPat L -> [RPat L] -> [RPat L]
forall a. a -> [a] -> [a]
: [RPat L]
rps)

-----------------------------------------------------------------------------
-- 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               -> Exp L -> P (Exp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp L -> P (Exp L)) -> Exp L -> P (Exp L)
forall a b. (a -> b) -> a -> b
$ L -> QName L -> Exp L
forall l. l -> QName l -> Exp l
S.Var L
l QName L
v
    OverloadedLabel L
l [Char]
v   -> Exp L -> P (Exp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp L -> P (Exp L)) -> Exp L -> P (Exp L)
forall a b. (a -> b) -> a -> b
$ L -> [Char] -> Exp L
forall l. l -> [Char] -> Exp l
S.OverloadedLabel L
l [Char]
v
    IPVar L
l IPName L
v             -> Exp L -> P (Exp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp L -> P (Exp L)) -> Exp L -> P (Exp L)
forall a b. (a -> b) -> a -> b
$ L -> IPName L -> Exp L
forall l. l -> IPName l -> Exp l
S.IPVar L
l IPName L
v
    Con L
l QName L
c               -> Exp L -> P (Exp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp L -> P (Exp L)) -> Exp L -> P (Exp L)
forall a b. (a -> b) -> a -> b
$ L -> QName L -> Exp L
forall l. l -> QName l -> Exp l
S.Con L
l QName L
c
    Lit L
l Literal L
lit             -> Exp L -> P (Exp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp L -> P (Exp L)) -> Exp L -> P (Exp L)
forall a b. (a -> b) -> a -> b
$ L -> Literal L -> Exp L
forall l. l -> Literal l -> Exp l
S.Lit L
l Literal L
lit
    InfixApp L
l PExp L
e1 QOp L
op PExp L
e2   -> PExp L -> PExp L -> (Exp L -> Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> PExp L -> (Exp L -> Exp L -> a) -> P a
check2Exprs PExp L
e1 PExp L
e2 ((Exp L -> QOp L -> Exp L -> Exp L)
-> QOp L -> Exp L -> Exp L -> Exp L
forall a b c. (a -> b -> c) -> b -> a -> c
flip (L -> Exp L -> QOp L -> Exp L -> Exp L
forall l. l -> Exp l -> QOp l -> Exp l -> Exp l
S.InfixApp L
l) QOp L
op)
    App L
l PExp L
e1 PExp L
e2           -> PExp L -> PExp L -> (Exp L -> Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> PExp L -> (Exp L -> Exp L -> a) -> P a
check2Exprs PExp L
e1 PExp L
e2 (L -> Exp L -> Exp L -> Exp L
forall l. l -> Exp l -> Exp l -> Exp l
S.App L
l)
    NegApp L
_ (Lit L
_ (PrimWord L
_ Integer
_ [Char]
_))
                          -> [Char] -> P (Exp L)
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail ([Char] -> P (Exp L)) -> [Char] -> P (Exp L)
forall a b. (a -> b) -> a -> b
$ [Char]
"Parse error: negative primitive word literal: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PExp L -> [Char]
forall a. Pretty a => a -> [Char]
prettyPrint PExp L
e'
    NegApp L
l PExp L
e            -> PExp L -> (Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e (L -> Exp L -> Exp L
forall l. l -> Exp l -> Exp l
S.NegApp L
l)
    Lambda L
loc [Pat L]
ps PExp L
e       -> PExp L -> (Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e (L -> [Pat L] -> Exp L -> Exp L
forall l. l -> [Pat l] -> Exp l -> Exp l
S.Lambda L
loc [Pat L]
ps)
    Let L
l Binds L
bs PExp L
e            -> PExp L -> (Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e (L -> Binds L -> Exp L -> Exp L
forall l. l -> Binds l -> Exp l -> Exp l
S.Let L
l Binds L
bs)
    If L
l PExp L
e1 PExp L
e2 PExp L
e3         -> PExp L
-> PExp L
-> PExp L
-> (Exp L -> Exp L -> Exp L -> Exp L)
-> P (Exp L)
forall a.
PExp L -> PExp L -> PExp L -> (Exp L -> Exp L -> Exp L -> a) -> P a
check3Exprs PExp L
e1 PExp L
e2 PExp L
e3 (L -> Exp L -> Exp L -> Exp L -> Exp L
forall l. l -> Exp l -> Exp l -> Exp l -> Exp l
S.If L
l)
    MultiIf L
l [GuardedRhs L]
alts        -> Exp L -> P (Exp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> [GuardedRhs L] -> Exp L
forall l. l -> [GuardedRhs l] -> Exp l
S.MultiIf L
l [GuardedRhs L]
alts)
    Case L
l PExp L
e [Alt L]
alts         -> do
                     e1 <- PExp L -> P (Exp L)
checkExpr PExp L
e
                     return (S.Case l e1 alts)
    Do L
l [Stmt L]
stmts            -> [Stmt L] -> P ()
forall t. [Stmt t] -> P ()
checkDo [Stmt L]
stmts P () -> P (Exp L) -> P (Exp L)
forall a b. P a -> P b -> P b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Exp L -> P (Exp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> [Stmt L] -> Exp L
forall l. l -> [Stmt l] -> Exp l
S.Do L
l [Stmt L]
stmts)
    MDo L
l [Stmt L]
stmts           -> [Stmt L] -> P ()
forall t. [Stmt t] -> P ()
checkDo [Stmt L]
stmts P () -> P (Exp L) -> P (Exp L)
forall a b. P a -> P b -> P b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Exp L -> P (Exp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> [Stmt L] -> Exp L
forall l. l -> [Stmt l] -> Exp l
S.MDo L
l [Stmt L]
stmts)
    TupleSection L
l Boxed
bx [Maybe (PExp L)]
mes -> if Maybe (PExp L)
forall a. Maybe a
Nothing Maybe (PExp L) -> [Maybe (PExp L)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Maybe (PExp L)]
mes
                             then [PExp L] -> ([Exp L] -> Exp L) -> P (Exp L)
forall a. [PExp L] -> ([Exp L] -> a) -> P a
checkManyExprs ((Maybe (PExp L) -> PExp L) -> [Maybe (PExp L)] -> [PExp L]
forall a b. (a -> b) -> [a] -> [b]
map Maybe (PExp L) -> PExp L
forall a. HasCallStack => Maybe a -> a
fromJust [Maybe (PExp L)]
mes) (L -> Boxed -> [Exp L] -> Exp L
forall l. l -> Boxed -> [Exp l] -> Exp l
S.Tuple L
l Boxed
bx)
                             else do KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
TupleSections
                                     mes' <- (Maybe (PExp L) -> P (Maybe (Exp L)))
-> [Maybe (PExp L)] -> P [Maybe (Exp L)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Maybe (PExp L) -> P (Maybe (Exp L))
mCheckExpr [Maybe (PExp L)]
mes
                                     return $ S.TupleSection l bx mes'
    UnboxedSum L
l Int
before Int
after PExp L
e -> L -> Int -> Int -> Exp L -> Exp L
forall l. l -> Int -> Int -> Exp l -> Exp l
S.UnboxedSum L
l Int
before Int
after (Exp L -> Exp L) -> P (Exp L) -> P (Exp L)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PExp L -> P (Exp L)
checkExpr PExp L
e


    List L
l [PExp L]
es         -> [PExp L] -> ([Exp L] -> Exp L) -> P (Exp L)
forall a. [PExp L] -> ([Exp L] -> a) -> P a
checkManyExprs [PExp L]
es (L -> [Exp L] -> Exp L
forall l. l -> [Exp l] -> Exp l
S.List L
l)
    ParArray L
l [PExp L]
es     -> [PExp L] -> ([Exp L] -> Exp L) -> P (Exp L)
forall a. [PExp L] -> ([Exp L] -> a) -> P a
checkManyExprs [PExp L]
es (L -> [Exp L] -> Exp L
forall l. l -> [Exp l] -> Exp l
S.ParArray L
l)
    -- 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 -> PExp L -> (Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e1 ((Exp L -> QOp L -> Exp L) -> QOp L -> Exp L -> Exp L
forall a b c. (a -> b -> c) -> b -> a -> c
flip (L -> Exp L -> QOp L -> Exp L
forall l. l -> Exp l -> QOp l -> Exp l
S.LeftSection L
l) QOp L
op)
                          PreOp  L
_ QOp L
op PExp L
e2 -> PExp L -> (Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e2 (L -> QOp L -> Exp L -> Exp L
forall l. l -> QOp l -> Exp l -> Exp l
S.RightSection L
l QOp L
op)
                          PExp L
_            -> PExp L -> (Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e (L -> Exp L -> Exp L
forall l. l -> Exp l -> Exp l
S.Paren L
l)
    RecConstr L
l QName L
c [PFieldUpdate L]
fields      -> do
                     fields1 <- (PFieldUpdate L -> P (FieldUpdate L))
-> [PFieldUpdate L] -> P [FieldUpdate L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PFieldUpdate L -> P (FieldUpdate L)
checkField [PFieldUpdate L]
fields
                     return (S.RecConstr l c fields1)
    RecUpdate L
l PExp L
e [PFieldUpdate L]
fields      -> do
                     fields1 <- (PFieldUpdate L -> P (FieldUpdate L))
-> [PFieldUpdate L] -> P [FieldUpdate L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PFieldUpdate L -> P (FieldUpdate L)
checkField [PFieldUpdate L]
fields
                     e1 <- checkExpr e
                     return (S.RecUpdate l e1 fields1)
    EnumFrom L
l PExp L
e          -> PExp L -> (Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e (L -> Exp L -> Exp L
forall l. l -> Exp l -> Exp l
S.EnumFrom L
l)
    EnumFromTo L
l PExp L
e1 PExp L
e2    -> PExp L -> PExp L -> (Exp L -> Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> PExp L -> (Exp L -> Exp L -> a) -> P a
check2Exprs PExp L
e1 PExp L
e2 (L -> Exp L -> Exp L -> Exp L
forall l. l -> Exp l -> Exp l -> Exp l
S.EnumFromTo L
l)
    EnumFromThen L
l PExp L
e1 PExp L
e2      -> PExp L -> PExp L -> (Exp L -> Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> PExp L -> (Exp L -> Exp L -> a) -> P a
check2Exprs PExp L
e1 PExp L
e2 (L -> Exp L -> Exp L -> Exp L
forall l. l -> Exp l -> Exp l -> Exp l
S.EnumFromThen L
l)
    EnumFromThenTo L
l PExp L
e1 PExp L
e2 PExp L
e3 -> PExp L
-> PExp L
-> PExp L
-> (Exp L -> Exp L -> Exp L -> Exp L)
-> P (Exp L)
forall a.
PExp L -> PExp L -> PExp L -> (Exp L -> Exp L -> Exp L -> a) -> P a
check3Exprs PExp L
e1 PExp L
e2 PExp L
e3 (L -> Exp L -> Exp L -> Exp L -> Exp L
forall l. l -> Exp l -> Exp l -> Exp l -> Exp l
S.EnumFromThenTo L
l)
    ParArrayFromTo L
l PExp L
e1 PExp L
e2    -> PExp L -> PExp L -> (Exp L -> Exp L -> Exp L) -> P (Exp L)
forall a. PExp L -> PExp L -> (Exp L -> Exp L -> a) -> P a
check2Exprs PExp L
e1 PExp L
e2 (L -> Exp L -> Exp L -> Exp L
forall l. l -> Exp l -> Exp l -> Exp l
S.ParArrayFromTo L
l)
    ParArrayFromThenTo L
l PExp L
e1 PExp L
e2 PExp L
e3 -> PExp L
-> PExp L
-> PExp L
-> (Exp L -> Exp L -> Exp L -> Exp L)
-> P (Exp L)
forall a.
PExp L -> PExp L -> PExp L -> (Exp L -> Exp L -> Exp L -> a) -> P a
check3Exprs PExp L
e1 PExp L
e2 PExp L
e3 (L -> Exp L -> Exp L -> Exp L -> Exp L
forall l. l -> Exp l -> Exp l -> Exp l -> Exp l
S.ParArrayFromThenTo L
l)
    -- a parallel list comprehension, which could be just a simple one
    ParComp L
l PExp L
e [[QualStmt L]]
qualss        -> do
                     e1 <- PExp L -> P (Exp L)
checkExpr PExp L
e
                     case qualss of
                      [[QualStmt L]
quals] -> Exp L -> P (Exp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Exp L -> [QualStmt L] -> Exp L
forall l. l -> Exp l -> [QualStmt l] -> Exp l
S.ListComp L
l Exp L
e1 [QualStmt L]
quals)
                      [[QualStmt L]]
_       -> Exp L -> P (Exp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Exp L -> [[QualStmt L]] -> Exp L
forall l. l -> Exp l -> [[QualStmt l]] -> Exp l
S.ParComp L
l Exp L
e1 [[QualStmt L]]
qualss)
    ParArrayComp L
l PExp L
e [[QualStmt L]]
qualss        -> do
                     e1 <- PExp L -> P (Exp L)
checkExpr PExp L
e
                     return (S.ParArrayComp l e1 qualss)
    ExpTypeSig L
loc PExp L
e Type L
ty     -> do
                     e1 <- PExp L -> P (Exp L)
checkExpr PExp L
e
                     return (S.ExpTypeSig loc e1 ty)

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

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

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

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

    PExp L
_             -> [Char] -> P (Exp L)
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail ([Char] -> P (Exp L)) -> [Char] -> P (Exp L)
forall a b. (a -> b) -> a -> b
$ [Char]
"Parse error in expression: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PExp L -> [Char]
forall a. Pretty a => a -> [Char]
prettyPrint PExp L
e'

checkAttr :: ParseXAttr L -> P (S.XAttr L)
checkAttr :: ParseXAttr L -> P (XAttr L)
checkAttr (XAttr L
l XName L
n PExp L
v) = do v' <- PExp L -> P (Exp L)
checkExpr PExp L
v
                             return $ S.XAttr l n v'

checkDo :: [Stmt t] -> P ()
checkDo :: forall t. [Stmt t] -> P ()
checkDo [] = [Char] -> P ()
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail [Char]
"Parse error: Last statement in a do-block must be an expression"
checkDo [Qualifier t
_ Exp t
_] = () -> P ()
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkDo (Stmt t
_:[Stmt t]
xs) = [Stmt t] -> P ()
forall t. [Stmt t] -> P ()
checkDo [Stmt t]
xs

-- 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
    e1' <- PExp L -> P (Exp L)
checkExpr PExp L
e1
    return (f e1')

check2Exprs :: PExp L -> PExp L -> (S.Exp L -> S.Exp L -> a) -> P a
check2Exprs :: forall a. PExp L -> PExp L -> (Exp L -> Exp L -> a) -> P a
check2Exprs PExp L
e1 PExp L
e2 Exp L -> Exp L -> a
f = do
    e1' <- PExp L -> P (Exp L)
checkExpr PExp L
e1
    e2' <- checkExpr e2
    return (f e1' e2')

check3Exprs :: PExp L -> PExp L -> PExp L -> (S.Exp L -> S.Exp L -> S.Exp L -> a) -> P a
check3Exprs :: forall a.
PExp L -> PExp L -> PExp L -> (Exp L -> Exp L -> Exp L -> a) -> P a
check3Exprs PExp L
e1 PExp L
e2 PExp L
e3 Exp L -> Exp L -> Exp L -> a
f = do
    e1' <- PExp L -> P (Exp L)
checkExpr PExp L
e1
    e2' <- checkExpr e2
    e3' <- checkExpr e3
    return (f e1' e2' e3')

checkManyExprs :: [PExp L] -> ([S.Exp L] -> a) -> P a
checkManyExprs :: forall a. [PExp L] -> ([Exp L] -> a) -> P a
checkManyExprs [PExp L]
es [Exp L] -> a
f = do
    es' <- (PExp L -> P (Exp L)) -> [PExp L] -> P [Exp L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PExp L -> P (Exp L)
checkExpr [PExp L]
es
    return (f es')

mCheckExpr :: Maybe (PExp L) -> P (Maybe (S.Exp L))
mCheckExpr :: Maybe (PExp L) -> P (Maybe (Exp L))
mCheckExpr Maybe (PExp L)
Nothing = Maybe (Exp L) -> P (Maybe (Exp L))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Exp L)
forall a. Maybe a
Nothing
mCheckExpr (Just PExp L
e) = PExp L -> P (Exp L)
checkExpr PExp L
e P (Exp L) -> (Exp L -> P (Maybe (Exp L))) -> P (Maybe (Exp L))
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (Exp L) -> P (Maybe (Exp L))
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Exp L) -> P (Maybe (Exp L)))
-> (Exp L -> Maybe (Exp L)) -> Exp L -> P (Maybe (Exp L))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp L -> Maybe (Exp L)
forall a. a -> Maybe a
Just

checkRuleExpr :: PExp L -> P (S.Exp L)
checkRuleExpr :: PExp L -> P (Exp L)
checkRuleExpr = PExp L -> P (Exp L)
checkExpr

readTool :: Maybe String -> Maybe Tool
readTool :: Maybe [Char] -> Maybe Tool
readTool = ([Char] -> Tool) -> Maybe [Char] -> Maybe Tool
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> Tool
readC
 where readC :: [Char] -> Tool
readC [Char]
str = case [Char]
str of
        [Char]
"GHC" -> Tool
GHC
        [Char]
"HUGS" -> Tool
HUGS
        [Char]
"NHC98" -> Tool
NHC98
        [Char]
"YHC" -> Tool
YHC
        [Char]
"HADDOCK" -> Tool
HADDOCK
        [Char]
_ -> [Char] -> Tool
UnknownTool [Char]
str

checkField :: PFieldUpdate L -> P (S.FieldUpdate L)
checkField :: PFieldUpdate L -> P (FieldUpdate L)
checkField (FieldUpdate L
l QName L
n PExp L
e) = PExp L -> (Exp L -> FieldUpdate L) -> P (FieldUpdate L)
forall a. PExp L -> (Exp L -> a) -> P a
check1Expr PExp L
e (L -> QName L -> Exp L -> FieldUpdate L
forall l. l -> QName l -> Exp l -> FieldUpdate l
S.FieldUpdate L
l QName L
n)
checkField (FieldPun L
l QName L
n) = FieldUpdate L -> P (FieldUpdate L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (FieldUpdate L -> P (FieldUpdate L))
-> FieldUpdate L -> P (FieldUpdate L)
forall a b. (a -> b) -> a -> b
$ L -> QName L -> FieldUpdate L
forall l. l -> QName l -> FieldUpdate l
S.FieldPun L
l QName L
n
checkField (FieldWildcard L
l) = FieldUpdate L -> P (FieldUpdate L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (FieldUpdate L -> P (FieldUpdate L))
-> FieldUpdate L -> P (FieldUpdate L)
forall a b. (a -> b) -> a -> b
$ L -> FieldUpdate L
forall l. l -> FieldUpdate l
S.FieldWildcard L
l

getGConName :: S.Exp L -> P (QName L)
getGConName :: Exp L -> P (QName L)
getGConName (S.Con L
_ QName L
n) = QName L -> P (QName L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return QName L
n
getGConName (S.List L
l []) = QName L -> P (QName L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> QName L
forall l. l -> QName l
list_cons_name L
l)
getGConName Exp L
_ = [Char] -> P (QName L)
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail [Char]
"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
    mlhs <- PExp L -> [PExp L] -> P (Maybe (Name L, [PExp L], Bool, [SrcSpan]))
isFunLhs PExp L
lhs []
    let whpt = L -> [SrcSpan]
srcInfoPoints L
l
    case mlhs of
     Just (Name L
f,[PExp L]
es,Bool
b,[SrcSpan]
pts) -> do
            ps <- (PExp L -> P (Pat L)) -> [PExp L] -> P [Pat L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PExp L -> P (Pat L)
checkPattern [PExp L]
es
            let l' = L
l { srcInfoPoints = pts ++ whpt }
            case optsig of -- only pattern bindings can have signatures
                Maybe (Type L, SrcSpan)
Nothing -> Decl L -> P (Decl L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> [Match L] -> Decl L
forall l. l -> [Match l] -> Decl l
FunBind L
l ([Match L] -> Decl L) -> [Match L] -> Decl L
forall a b. (a -> b) -> a -> b
$
                            if Bool
b then [L -> Name L -> [Pat L] -> Rhs L -> Maybe (Binds L) -> Match L
forall l.
l -> Name l -> [Pat l] -> Rhs l -> Maybe (Binds l) -> Match l
Match L
l' Name L
f [Pat L]
ps Rhs L
rhs Maybe (Binds L)
whereBinds]
                                 else let (Pat L
a:[Pat L]
bs) = [Pat L]
ps
                                       in [L
-> Pat L
-> Name L
-> [Pat L]
-> Rhs L
-> Maybe (Binds L)
-> Match L
forall l.
l
-> Pat l
-> Name l
-> [Pat l]
-> Rhs l
-> Maybe (Binds l)
-> Match l
InfixMatch L
l' Pat L
a Name L
f [Pat L]
bs Rhs L
rhs Maybe (Binds L)
whereBinds])
                Just (Type L, SrcSpan)
_  -> [Char] -> P (Decl L)
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail [Char]
"Cannot give an explicit type signature to a function binding"
     Maybe (Name L, [PExp L], Bool, [SrcSpan])
Nothing     -> do
            lhs1 <- PExp L -> P (Pat L)
checkPattern PExp L
lhs
            let lhs' = case Maybe (Type L, SrcSpan)
optsig of
                        Maybe (Type L, SrcSpan)
Nothing -> Pat L
lhs1
                        Just (Type L
ty, SrcSpan
pt) -> let lp :: L
lp = (Pat L -> L
forall l. Pat l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Pat L
lhs1 L -> L -> L
<++> Type L -> L
forall l. Type l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Type L
ty) L -> [SrcSpan] -> L
<** [SrcSpan
pt]
                                         in L -> Pat L -> Type L -> Pat L
forall l. l -> Pat l -> Type l -> Pat l
PatTypeSig L
lp Pat L
lhs1 Type L
ty
            return (PatBind l lhs' rhs whereBinds)

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

-- 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)) = Name L -> P (Name L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name L -> P (Name L)) -> Name L -> P (Name L)
forall a b. (a -> b) -> a -> b
$ (L -> L) -> Name L -> Name L
forall a b. (a -> b) -> Name a -> Name b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (L -> L -> L
forall a b. a -> b -> a
const L
l) Name L
n
checkSigVar PExp L
e = [Char] -> P (Name L)
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail ([Char] -> P (Name L)) -> [Char] -> P (Name L)
forall a b. (a -> b) -> a -> b
$ [Char]
"Left-hand side of type signature is not a variable: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PExp L -> [Char]
forall a. Pretty a => a -> [Char]
prettyPrint PExp L
e

checkExplicitPatSyn :: S -> S -> ([Decl L], [S]) -> S -> P (PatternSynDirection L)
checkExplicitPatSyn :: SrcSpan
-> SrcSpan
-> ([Decl L], [SrcSpan])
-> SrcSpan
-> P (PatternSynDirection L)
checkExplicitPatSyn SrcSpan
whereLoc SrcSpan
openLoc ([Decl L]
decls, [SrcSpan]
semis) SrcSpan
closeLoc =
  let l :: L
l = SrcSpan
whereLoc SrcSpan -> SrcSpan -> L
<^^> SrcSpan
closeLoc  L -> [SrcSpan] -> L
<** ([SrcSpan
whereLoc, SrcSpan
openLoc] [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
++ [SrcSpan]
semis [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
++ [SrcSpan
closeLoc])
  in  L -> [Decl L] -> PatternSynDirection L
forall l. l -> [Decl l] -> PatternSynDirection l
S.ExplicitBidirectional L
l  ([Decl L] -> PatternSynDirection L)
-> P [Decl L] -> P (PatternSynDirection L)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Decl L -> P (Decl L)) -> [Decl L] -> P [Decl L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Decl L -> P (Decl L)
checkDecls [Decl L]
decls
  where
    checkDecls :: Decl L -> P (Decl L)
    checkDecls :: Decl L -> P (Decl L)
checkDecls p :: Decl L
p@(PatBind L
_ Pat L
pat Rhs L
_ Maybe (Binds L)
_) =
      case Pat L
pat of
        PApp L
_ QName L
_ [Pat L]
_        -> Decl L -> P (Decl L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return Decl L
p
        PInfixApp L
_ Pat L
_ QName L
_ Pat L
_ ->  Decl L -> P (Decl L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return Decl L
p
        Pat L
_ -> [Char] -> P (Decl L)
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail [Char]
"Illegal pattern binding in PatternSynonym"
    checkDecls Decl L
_                 = [Char] -> P (Decl L)
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail [Char]
"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
    (ClassDecl L -> P ()) -> [ClassDecl L] -> P ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ClassDecl L -> P ()
checkClassMethodDef [ClassDecl L]
decls
    [ClassDecl L] -> P [ClassDecl L]
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return [ClassDecl L]
decls
  where checkClassMethodDef :: ClassDecl L -> P ()
checkClassMethodDef (ClsDecl L
_ Decl L
decl) = Decl L -> P ()
checkMethodDef Decl L
decl
        checkClassMethodDef ClassDecl L
_ = () -> P ()
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

checkInstBody :: [InstDecl L] -> P [InstDecl L]
checkInstBody :: [InstDecl L] -> P [InstDecl L]
checkInstBody [InstDecl L]
decls = do
    (InstDecl L -> P ()) -> [InstDecl L] -> P ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ InstDecl L -> P ()
checkInstMethodDef [InstDecl L]
decls
    [InstDecl L] -> P [InstDecl L]
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return [InstDecl L]
decls
  where checkInstMethodDef :: InstDecl L -> P ()
checkInstMethodDef (InsDecl L
_ Decl L
decl) = Decl L -> P ()
checkMethodDef Decl L
decl
        checkInstMethodDef InstDecl L
_ = () -> P ()
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

checkMethodDef :: Decl L -> P ()
checkMethodDef :: Decl L -> P ()
checkMethodDef (PatBind L
_ (PVar L
_ Name L
_) Rhs L
_ Maybe (Binds L)
_) = () -> P ()
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkMethodDef (PatBind L
loc Pat L
_ Rhs L
_ Maybe (Binds L)
_) =
    [Char] -> P ()
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail [Char]
"illegal method definition" P () -> SrcLoc -> P ()
forall a. P a -> SrcLoc -> P a
`atSrcLoc` L -> SrcLoc
forall si. SrcInfo si => L -> si
fromSrcInfo L
loc
checkMethodDef Decl L
_ = () -> P ()
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

checkDefSigDef :: Decl L -> P (Name L,S.Type L,S)
checkDefSigDef :: Decl L -> P (Name L, Type L, SrcSpan)
checkDefSigDef (TypeSig L
loc [Name L
name] Type L
typ) =
  let (SrcSpan
b:[SrcSpan]
_) = L -> [SrcSpan]
srcInfoPoints L
loc in (Name L, Type L, SrcSpan) -> P (Name L, Type L, SrcSpan)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name L
name,Type L
typ,SrcSpan
b)
checkDefSigDef (TypeSig L
_ [Name L]
_ Type L
_) =
    [Char] -> P (Name L, Type L, SrcSpan)
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail [Char]
"default signature must be for a single name"
checkDefSigDef Decl L
_ =
    [Char] -> P (Name L, Type L, SrcSpan)
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail [Char]
"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
_) = [Char] -> P (Name L)
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail [Char]
"Illegal qualified name"
checkUnQual (UnQual  L
l Name L
n) = Name L -> P (Name L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name L -> P (Name L)) -> Name L -> P (Name L)
forall a b. (a -> b) -> a -> b
$ (L -> L) -> Name L -> Name L
forall a b. (a -> b) -> Name a -> Name b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (L -> L -> L
forall a b. a -> b -> a
const L
l) Name L
n
checkUnQual (Special L
_ SpecialCon L
_) = [Char] -> P (Name L)
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail [Char]
"Illegal special name"

checkQualOrUnQual :: QName L -> P (QName L)
checkQualOrUnQual :: QName L -> P (QName L)
checkQualOrUnQual n :: QName L
n@(Qual  L
_ ModuleName L
_ Name L
_) = QName L -> P (QName L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return QName L
n
checkQualOrUnQual n :: QName L
n@(UnQual  L
_ Name L
_) = QName L -> P (QName L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return QName L
n
checkQualOrUnQual (Special L
_ SpecialCon L
_)   = [Char] -> P (QName L)
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail [Char]
"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
_ [Char]
n1) (XName L
_ [Char]
n2)
    | [Char]
n1 [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
n2  = XName L -> P (XName L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return XName L
n
checkEqNames n :: XName L
n@(XDomName L
_ [Char]
d1 [Char]
n1) (XDomName L
_ [Char]
d2 [Char]
n2)
    | [Char]
n1 [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
n2 Bool -> Bool -> Bool
&& [Char]
d1 [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
d2 = XName L -> P (XName L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return XName L
n
checkEqNames XName L
n XName L
m = [Char] -> P (XName L)
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail ([Char] -> P (XName L)) -> [Char] -> P (XName L)
forall a b. (a -> b) -> a -> b
$ [Char]
"opening tag '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ XName L -> [Char]
forall {l}. XName l -> [Char]
showTag XName L
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                   [Char]
"' does not match closing tag '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ XName L -> [Char]
forall {l}. XName l -> [Char]
showTag XName L
m [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'"
    where
        showTag :: XName l -> [Char]
showTag (XName l
_ [Char]
n') = [Char]
n'
        showTag (XDomName l
_ [Char]
d [Char]
n') = [Char]
d [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
":" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
n'


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

checkPrec :: Integer -> P Int
checkPrec :: Integer -> P Int
checkPrec Integer
i | Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
i Bool -> Bool -> Bool
&& Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
9 = Int -> P Int
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
i)
            | Bool
otherwise        = [Char] -> P Int
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail ([Char]
"Illegal precedence " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
i)

mkRecConstrOrUpdate :: PExp L -> [PFieldUpdate L] -> P (PExp L)
mkRecConstrOrUpdate :: PExp L -> [PFieldUpdate L] -> P (PExp L)
mkRecConstrOrUpdate (Con L
l QName L
c) [PFieldUpdate L]
fs       = PExp L -> P (PExp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> QName L -> [PFieldUpdate L] -> PExp L
forall l. l -> QName l -> [PFieldUpdate l] -> PExp l
RecConstr L
l QName L
c [PFieldUpdate L]
fs)
mkRecConstrOrUpdate PExp L
e         fs :: [PFieldUpdate L]
fs@(PFieldUpdate L
_:[PFieldUpdate L]
_) = PExp L -> P (PExp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> PExp L -> [PFieldUpdate L] -> PExp L
forall l. l -> PExp l -> [PFieldUpdate l] -> PExp l
RecUpdate (PExp L -> L
forall l. PExp l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PExp L
e) PExp L
e [PFieldUpdate L]
fs)
mkRecConstrOrUpdate PExp L
_         [PFieldUpdate L]
_        = [Char] -> P (PExp L)
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail [Char]
"Empty record update"

updateQNameLoc :: l -> QName l -> QName l
updateQNameLoc :: forall l. l -> QName l -> QName l
updateQNameLoc l
l (Qual l
_ ModuleName l
mn Name l
n) = l -> ModuleName l -> Name l -> QName l
forall l. l -> ModuleName l -> Name l -> QName l
Qual l
l ModuleName l
mn Name l
n
updateQNameLoc l
l (UnQual l
_ Name l
n)  = l -> Name l -> QName l
forall l. l -> Name l -> QName l
UnQual l
l Name l
n
updateQNameLoc l
l (Special l
_ SpecialCon l
s) = l -> SpecialCon l -> QName l
forall l. l -> SpecialCon l -> QName l
Special l
l SpecialCon l
s

-----------------------------------------------------------------------------
-- 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] = Decl L -> P (Decl L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return Decl L
d
checkSingleDecl [Decl L]
ds =
    [Char] -> P (Decl L)
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail ([Char] -> P (Decl L)) -> [Char] -> P (Decl L)
forall a b. (a -> b) -> a -> b
$ [Char]
"Expected a single declaration, found " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([Decl L] -> Int
forall a. [a] -> Int
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 [] = [Decl L] -> P [Decl L]
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return [Decl L]
revDs
    mergeFunBinds [Decl L]
revDs (FunBind L
l' ms1 :: [Match L]
ms1@(Match L
_ Name L
name [Pat L]
ps Rhs L
_ Maybe (Binds L)
_:[Match L]
_):[Decl L]
ds1) =
        [Match L] -> [Decl L] -> L -> P [Decl L]
mergeMatches [Match L]
ms1 [Decl L]
ds1 L
l'
        where
        arity :: Int
arity = [Pat L] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat L]
ps
        mergeMatches :: [Match L] -> [Decl L] -> L -> P [Decl L]
mergeMatches [Match L]
ms' (FunBind L
_ ms :: [Match L]
ms@(Match L
loc Name L
name' [Pat L]
ps' Rhs L
_ Maybe (Binds L)
_:[Match L]
_):[Decl L]
ds) L
l
            | Name L
name' Name L -> Name L -> Bool
forall (a :: * -> *) l1 l2.
(Annotated a, Eq (a ())) =>
a l1 -> a l2 -> Bool
=~= Name L
name = do
            ignoreArity <- P Bool
getIgnoreFunctionArity
            if length ps' == arity || ignoreArity
              then mergeMatches (ms++ms') ds (loc <++> l)
              else fail ("arity mismatch for '" ++ prettyPrint name ++ "'")
                    `atSrcLoc` fromSrcInfo loc
        mergeMatches [Match L]
ms' [Decl L]
ds L
l = [Decl L] -> [Decl L] -> P [Decl L]
mergeFunBinds (L -> [Match L] -> Decl L
forall l. l -> [Match l] -> Decl l
FunBind L
l [Match L]
ms'Decl L -> [Decl L] -> [Decl L]
forall a. a -> [a] -> [a]
:[Decl L]
revDs) [Decl L]
ds
    mergeFunBinds [Decl L]
revDs (FunBind L
l' ims1 :: [Match L]
ims1@(InfixMatch L
_ Pat L
_ Name L
name [Pat L]
_ Rhs L
_ Maybe (Binds L)
_:[Match L]
_):[Decl L]
ds1) =
        [Match L] -> [Decl L] -> L -> P [Decl L]
mergeInfix [Match L]
ims1 [Decl L]
ds1 L
l'
        where
        mergeInfix :: [Match L] -> [Decl L] -> L -> P [Decl L]
mergeInfix [Match L]
ims' (FunBind L
_ ims :: [Match L]
ims@(InfixMatch L
loc Pat L
_ Name L
name' [Pat L]
_ Rhs L
_ Maybe (Binds L)
_:[Match L]
_):[Decl L]
ds) L
l
            | Name L
name' Name L -> Name L -> Bool
forall (a :: * -> *) l1 l2.
(Annotated a, Eq (a ())) =>
a l1 -> a l2 -> Bool
=~= Name L
name =
            [Match L] -> [Decl L] -> L -> P [Decl L]
mergeInfix ([Match L]
ims[Match L] -> [Match L] -> [Match L]
forall a. [a] -> [a] -> [a]
++[Match L]
ims') [Decl L]
ds (L
loc L -> L -> L
<++> L
l)
        mergeInfix [Match L]
ms' [Decl L]
ds L
l = [Decl L] -> [Decl L] -> P [Decl L]
mergeFunBinds (L -> [Match L] -> Decl L
forall l. l -> [Match l] -> Decl l
FunBind L
l [Match L]
ms'Decl L -> [Decl L] -> [Decl L]
forall a. a -> [a] -> [a]
:[Decl L]
revDs) [Decl L]
ds
    mergeFunBinds [Decl L]
revDs (Decl L
d:[Decl L]
ds) = [Decl L] -> [Decl L] -> P [Decl L]
mergeFunBinds (Decl L
dDecl L -> [Decl L] -> [Decl L]
forall a. a -> [a] -> [a]
:[Decl L]
revDs) [Decl L]
ds

checkRevClsDecls :: [ClassDecl L] -> P [ClassDecl L]
checkRevClsDecls :: [ClassDecl L] -> P [ClassDecl L]
checkRevClsDecls = [ClassDecl L] -> [ClassDecl L] -> P [ClassDecl L]
mergeClsFunBinds []
    where
    mergeClsFunBinds :: [ClassDecl L] -> [ClassDecl L] -> P [ClassDecl L]
mergeClsFunBinds [ClassDecl L]
revDs [] = [ClassDecl L] -> P [ClassDecl L]
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return [ClassDecl L]
revDs
    mergeClsFunBinds [ClassDecl L]
revDs (ClsDecl L
l' (FunBind L
_ ms1 :: [Match L]
ms1@(Match L
_ Name L
name [Pat L]
ps Rhs L
_ Maybe (Binds L)
_:[Match L]
_)):[ClassDecl L]
ds1) =
        [Match L] -> [ClassDecl L] -> L -> P [ClassDecl L]
mergeMatches [Match L]
ms1 [ClassDecl L]
ds1 L
l'
        where
        arity :: Int
arity = [Pat L] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat L]
ps
        mergeMatches :: [Match L] -> [ClassDecl L] -> L -> P [ClassDecl L]
mergeMatches [Match L]
ms' (ClsDecl L
_ (FunBind L
_ ms :: [Match L]
ms@(Match L
loc Name L
name' [Pat L]
ps' Rhs L
_ Maybe (Binds L)
_:[Match L]
_)):[ClassDecl L]
ds) L
l
            | Name L
name' Name L -> Name L -> Bool
forall (a :: * -> *) l1 l2.
(Annotated a, Eq (a ())) =>
a l1 -> a l2 -> Bool
=~= Name L
name = do
            ignoreArity <- P Bool
getIgnoreFunctionArity
            if length ps' == arity || ignoreArity
              then mergeMatches (ms++ms') ds (loc <++> l)
              else fail ("arity mismatch for '" ++ prettyPrint name ++ "'")
                    `atSrcLoc` fromSrcInfo loc
        mergeMatches [Match L]
ms' [ClassDecl L]
ds L
l = [ClassDecl L] -> [ClassDecl L] -> P [ClassDecl L]
mergeClsFunBinds (L -> Decl L -> ClassDecl L
forall l. l -> Decl l -> ClassDecl l
ClsDecl L
l (L -> [Match L] -> Decl L
forall l. l -> [Match l] -> Decl l
FunBind L
l [Match L]
ms')ClassDecl L -> [ClassDecl L] -> [ClassDecl L]
forall a. a -> [a] -> [a]
:[ClassDecl L]
revDs) [ClassDecl L]
ds
    mergeClsFunBinds [ClassDecl L]
revDs (ClsDecl L
l' (FunBind L
_ ims1 :: [Match L]
ims1@(InfixMatch L
_ Pat L
_ Name L
name [Pat L]
_ Rhs L
_ Maybe (Binds L)
_:[Match L]
_)):[ClassDecl L]
ds1) =
        [Match L] -> [ClassDecl L] -> L -> P [ClassDecl L]
mergeInfix [Match L]
ims1 [ClassDecl L]
ds1 L
l'
        where
        mergeInfix :: [Match L] -> [ClassDecl L] -> L -> P [ClassDecl L]
mergeInfix [Match L]
ims' (ClsDecl L
_ (FunBind L
_ ims :: [Match L]
ims@(InfixMatch L
loc Pat L
_ Name L
name' [Pat L]
_ Rhs L
_ Maybe (Binds L)
_:[Match L]
_)):[ClassDecl L]
ds) L
l
            | Name L
name' Name L -> Name L -> Bool
forall (a :: * -> *) l1 l2.
(Annotated a, Eq (a ())) =>
a l1 -> a l2 -> Bool
=~= Name L
name =
            [Match L] -> [ClassDecl L] -> L -> P [ClassDecl L]
mergeInfix ([Match L]
ims[Match L] -> [Match L] -> [Match L]
forall a. [a] -> [a] -> [a]
++[Match L]
ims') [ClassDecl L]
ds (L
loc L -> L -> L
<++> L
l)
        mergeInfix [Match L]
ms' [ClassDecl L]
ds L
l = [ClassDecl L] -> [ClassDecl L] -> P [ClassDecl L]
mergeClsFunBinds (L -> Decl L -> ClassDecl L
forall l. l -> Decl l -> ClassDecl l
ClsDecl L
l (L -> [Match L] -> Decl L
forall l. l -> [Match l] -> Decl l
FunBind L
l [Match L]
ms')ClassDecl L -> [ClassDecl L] -> [ClassDecl L]
forall a. a -> [a] -> [a]
:[ClassDecl L]
revDs) [ClassDecl L]
ds
    mergeClsFunBinds [ClassDecl L]
revDs (ClassDecl L
d:[ClassDecl L]
ds) = [ClassDecl L] -> [ClassDecl L] -> P [ClassDecl L]
mergeClsFunBinds (ClassDecl L
dClassDecl L -> [ClassDecl L] -> [ClassDecl L]
forall a. a -> [a] -> [a]
:[ClassDecl L]
revDs) [ClassDecl L]
ds

checkRevInstDecls :: [InstDecl L] -> P [InstDecl L]
checkRevInstDecls :: [InstDecl L] -> P [InstDecl L]
checkRevInstDecls = [InstDecl L] -> [InstDecl L] -> P [InstDecl L]
mergeInstFunBinds []
    where
    mergeInstFunBinds :: [InstDecl L] -> [InstDecl L] -> P [InstDecl L]
    mergeInstFunBinds :: [InstDecl L] -> [InstDecl L] -> P [InstDecl L]
mergeInstFunBinds [InstDecl L]
revDs [] = [InstDecl L] -> P [InstDecl L]
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return [InstDecl L]
revDs
    mergeInstFunBinds [InstDecl L]
revDs (InsDecl L
l' (FunBind L
_ ms1 :: [Match L]
ms1@(Match L
_ Name L
name [Pat L]
ps Rhs L
_ Maybe (Binds L)
_:[Match L]
_)):[InstDecl L]
ds1) =
        [Match L] -> [InstDecl L] -> L -> P [InstDecl L]
mergeMatches [Match L]
ms1 [InstDecl L]
ds1 L
l'
        where
        arity :: Int
arity = [Pat L] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat L]
ps
        mergeMatches :: [Match L] -> [InstDecl L] -> L -> P [InstDecl L]
mergeMatches [Match L]
ms' (InsDecl L
_ (FunBind L
_ ms :: [Match L]
ms@(Match L
loc Name L
name' [Pat L]
ps' Rhs L
_ Maybe (Binds L)
_:[Match L]
_)):[InstDecl L]
ds) L
l
            | Name L
name' Name L -> Name L -> Bool
forall (a :: * -> *) l1 l2.
(Annotated a, Eq (a ())) =>
a l1 -> a l2 -> Bool
=~= Name L
name = do
            ignoreArity <- P Bool
getIgnoreFunctionArity
            if length ps' == arity || ignoreArity
              then mergeMatches (ms++ms') ds (loc <++> l)
              else fail ("arity mismatch for '" ++ prettyPrint name ++ "'")
                    `atSrcLoc` fromSrcInfo loc
        mergeMatches [Match L]
ms' [InstDecl L]
ds L
l = [InstDecl L] -> [InstDecl L] -> P [InstDecl L]
mergeInstFunBinds (L -> Decl L -> InstDecl L
forall l. l -> Decl l -> InstDecl l
InsDecl L
l (L -> [Match L] -> Decl L
forall l. l -> [Match l] -> Decl l
FunBind L
l [Match L]
ms')InstDecl L -> [InstDecl L] -> [InstDecl L]
forall a. a -> [a] -> [a]
:[InstDecl L]
revDs) [InstDecl L]
ds
    mergeInstFunBinds [InstDecl L]
revDs (InsDecl L
l' (FunBind L
_ ims1 :: [Match L]
ims1@(InfixMatch L
_ Pat L
_ Name L
name [Pat L]
_ Rhs L
_ Maybe (Binds L)
_:[Match L]
_)):[InstDecl L]
ds1) =
        [Match L] -> [InstDecl L] -> L -> P [InstDecl L]
mergeInfix [Match L]
ims1 [InstDecl L]
ds1 L
l'
        where
        mergeInfix :: [Match L] -> [InstDecl L] -> L -> P [InstDecl L]
mergeInfix [Match L]
ims' (InsDecl L
_ (FunBind L
_ ims :: [Match L]
ims@(InfixMatch L
loc Pat L
_ Name L
name' [Pat L]
_ Rhs L
_ Maybe (Binds L)
_:[Match L]
_)):[InstDecl L]
ds) L
l
            | Name L
name' Name L -> Name L -> Bool
forall (a :: * -> *) l1 l2.
(Annotated a, Eq (a ())) =>
a l1 -> a l2 -> Bool
=~= Name L
name =
            [Match L] -> [InstDecl L] -> L -> P [InstDecl L]
mergeInfix ([Match L]
ims[Match L] -> [Match L] -> [Match L]
forall a. [a] -> [a] -> [a]
++[Match L]
ims') [InstDecl L]
ds (L
loc L -> L -> L
<++> L
l)
        mergeInfix [Match L]
ms' [InstDecl L]
ds L
l = [InstDecl L] -> [InstDecl L] -> P [InstDecl L]
mergeInstFunBinds (L -> Decl L -> InstDecl L
forall l. l -> Decl l -> InstDecl l
InsDecl L
l (L -> [Match L] -> Decl L
forall l. l -> [Match l] -> Decl l
FunBind L
l [Match L]
ms')InstDecl L -> [InstDecl L] -> [InstDecl L]
forall a. a -> [a] -> [a]
:[InstDecl L]
revDs) [InstDecl L]
ds
    mergeInstFunBinds [InstDecl L]
revDs (InstDecl L
d:[InstDecl L]
ds) = [InstDecl L] -> [InstDecl L] -> P [InstDecl L]
mergeInstFunBinds (InstDecl L
dInstDecl L -> [InstDecl L] -> [InstDecl L]
forall a. a -> [a] -> [a]
:[InstDecl L]
revDs) [InstDecl L]
ds

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

checkDataOrNewG :: DataOrNew L -> [GadtDecl L] -> P ()
checkDataOrNewG :: DataOrNew L -> [GadtDecl L] -> P ()
checkDataOrNewG (DataType L
_) [GadtDecl L]
_  = () -> P ()
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkDataOrNewG (NewType L
_) [GadtDecl L
_] = () -> P ()
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkDataOrNewG DataOrNew L
_        [GadtDecl L]
_  = [Char] -> P ()
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail [Char]
"newtype declaration must have exactly one constructor."

checkSimpleType :: PType L -> P (DeclHead L)
checkSimpleType :: PType L -> P (DeclHead L)
checkSimpleType = [Char] -> PType L -> P (DeclHead L)
checkSimple [Char]
"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) -> L -> BangType L -> Unpackedness L -> PType L -> PType L
forall l. l -> BangType l -> Unpackedness l -> PType l -> PType l
TyBang (Unpackedness L -> L
forall l. Unpackedness l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Unpackedness L
upack L -> L -> L
<++> PType L -> L
forall l. PType l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PType L
ty) (L -> BangType L
forall l. l -> BangType l
NoStrictAnnot L
noSrcSpan) Unpackedness L
upack PType L
ty
    (Just (L -> BangType L
strict, SrcSpan
pos), Maybe (Unpackedness L)
_)  ->
      L -> BangType L -> Unpackedness L -> PType L -> PType L
forall l. l -> BangType l -> Unpackedness l -> PType l -> PType l
TyBang ((Unpackedness L -> L) -> Maybe (Unpackedness L) -> Maybe L
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Unpackedness L -> L
forall l. Unpackedness l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Maybe (Unpackedness L)
munpack Maybe L -> L -> L
<?+> SrcSpan -> L
noInfoSpan SrcSpan
pos L -> L -> L
<++> PType L -> L
forall l. PType l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PType L
ty) (L -> BangType L
strict (SrcSpan -> L
noInfoSpan SrcSpan
pos))
        (Unpackedness L -> Maybe (Unpackedness L) -> Unpackedness L
forall a. a -> Maybe a -> a
fromMaybe (L -> Unpackedness L
forall l. l -> Unpackedness l
NoUnpackPragma L
noSrcSpan) Maybe (Unpackedness L)
munpack) PType L
ty
    (Maybe (L -> BangType L, SrcSpan)
Nothing, Maybe (Unpackedness L)
Nothing) -> PType L
ty


checkType :: PType L -> P (S.Type L)
checkType :: PType L -> P (Type L)
checkType PType L
t = PType L -> Bool -> P (Type L)
checkT PType L
t Bool
False

checkT :: PType L -> Bool -> P (S.Type L)
checkT :: PType L -> Bool -> P (Type L)
checkT PType L
t Bool
simple = case PType L
t of
    TyForall L
l Maybe [TyVarBind L]
Nothing Maybe (PContext L)
cs PType L
pt    -> do
            Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
simple (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$ KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
ExplicitForAll
            ctxt <- Maybe (PContext L) -> P (Maybe (Context L))
checkContext Maybe (PContext L)
cs
            check1Type pt (S.TyForall l Nothing ctxt)
    TyForall L
l Maybe [TyVarBind L]
tvs Maybe (PContext L)
cs PType L
pt -> do
            KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
ExplicitForAll
            ctxt <- Maybe (PContext L) -> P (Maybe (Context L))
checkContext Maybe (PContext L)
cs
            check1Type pt (S.TyForall l tvs ctxt)
    TyStar  L
l         -> Type L -> P (Type L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type L -> P (Type L)) -> Type L -> P (Type L)
forall a b. (a -> b) -> a -> b
$ L -> Type L
forall l. l -> Type l
S.TyStar L
l
    TyFun   L
l PType L
at PType L
rt   -> PType L -> PType L -> (Type L -> Type L -> Type L) -> P (Type L)
check2Types PType L
at PType L
rt (L -> Type L -> Type L -> Type L
forall l. l -> Type l -> Type l -> Type l
S.TyFun L
l)
    TyTuple L
l Boxed
b [PType L]
pts   -> [PType L] -> P [Type L]
checkTypes [PType L]
pts P [Type L] -> ([Type L] -> P (Type L)) -> P (Type L)
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type L -> P (Type L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type L -> P (Type L))
-> ([Type L] -> Type L) -> [Type L] -> P (Type L)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> Boxed -> [Type L] -> Type L
forall l. l -> Boxed -> [Type l] -> Type l
S.TyTuple L
l Boxed
b
    TyUnboxedSum L
l [PType L]
es -> [PType L] -> P [Type L]
checkTypes [PType L]
es P [Type L] -> ([Type L] -> P (Type L)) -> P (Type L)
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type L -> P (Type L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type L -> P (Type L))
-> ([Type L] -> Type L) -> [Type L] -> P (Type L)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> [Type L] -> Type L
forall l. l -> [Type l] -> Type l
S.TyUnboxedSum L
l
    TyList  L
l PType L
pt      -> PType L -> (Type L -> Type L) -> P (Type L)
check1Type PType L
pt (L -> Type L -> Type L
forall l. l -> Type l -> Type l
S.TyList L
l)
    TyParArray L
l PType L
pt   -> PType L -> (Type L -> Type L) -> P (Type L)
check1Type PType L
pt (L -> Type L -> Type L
forall l. l -> Type l -> Type l
S.TyParArray L
l)
    TyApp   L
l PType L
ft PType L
at   -> PType L -> PType L -> (Type L -> Type L -> Type L) -> P (Type L)
check2Types PType L
ft PType L
at (L -> Type L -> Type L -> Type L
forall l. l -> Type l -> Type l -> Type l
S.TyApp L
l)
    TyVar   L
l Name L
n       -> Type L -> P (Type L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type L -> P (Type L)) -> Type L -> P (Type L)
forall a b. (a -> b) -> a -> b
$ L -> Name L -> Type L
forall l. l -> Name l -> Type l
S.TyVar L
l Name L
n
    TyCon   L
l QName L
n       -> do
            QName L -> P ()
checkAndWarnTypeOperators QName L
n
            Type L -> P (Type L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type L -> P (Type L)) -> Type L -> P (Type L)
forall a b. (a -> b) -> a -> b
$ L -> QName L -> Type L
forall l. l -> QName l -> Type l
S.TyCon L
l QName L
n
    TyParen L
l PType L
pt      -> PType L -> (Type L -> Type L) -> P (Type L)
check1Type PType L
pt (L -> Type L -> Type L
forall l. l -> Type l -> Type l
S.TyParen L
l)
    -- 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 (MaybePromotedName L -> QName L
forall l. MaybePromotedName l -> QName l
getMaybePromotedQName MaybePromotedName L
op)
                           P () -> P (Type L) -> P (Type L)
forall a b. P a -> P b -> P b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PType L -> PType L -> (Type L -> Type L -> Type L) -> P (Type L)
check2Types PType L
at PType L
bt ((Type L -> MaybePromotedName L -> Type L -> Type L)
-> MaybePromotedName L -> Type L -> Type L -> Type L
forall a b c. (a -> b -> c) -> b -> a -> c
flip (L -> Type L -> MaybePromotedName L -> Type L -> Type L
forall l. l -> Type l -> MaybePromotedName l -> Type l -> Type l
S.TyInfix L
l) MaybePromotedName L
op)
    TyKind  L
l PType L
pt Type L
k    -> PType L -> (Type L -> Type L) -> P (Type L)
check1Type PType L
pt ((Type L -> Type L -> Type L) -> Type L -> Type L -> Type L
forall a b c. (a -> b -> c) -> b -> a -> c
flip (L -> Type L -> Type L -> Type L
forall l. l -> Type l -> Type l -> Type l
S.TyKind L
l) Type L
k)

    TyPromoted L
l Promoted L
p -> Type L -> P (Type L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type L -> P (Type L)) -> Type L -> P (Type L)
forall a b. (a -> b) -> a -> b
$ L -> Promoted L -> Type L
forall l. l -> Promoted l -> Type l
S.TyPromoted L
l Promoted L
p -- ??
    TyEquals L
l PType L
at PType L
bt   -> PType L -> PType L -> (Type L -> Type L -> Type L) -> P (Type L)
check2Types PType L
at PType L
bt (L -> Type L -> Type L -> Type L
forall l. l -> Type l -> Type l -> Type l
S.TyEquals L
l)
    TySplice L
l Splice L
s        -> do
                              KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
TemplateHaskell
                              Type L -> P (Type L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type L -> P (Type L)) -> Type L -> P (Type L)
forall a b. (a -> b) -> a -> b
$ L -> Splice L -> Type L
forall l. l -> Splice l -> Type l
S.TySplice L
l Splice L
s
    TyBang L
l BangType L
b Unpackedness L
u PType L
t' -> PType L -> (Type L -> Type L) -> P (Type L)
check1Type PType L
t' (L -> BangType L -> Unpackedness L -> Type L -> Type L
forall l. l -> BangType l -> Unpackedness l -> Type l -> Type l
S.TyBang L
l BangType L
b Unpackedness L
u)
    TyWildCard L
l Maybe (Name L)
mn -> Type L -> P (Type L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type L -> P (Type L)) -> Type L -> P (Type L)
forall a b. (a -> b) -> a -> b
$ L -> Maybe (Name L) -> Type L
forall l. l -> Maybe (Name l) -> Type l
S.TyWildCard L
l Maybe (Name L)
mn
    TyQuasiQuote L
l [Char]
n [Char]
s -> do
                              KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
QuasiQuotes
                              Type L -> P (Type L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type L -> P (Type L)) -> Type L -> P (Type L)
forall a b. (a -> b) -> a -> b
$ L -> [Char] -> [Char] -> Type L
forall l. l -> [Char] -> [Char] -> Type l
S.TyQuasiQuote L
l [Char]
n [Char]
s
    PType L
_   -> [Char] -> P (Type L)
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail ([Char] -> P (Type L)) -> [Char] -> P (Type L)
forall a b. (a -> b) -> a -> b
$ [Char]
"Parse error in type: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PType L -> [Char]
forall a. Pretty a => a -> [Char]
prettyPrint PType L
t

getMaybePromotedQName :: MaybePromotedName l -> QName l
getMaybePromotedQName :: forall l. MaybePromotedName l -> QName l
getMaybePromotedQName (PromotedName l
_ QName l
q) = QName l
q
getMaybePromotedQName (UnpromotedName l
_ QName l
q) = QName l
q

check1Type :: PType L -> (S.Type L -> S.Type L) -> P (S.Type L)
check1Type :: PType L -> (Type L -> Type L) -> P (Type L)
check1Type PType L
pt Type L -> Type L
f = PType L -> Bool -> P (Type L)
checkT PType L
pt Bool
True P (Type L) -> (Type L -> P (Type L)) -> P (Type L)
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type L -> P (Type L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type L -> P (Type L))
-> (Type L -> Type L) -> Type L -> P (Type L)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type L -> Type L
f

check2Types :: PType L -> PType L -> (S.Type L -> S.Type L -> S.Type L) -> P (S.Type L)
check2Types :: PType L -> PType L -> (Type L -> Type L -> Type L) -> P (Type L)
check2Types PType L
at PType L
bt Type L -> Type L -> Type L
f = PType L -> Bool -> P (Type L)
checkT PType L
at Bool
True P (Type L) -> (Type L -> P (Type L)) -> P (Type L)
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type L
a -> PType L -> Bool -> P (Type L)
checkT PType L
bt Bool
True P (Type L) -> (Type L -> P (Type L)) -> P (Type L)
forall a b. P a -> (a -> P b) -> P b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type L
b -> Type L -> P (Type L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type L -> Type L -> Type L
f Type L
a Type L
b)

checkTypes :: [PType L] -> P [S.Type L]
checkTypes :: [PType L] -> P [Type L]
checkTypes = (PType L -> P (Type L)) -> [PType L] -> P [Type L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((PType L -> Bool -> P (Type L)) -> Bool -> PType L -> P (Type L)
forall a b c. (a -> b -> c) -> b -> a -> c
flip PType L -> Bool -> P (Type L)
checkT Bool
True)

checkTyVar ::  Name L -> P (PType L)
checkTyVar :: Name L -> P (PType L)
checkTyVar Name L
n = do
  e <- P [KnownExtension]
getExtensions
  return $
    case n of
      Ident L
il (Char
'_':[Char]
ident) | KnownExtension
NamedWildCards KnownExtension -> [KnownExtension] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
e ->
        L -> Maybe (Name L) -> PType L
forall l. l -> Maybe (Name l) -> PType l
TyWildCard L
il (Name L -> Maybe (Name L)
forall a. a -> Maybe a
Just (L -> [Char] -> Name L
forall l. l -> [Char] -> Name l
Ident (L -> L
reduceSrcSpanInfo L
il) [Char]
ident))
      Name L
_ ->
        L -> Name L -> PType L
forall l. l -> Name l -> PType l
TyVar (Name L -> L
forall l. Name l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Name L
n) Name L
n
  where
    -- 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 = srcSpanStartColumn ss + 1 }
      in  L
spaninfo { srcInfoSpan = 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 | Name l -> Bool
forall {l}. Name l -> Bool
constrKind Name l
q -> [KnownExtension] -> P ()
forall e. (Show e, Enabled e) => [e] -> P ()
checkEnabledOneOf [KnownExtension
ConstraintKinds, KnownExtension
DataKinds]
            where constrKind :: Name l -> Bool
constrKind Name l
name = case Name l
name of
                    Ident l
_ [Char]
n -> [Char]
n [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"Constraint"
                    Name l
_                      -> Bool
False

        Kind l
_ -> KnownExtension -> P ()
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
    mod <- P [Char]
getModuleName
    xml' <- checkExpr xml
    case xml' of
        S.XTag  L
l XName L
xn [XAttr L]
ats Maybe (Exp L)
mattr [Exp L]
cs -> Module L -> P (Module L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Module L -> P (Module L)) -> Module L -> P (Module L)
forall a b. (a -> b) -> a -> b
$ L
-> ModuleName L
-> [ModulePragma L]
-> XName L
-> [XAttr L]
-> Maybe (Exp L)
-> [Exp L]
-> Module L
forall l.
l
-> ModuleName l
-> [ModulePragma l]
-> XName l
-> [XAttr l]
-> Maybe (Exp l)
-> [Exp l]
-> Module l
XmlPage (L
infL -> L -> L
<++>L
lL -> [SrcSpan] -> L
<**(L -> [SrcSpan]
srcInfoPoints L
l [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
++ [SrcSpan]
ss)) (L -> [Char] -> ModuleName L
forall l. l -> [Char] -> ModuleName l
ModuleName L
l [Char]
mod) [ModulePragma L]
os XName L
xn [XAttr L]
ats Maybe (Exp L)
mattr [Exp L]
cs
        S.XETag L
l XName L
xn [XAttr L]
ats Maybe (Exp L)
mattr    -> Module L -> P (Module L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Module L -> P (Module L)) -> Module L -> P (Module L)
forall a b. (a -> b) -> a -> b
$ L
-> ModuleName L
-> [ModulePragma L]
-> XName L
-> [XAttr L]
-> Maybe (Exp L)
-> [Exp L]
-> Module L
forall l.
l
-> ModuleName l
-> [ModulePragma l]
-> XName l
-> [XAttr l]
-> Maybe (Exp l)
-> [Exp l]
-> Module l
XmlPage (L
infL -> L -> L
<++>L
lL -> [SrcSpan] -> L
<**(L -> [SrcSpan]
srcInfoPoints L
l [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
++ [SrcSpan]
ss)) (L -> [Char] -> ModuleName L
forall l. l -> [Char] -> ModuleName l
ModuleName L
l [Char]
mod) [ModulePragma L]
os XName L
xn [XAttr L]
ats Maybe (Exp L)
mattr []
        Exp L
_ -> [Char] -> P (Module L)
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail [Char]
"Unexpected expression; tag is expected"

checkHybridModule :: PExp L -> Module L -> S -> S -> P (Module L)
checkHybridModule :: PExp L -> Module L -> SrcSpan -> SrcSpan -> P (Module L)
checkHybridModule PExp L
xml (Module L
inf Maybe (ModuleHead L)
mh [ModulePragma L]
os [ImportDecl L]
is [Decl L]
ds) SrcSpan
s1 SrcSpan
s2 = do
    xml' <- PExp L -> P (Exp L)
checkExpr PExp L
xml
    case xml' of
        S.XTag  L
l XName L
xn [XAttr L]
ats Maybe (Exp L)
mattr [Exp L]
cs -> Module L -> P (Module L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Module L -> P (Module L)) -> Module L -> P (Module L)
forall a b. (a -> b) -> a -> b
$ L
-> Maybe (ModuleHead L)
-> [ModulePragma L]
-> [ImportDecl L]
-> [Decl L]
-> XName L
-> [XAttr L]
-> Maybe (Exp L)
-> [Exp L]
-> Module L
forall l.
l
-> Maybe (ModuleHead l)
-> [ModulePragma l]
-> [ImportDecl l]
-> [Decl l]
-> XName l
-> [XAttr l]
-> Maybe (Exp l)
-> [Exp l]
-> Module l
XmlHybrid (L
infL -> L -> L
<++>L
lL -> [SrcSpan] -> L
<**(SrcSpan
s1 SrcSpan -> [SrcSpan] -> [SrcSpan]
forall a. a -> [a] -> [a]
: L -> [SrcSpan]
srcInfoPoints L
inf [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
++ SrcSpan
s2 SrcSpan -> [SrcSpan] -> [SrcSpan]
forall a. a -> [a] -> [a]
: L -> [SrcSpan]
srcInfoPoints L
l))
                                                Maybe (ModuleHead L)
mh [ModulePragma L]
os [ImportDecl L]
is [Decl L]
ds XName L
xn [XAttr L]
ats Maybe (Exp L)
mattr [Exp L]
cs
        S.XETag L
l XName L
xn [XAttr L]
ats Maybe (Exp L)
mattr    -> Module L -> P (Module L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Module L -> P (Module L)) -> Module L -> P (Module L)
forall a b. (a -> b) -> a -> b
$ L
-> Maybe (ModuleHead L)
-> [ModulePragma L]
-> [ImportDecl L]
-> [Decl L]
-> XName L
-> [XAttr L]
-> Maybe (Exp L)
-> [Exp L]
-> Module L
forall l.
l
-> Maybe (ModuleHead l)
-> [ModulePragma l]
-> [ImportDecl l]
-> [Decl l]
-> XName l
-> [XAttr l]
-> Maybe (Exp l)
-> [Exp l]
-> Module l
XmlHybrid (L
infL -> L -> L
<++>L
lL -> [SrcSpan] -> L
<**(SrcSpan
s1 SrcSpan -> [SrcSpan] -> [SrcSpan]
forall a. a -> [a] -> [a]
: L -> [SrcSpan]
srcInfoPoints L
inf [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
++ SrcSpan
s2 SrcSpan -> [SrcSpan] -> [SrcSpan]
forall a. a -> [a] -> [a]
: L -> [SrcSpan]
srcInfoPoints L
l))
                                                Maybe (ModuleHead L)
mh [ModulePragma L]
os [ImportDecl L]
is [Decl L]
ds XName L
xn [XAttr L]
ats Maybe (Exp L)
mattr []
        Exp L
_ -> [Char] -> P (Module L)
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail [Char]
"Unexpected expression; tag is expected"
checkHybridModule PExp L
_ Module L
_ SrcSpan
_ SrcSpan
_ = [Char] -> P (Module L)
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail [Char]
"Hybrid module expected"

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

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

---------------------------------------
-- 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) -> L
-> Maybe [TyVarBind L] -> Maybe (PContext L) -> PType L -> PType L
forall l.
l
-> Maybe [TyVarBind l] -> Maybe (PContext l) -> PType l -> PType l
TyForall L
l Maybe [TyVarBind L]
mtvs Maybe (PContext L)
ctxt2 PType L
ty2
        (Maybe (PContext L), PType L)
_                                       -> L
-> Maybe [TyVarBind L] -> Maybe (PContext L) -> PType L -> PType L
forall l.
l
-> Maybe [TyVarBind l] -> Maybe (PContext l) -> PType l -> PType l
TyForall L
l Maybe [TyVarBind L]
mtvs Maybe (PContext L)
ctxt PType L
ty

-- Make a role annotation

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

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

  where
    checkKTyVar :: S -> S.Type L -> P (ResultSig L)
    checkKTyVar :: SrcSpan -> Type L -> P (ResultSig L)
checkKTyVar SrcSpan
eqloc Type L
rhsty =
      case Type L
rhsty of
       S.TyVar L
l Name L
n -> ResultSig L -> P (ResultSig L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (ResultSig L -> P (ResultSig L)) -> ResultSig L -> P (ResultSig L)
forall a b. (a -> b) -> a -> b
$ L -> TyVarBind L -> ResultSig L
forall l. l -> TyVarBind l -> ResultSig l
TyVarSig (SrcSpan -> L
noInfoSpan SrcSpan
eqloc L -> L -> L
<++> L
l L -> [SrcSpan] -> L
<** [SrcSpan
eqloc]) (L -> Name L -> TyVarBind L
forall l. l -> Name l -> TyVarBind l
UnkindedVar L
l Name L
n)
       S.TyKind L
l (S.TyVar L
_ Name L
n) Type L
k -> ResultSig L -> P (ResultSig L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (ResultSig L -> P (ResultSig L)) -> ResultSig L -> P (ResultSig L)
forall a b. (a -> b) -> a -> b
$ L -> TyVarBind L -> ResultSig L
forall l. l -> TyVarBind l -> ResultSig l
TyVarSig (SrcSpan -> L
noInfoSpan SrcSpan
eqloc L -> L -> L
<++> L
l L -> [SrcSpan] -> L
<** [SrcSpan
eqloc]) (L -> Name L -> Type L -> TyVarBind L
forall l. l -> Name l -> Kind l -> TyVarBind l
KindedVar L
l Name L
n Type L
k)
       Type L
_ -> [Char] -> P (ResultSig L)
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail ([Char]
"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
          = L -> PType L -> PType L -> PType L
forall l. l -> PType l -> PType l -> PType l
TyEquals (L
loc L -> [SrcSpan] -> L
<** [L -> SrcSpan
srcInfoSpan L
eqloc]) (PType L -> PType L
go PType L
t1) PType L
t2'
          | Bool
otherwise
          = case PType L -> PType L
go PType L
t1 of
              TyEquals L
eqloc PType L
tl PType L
tr ->
                L -> PType L -> PType L -> PType L
forall l. l -> PType l -> PType l -> PType l
TyEquals (L
eqloc L -> L -> L
<++> PType L -> L
forall l. PType l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PType L
t2 L -> [SrcSpan] -> L
<** L -> [SrcSpan]
srcInfoPoints L
eqloc) PType L
tl (L -> PType L -> PType L -> PType L
forall l. l -> PType l -> PType l -> PType l
TyApp (PType L -> L
forall l. PType l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PType L
tr L -> L -> L
<++> PType L -> L
forall l. PType l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PType L
t2) PType L
tr PType L
t2)
              PType L
t' -> L -> PType L -> PType L -> PType L
forall l. l -> PType l -> PType l -> PType l
TyApp L
loc PType L
t' PType L
t2

        go PType L
t' = PType L
t'

-- 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
  Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EWildcard L -> Bool
forall {l}. EWildcard l -> Bool
isWc EWildcard L
wc Bool -> Bool -> Bool
&& Bool -> Bool
not ([CName L] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CName L]
cnames)) (KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
PatternSynonyms)
  ExportSpec L -> P (ExportSpec L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExportSpec L -> P (ExportSpec L))
-> ExportSpec L -> P (ExportSpec L)
forall a b. (a -> b) -> a -> b
$ L -> EWildcard L -> QName L -> [CName L] -> ExportSpec L
forall l. l -> EWildcard l -> QName l -> [CName l] -> ExportSpec l
EThingWith L
loc EWildcard L
wc QName L
qn [CName L]
cnames
  where
    isWc :: EWildcard l -> Bool
isWc (NoWildcard {}) = Bool
False
    isWc EWildcard l
_ = Bool
True

    wc :: EWildcard L
    wc :: EWildcard L
wc = EWildcard L
-> ((Int, Either SrcSpan (CName L)) -> EWildcard L)
-> Maybe (Int, Either SrcSpan (CName L))
-> EWildcard L
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (L -> EWildcard L
forall l. l -> EWildcard l
NoWildcard L
noSrcSpan)
               (\(Int
n,Left SrcSpan
s) -> L -> Int -> EWildcard L
forall l. l -> Int -> EWildcard l
EWildcard (SrcSpan -> L
noInfoSpan SrcSpan
s) Int
n)
               (Int
-> (Either SrcSpan (CName L) -> Bool)
-> [Either SrcSpan (CName L)]
-> Maybe (Int, Either SrcSpan (CName L))
forall a. Int -> (a -> Bool) -> [a] -> Maybe (Int, a)
findWithIndex Int
0 Either SrcSpan (CName L) -> Bool
forall a b. Either a b -> Bool
checkLeft [Either SrcSpan (CName L)]
mcns)

    checkLeft :: Either a b -> Bool
    checkLeft :: forall a b. Either a b -> Bool
checkLeft (Left a
_) = Bool
True
    checkLeft Either a b
_ = Bool
False

    cnames :: [CName L]
cnames = [Either SrcSpan (CName L)] -> [CName L]
forall a b. [Either a b] -> [b]
rights [Either SrcSpan (CName L)]
mcns

    findWithIndex :: Int -> (a -> Bool) -> [a] -> Maybe (Int, a)
    findWithIndex :: forall a. Int -> (a -> Bool) -> [a] -> Maybe (Int, a)
findWithIndex Int
_ a -> Bool
_ [] = Maybe (Int, a)
forall a. Maybe a
Nothing
    findWithIndex Int
n a -> Bool
p (a
x:[a]
xs)
      | a -> Bool
p a
x = (Int, a) -> Maybe (Int, a)
forall a. a -> Maybe a
Just (Int
n, a
x)
      | Bool
otherwise = Int -> (a -> Bool) -> [a] -> Maybe (Int, a)
forall a. Int -> (a -> Bool) -> [a] -> Maybe (Int, a)
findWithIndex (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) a -> Bool
p [a]
xs

data SumOrTuple l = SSum Int Int (PExp l)
                  | STuple [Maybe (PExp l)]

mkSumOrTuple :: Boxed -> L -> SumOrTuple L -> P (PExp L)
mkSumOrTuple :: Boxed -> L -> SumOrTuple L -> P (PExp L)
mkSumOrTuple Boxed
Unboxed L
s (SSum Int
before Int
after PExp L
e) = PExp L -> P (PExp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Int -> Int -> PExp L -> PExp L
forall l. l -> Int -> Int -> PExp l -> PExp l
UnboxedSum L
s Int
before Int
after PExp L
e)
mkSumOrTuple Boxed
boxity L
s (STuple [Maybe (PExp L)]
ms) =
    PExp L -> P (PExp L)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (PExp L -> P (PExp L)) -> PExp L -> P (PExp L)
forall a b. (a -> b) -> a -> b
$ L -> Boxed -> [Maybe (PExp L)] -> PExp L
forall l. l -> Boxed -> [Maybe (PExp l)] -> PExp l
TupleSection L
s Boxed
boxity [Maybe (PExp L)]
ms
mkSumOrTuple Boxed
Boxed L
_s (SSum {}) = [Char] -> P (PExp L)
forall a. HasCallStack => [Char] -> P a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail [Char]
"Boxed sums are not implemented"