{-# 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 :: PExp l -> P (QName l)
pexprToQName (Con _ qn :: QName l
qn) = QName l -> P (QName l)
forall (m :: * -> *) a. Monad m => a -> m a
return QName l
qn
pexprToQName (List l :: l
l []) = QName l -> P (QName l)
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 _ = String -> P (QName l)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "pexprToQName"

splitTyConApp :: PType L -> P (Name L, [S.Type L])
splitTyConApp :: PType L -> P (Name L, [Type L])
splitTyConApp t0 :: PType L
t0 = do
            (n :: Name L
n, pts :: [PType L]
pts) <- PType L -> [PType L] -> P (Name L, [PType L])
split PType L
t0 []
            [Type L]
ts <- (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)
mapM PType L -> P (Type L)
checkType [PType L]
pts
            (Name L, [Type L]) -> P (Name L, [Type L])
forall (m :: * -> *) a. Monad m => a -> m a
return (Name L
n,[Type L]
ts)
 where
    split :: PType L -> [PType L] -> P (Name L, [PType L])
    split :: PType L -> [PType L] -> P (Name L, [PType L])
split (TyApp _ t :: PType L
t u :: PType L
u) ts :: [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 _ (UnQual _ t :: Name L
t)) ts :: [PType L]
ts = (Name L, [PType L]) -> P (Name L, [PType L])
forall (m :: * -> *) a. Monad m => a -> m a
return (Name L
t,[PType L]
ts)
    split (TyInfix l :: L
l a :: PType L
a op :: MaybePromotedName L
op b :: PType L
b) ts :: [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 _ _ = String -> P (Name L, [PType L])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Illegal data/newtype declaration"

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

checkEnabled :: (Show e, Enabled e) => e  -> P ()
checkEnabled :: e -> P ()
checkEnabled e :: e
e = do
    [KnownExtension]
exts <- P [KnownExtension]
getExtensions
    Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (e -> [KnownExtension] -> Bool
forall a. Enabled a => a -> [KnownExtension] -> Bool
isEnabled e
e [KnownExtension]
exts) (P () -> P ()) -> P () -> P ()
forall a b. (a -> b) -> a -> b
$ String -> P ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
errorMsg
 where errorMsg :: String
errorMsg = [String] -> String
unwords
          [ e -> String
forall a. Show a => a -> String
show e
e
          , "language extension is not enabled."
          , "Please add {-# LANGUAGE " String -> String -> String
forall a. [a] -> [a] -> [a]
++ e -> String
forall a. Show a => a -> String
show e
e String -> String -> String
forall a. [a] -> [a] -> [a]
++  " #-}"
          , "pragma at the top of your module."
          ]

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

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

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

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

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

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

-- Check a single assertion according to the above, still leaving
-- the class assertion parameters for later.
checkAssertion :: PType L -> P (PAsst L)
-- We cannot even get here unless ImplicitParameters is enabled.
checkAssertion :: PType L -> P (PAsst L)
checkAssertion (TyParen l :: L
l asst :: PType L
asst) = do
    PAsst L
asst' <- PType L -> P (PAsst L)
checkAssertion PType L
asst
    PAsst L -> P (PAsst L)
forall (m :: * -> *) a. Monad m => a -> m a
return (PAsst L -> P (PAsst L)) -> PAsst L -> P (PAsst L)
forall a b. (a -> b) -> a -> b
$ L -> PAsst L -> PAsst L
forall l. l -> PAsst l -> PAsst l
ParenA L
l PAsst L
asst'
checkAssertion (TyPred _ p :: 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 t' :: PType L
t' = do
        PType L
t'' <- (L -> L) -> [PType L] -> PType L -> P (PType L)
checkAssertion' L -> L
forall a. a -> a
id [] PType L
t'
        PAsst L -> P (PAsst L)
forall (m :: * -> *) a. Monad m => a -> m a
return (PAsst L -> P (PAsst L)) -> PAsst L -> P (PAsst L)
forall a b. (a -> b) -> a -> b
$ L -> PType L -> PAsst L
forall l. l -> PType l -> PAsst l
TypeA (PType L -> L
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PType L
t'') PType L
t''
    where   -- class assertions must have at least one argument
            checkAssertion' :: (L -> L) -> [PType L] -> PType L -> P (PType L)
checkAssertion' _ _ t :: PType L
t@(TyEquals _ _ _) = PType L -> P (PType L)
forall (m :: * -> *) a. Monad m => a -> m a
return PType L
t
            checkAssertion' fl :: L -> L
fl ts :: [PType L]
ts (TyCon l :: L
l c :: QName L
c) = do
                Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([PType L] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PType L]
ts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 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 (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' fl :: L -> L
fl ts :: [PType L]
ts (TyApp l :: L
l a :: PType L
a t :: 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' fl :: L -> L
fl _ (TyInfix l :: L
l a :: PType L
a op :: MaybePromotedName L
op b :: 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 (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' fl :: L -> L
fl ts :: [PType L]
ts (TyParen l :: L
l t :: 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' fl :: L -> L
fl ts :: [PType L]
ts (TyVar l :: L
l t :: 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 (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' _ _ t :: PType L
t@(TyWildCard _ _) = PType L -> P (PType L)
forall (m :: * -> *) a. Monad m => a -> m a
return PType L
t
            checkAssertion' _ _ t :: 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 (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 _ c :: PType L
c [] = PType L
c
            tyApps l :: L
l c :: PType L
c (a :: PType L
a:aa :: [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 _ t :: PType L
t) = PType L -> P (PAsst L)
checkAssertion PType L
t
checkAAssertion (ParenA l :: L
l a :: PAsst L
a) = do
    PAsst L
a' <- PAsst L -> P (PAsst L)
checkAAssertion PAsst L
a
    PAsst L -> P (PAsst L)
forall (m :: * -> *) a. Monad m => a -> m a
return (PAsst L -> P (PAsst L)) -> PAsst L -> P (PAsst L)
forall a b. (a -> b) -> a -> b
$ L -> PAsst L -> PAsst L
forall l. l -> PAsst l -> PAsst l
ParenA L
l PAsst L
a'
checkAAssertion p :: PAsst L
p = PAsst L -> P (PAsst L)
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' ts :: [PType l]
ts (TyCon _ _) =
            Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([PType l] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PType l]
ts Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 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' ts :: [PType l]
ts (TyApp _ a :: PType l
a t :: 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' _ (TyInfix _ _ _ _) = KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
MultiParamTypeClasses
        checkMultiParam' ts :: [PType l]
ts (TyParen _ t :: PType l
t) = [PType l] -> PType l -> P ()
checkMultiParam' [PType l]
ts PType l
t
        checkMultiParam' _ _ = () -> P ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

getSymbol :: QName L -> Maybe String
getSymbol :: QName L -> Maybe String
getSymbol (UnQual _ (Symbol _ s :: String
s)) = String -> Maybe String
forall a. a -> Maybe a
Just String
s
getSymbol (Qual _ _ (Symbol _ s :: String
s)) = String -> Maybe String
forall a. a -> Maybe a
Just String
s
getSymbol _                       = Maybe String
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 c :: QName L
c =
    case QName L -> Maybe String
getSymbol QName L
c of
        Just s :: String
s | String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "."  -> [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
        Nothing -> () -> P ()
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 ctxt :: PContext L
ctxt) = case PContext L
ctxt of
    CxEmpty l :: L
l -> Maybe (Context L) -> P (Maybe (Context L))
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
l a :: 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (Context L) -> P (Maybe (Context L))
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
l as :: [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)
mapM PAsst L -> P (Asst L)
checkAsst [PAsst L]
as P [Asst L]
-> ([Asst L] -> P (Maybe (Context L))) -> P (Maybe (Context L))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (Context L) -> P (Maybe (Context L))
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 (Context L) -> P (Maybe (Context L))
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 ctxt :: PContext L
ctxt) = case PContext L
ctxt of
    CxEmpty l :: L
l -> Maybe (Context L) -> P (Maybe (Context L))
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
l a :: 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (Context L) -> P (Maybe (Context L))
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
l as :: [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)
mapM PAsst L -> P (Asst L)
checkAsst [PAsst L]
as P [Asst L]
-> ([Asst L] -> P (Maybe (Context L))) -> P (Maybe (Context L))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (Context L) -> P (Maybe (Context L))
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 (Context L) -> P (Maybe (Context L))
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 asst :: PAsst L
asst =
    case PAsst L
asst of
      TypeA l :: L
l pt :: PType L
pt -> do
                Type L
t <- PType L -> P (Type L)
checkType PType L
pt
                Asst L -> P (Asst L)
forall (m :: * -> *) a. Monad m => a -> m a
return (Asst L -> P (Asst L)) -> Asst L -> P (Asst L)
forall a b. (a -> b) -> a -> b
$ L -> Type L -> Asst L
forall l. l -> Type l -> Asst l
S.TypeA L
l Type L
t
      IParam l :: L
l ipn :: IPName L
ipn pt :: PType L
pt -> do
                Type L
t <- PType L -> P (Type L)
checkType PType L
pt
                Asst L -> P (Asst L)
forall (m :: * -> *) a. Monad m => a -> m a
return (Asst L -> P (Asst L)) -> Asst L -> P (Asst L)
forall a b. (a -> b) -> a -> b
$ L -> IPName L -> Type L -> Asst L
forall l. l -> IPName l -> Type l -> Asst l
S.IParam L
l IPName L
ipn Type L
t
      ParenA l :: L
l a :: PAsst L
a      -> do
                Asst L
a' <- PAsst L -> P (Asst L)
checkAsst PAsst L
a
                Asst L -> P (Asst L)
forall (m :: * -> *) a. Monad m => a -> m a
return (Asst L -> P (Asst L)) -> Asst L -> P (Asst L)
forall a b. (a -> b) -> a -> b
$ L -> Asst L -> Asst L
forall l. l -> Asst l -> Asst l
S.ParenA L
l Asst L
a'

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


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

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

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

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

mkTyVarBind :: String -> PType L -> P (TyVarBind L)
mkTyVarBind :: String -> PType L -> P (TyVarBind L)
mkTyVarBind _ (TyVar l :: L
l n :: Name L
n) = TyVarBind L -> P (TyVarBind L)
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 _ (TyKind l :: L
l (TyVar _ n :: Name L
n) k :: Type L
k) = TyVarBind L -> P (TyVarBind L)
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 _ (TyCon l :: L
l c :: QName L
c@(UnQual _ n :: Name L
n@(Symbol _ _))) = QName L -> P ()
checkAndWarnTypeOperators QName L
c P () -> P (TyVarBind L) -> P (TyVarBind L)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TyVarBind L -> P (TyVarBind L)
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 _ (TyKind l :: L
l (TyCon _ c :: QName L
c@(UnQual _ n :: Name L
n@(Symbol _ _))) k :: Type L
k) = QName L -> P ()
checkAndWarnTypeOperators QName L
c P () -> P (TyVarBind L) -> P (TyVarBind L)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TyVarBind L -> P (TyVarBind L)
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 kw :: String
kw _ = String -> P (TyVarBind L)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ("Illegal " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
kw String -> String -> String
forall a. [a] -> [a] -> [a]
++ " 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
l t :: PType L
t) = PType L -> P (InstRule L)
checkInstHeader PType L
t P (InstRule L) -> (InstRule L -> P (InstRule L)) -> P (InstRule L)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InstRule L -> P (InstRule L)
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
l mtvs :: Maybe [TyVarBind L]
mtvs cs :: Maybe (PContext L)
cs t :: PType L
t) = do
    Maybe (Context L)
cs' <- Maybe (PContext L) -> P (Maybe (Context L))
checkSContext Maybe (PContext L)
cs
    PType L -> P ()
checkMultiParam PType L
t
    Maybe L
-> Maybe [TyVarBind L]
-> Maybe (Context L)
-> PType L
-> P (InstRule L)
checkInsts (L -> Maybe L
forall a. a -> Maybe a
Just L
l) Maybe [TyVarBind L]
mtvs Maybe (Context L)
cs' PType L
t
checkInstHeader t :: PType L
t = PType L -> P ()
checkMultiParam PType L
t P () -> P (InstRule L) -> P (InstRule L)
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 _ mtvs :: Maybe [TyVarBind L]
mtvs mctxt :: Maybe (Context L)
mctxt (TyParen l :: L
l t :: 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InstRule L -> P (InstRule L)
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 l1 :: Maybe L
l1 mtvs :: Maybe [TyVarBind L]
mtvs mctxt :: Maybe (Context L)
mctxt t :: PType L
t = do
    InstHead L
t' <- PType L -> P (InstHead L)
checkInstsGuts PType L
t
    InstRule L -> P (InstRule L)
forall (m :: * -> *) a. Monad m => a -> m a
return (InstRule L -> P (InstRule L)) -> InstRule L -> P (InstRule L)
forall a b. (a -> b) -> a -> b
$ L
-> Maybe [TyVarBind L]
-> Maybe (Context L)
-> InstHead L
-> InstRule L
forall l.
l
-> Maybe [TyVarBind l]
-> Maybe (Context l)
-> InstHead l
-> InstRule l
IRule (L -> Maybe L -> L
forall a. a -> Maybe a -> a
fromMaybe ((Context L -> L) -> Maybe (Context L) -> Maybe L
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Context L -> L
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Maybe (Context L)
mctxt Maybe L -> L -> L
<?+> InstHead L -> L
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann InstHead L
t') Maybe L
l1) Maybe [TyVarBind L]
mtvs Maybe (Context L)
mctxt InstHead L
t'

checkInstsGuts :: PType L -> P (InstHead L)
checkInstsGuts :: PType L -> P (InstHead L)
checkInstsGuts (TyApp l :: L
l h :: PType L
h t :: PType L
t) = do
    Type L
t' <- PType L -> P (Type L)
checkType PType L
t
    InstHead L
h' <- PType L -> P (InstHead L)
checkInstsGuts PType L
h
    InstHead L -> P (InstHead L)
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 -> InstHead L -> Type L -> InstHead L
forall l. l -> InstHead l -> Type l -> InstHead l
IHApp L
l InstHead L
h' Type L
t'
checkInstsGuts (TyCon l :: L
l c :: QName L
c) = do
    QName L -> P ()
checkAndWarnTypeOperators QName L
c
    InstHead L -> P (InstHead L)
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
l a :: PType L
a op :: MaybePromotedName L
op b :: PType L
b) = do
    QName L -> P ()
checkAndWarnTypeOperators (MaybePromotedName L -> QName L
forall l. MaybePromotedName l -> QName l
getMaybePromotedQName MaybePromotedName L
op)
    [ta :: Type L
ta,tb :: Type L
tb] <- [PType L] -> P [Type L]
checkTypes [PType L
a,PType L
b]
    InstHead L -> P (InstHead L)
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 -> InstHead L -> Type L -> InstHead L
forall l. l -> InstHead l -> Type l -> InstHead l
IHApp L
l (L -> Type L -> QName L -> InstHead L
forall l. l -> Type l -> QName l -> InstHead l
IHInfix L
l Type L
ta (MaybePromotedName L -> QName L
forall l. MaybePromotedName l -> QName l
getMaybePromotedQName MaybePromotedName L
op)) Type L
tb
checkInstsGuts (TyParen l :: L
l t :: PType L
t) = PType L -> P (InstHead L)
checkInstsGuts PType L
t P (InstHead L) -> (InstHead L -> P (InstHead L)) -> P (InstHead L)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InstHead L -> P (InstHead L)
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 _ = String -> P (InstHead L)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "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)
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 e :: 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
l c :: QName L
c) args :: [Pat L]
args = do
  let l' :: L
l' = (L -> L -> L) -> L -> [L] -> L
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 (ast :: * -> *) l. Annotated ast => ast l -> l
ann [Pat L]
args)
  Pat L -> P (Pat L)
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 _ f :: PExp L
f x :: PExp L
x) args :: [Pat L]
args = do
    Pat L
x' <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
x []
    PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
f (Pat L
x'Pat L -> [Pat L] -> [Pat L]
forall a. a -> [a] -> [a]
:[Pat L]
args)
checkPat (InfixApp _ l :: PExp L
l op :: QOp L
op r :: PExp L
r) args :: [Pat L]
args
    | QOp L
op QOp L -> QOp () -> Bool
forall (a :: * -> *) l1 l2.
(Annotated a, Eq (a ())) =>
a l1 -> a l2 -> Bool
=~= () -> QName () -> QOp ()
forall l. l -> QName l -> QOp l
QVarOp () (() -> Name () -> QName ()
forall l. l -> Name l -> QName l
UnQual () (() -> String -> Name ()
forall l. l -> String -> Name l
Symbol () "!")) = do
        -- We must have BangPatterns on
        KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
BangPatterns
        let (e :: PExp L
e,es :: [PExp L]
es) = PExp L -> [PExp L] -> (PExp L, [PExp L])
splitBang PExp L
r []
        [Pat L]
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)
mapM PExp L -> P (Pat L)
checkPattern (L -> PExp L -> PExp L
forall l. l -> PExp l -> PExp l
BangPat (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)
        PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
l ([Pat L]
ps[Pat L] -> [Pat L] -> [Pat L]
forall a. [a] -> [a] -> [a]
++[Pat L]
args)
checkPat e' :: PExp L
e' [] = case PExp L
e' of
    Var _ (UnQual l :: L
l x :: Name L
x)   -> Pat L -> P (Pat L)
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 _ (Special l :: L
l (ExprHole _)) -> Pat L -> P (Pat L)
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Pat L
forall l. l -> Pat l
PWildCard L
l)
    Lit l :: L
l lit :: Literal L
lit            -> Pat L -> P (Pat L)
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 loc :: L
loc l :: PExp L
l op :: QOp L
op r :: PExp L
r  ->
        case QOp L
op of
            QConOp _ c :: QName L
c -> do
                    Pat L
l' <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
l []
                    Pat L
r' <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
r []
                    Pat L -> P (Pat L)
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Pat L -> QName L -> Pat L -> Pat L
forall l. l -> Pat l -> QName l -> Pat l -> Pat l
PInfixApp L
loc Pat L
l' QName L
c Pat L
r')
            QVarOp ppos :: L
ppos (UnQual _ (Symbol _ "+")) -> do
                    KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
NPlusKPatterns
                    case (PExp L
l,PExp L
r) of
                        (Var _ (UnQual _ n :: Name L
n@(Ident _ _)), Lit _ (Int kpos :: L
kpos k :: Integer
k _)) -> do
                            let pp :: SrcSpan
pp = L -> SrcSpan
srcInfoSpan L
ppos
                                kp :: SrcSpan
kp = L -> SrcSpan
srcInfoSpan L
kpos
                            Pat L -> P (Pat L)
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)
                        _ -> String -> P (Pat L)
forall a. String -> P a
patFail ""
            _ -> String -> P (Pat L)
forall a. String -> P a
patFail ""
    TupleSection l :: L
l bx :: Boxed
bx mes :: [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 [Pat L]
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)
mapM (\e :: 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)
                     Pat L -> P (Pat L)
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Boxed -> [Pat L] -> Pat L
forall l. l -> Boxed -> [Pat l] -> Pat l
PTuple L
l Boxed
bx [Pat L]
ps)
             else String -> P (Pat L)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Illegal tuple section in pattern"
    UnboxedSum l :: L
l b :: Int
b a :: Int
a e :: 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
l es :: [PExp L]
es      -> do
                  [RPat L]
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)
mapM PExp L -> P (RPat L)
checkRPattern [PExp L]
es
                  if (RPat L -> Bool) -> [RPat L] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all RPat L -> Bool
isStdPat [RPat L]
ps
                    then Pat L -> P (Pat L)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat L -> P (Pat L)) -> ([Pat L] -> Pat L) -> [Pat L] -> P (Pat L)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> [Pat L] -> Pat L
forall l. l -> [Pat l] -> Pat l
PList L
l ([Pat L] -> P (Pat L)) -> [Pat L] -> P (Pat L)
forall a b. (a -> b) -> a -> b
$ (RPat L -> Pat L) -> [RPat L] -> [Pat L]
forall a b. (a -> b) -> [a] -> [b]
map RPat L -> Pat L
stripRP [RPat L]
ps
                    -- we don't allow truly regular patterns unless the extension is enabled
                    else KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
RegularPatterns P () -> P (Pat L) -> P (Pat L)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pat L -> P (Pat L)
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> [RPat L] -> Pat L
forall l. l -> [RPat l] -> Pat l
PRPat L
l ([RPat L] -> Pat L) -> [RPat L] -> Pat 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]
ps)
            where isStdPat :: RPat L -> Bool
                  isStdPat :: RPat L -> Bool
isStdPat (RPPat _ _) = Bool
True
                  isStdPat (RPAs _ _ p :: RPat L
p) = RPat L -> Bool
isStdPat RPat L
p
                  isStdPat (RPParen _ p :: RPat L
p) = RPat L -> Bool
isStdPat RPat L
p
                  isStdPat _           = Bool
False
                  stripRP :: RPat L -> Pat L
                  stripRP :: RPat L -> Pat L
stripRP (RPPat  _ p :: Pat L
p) = Pat L
p
                  stripRP (RPAs l' :: L
l' n :: Name L
n p :: 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
l' p :: 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 _           = String -> Pat L
forall a. HasCallStack => String -> a
error "cannot strip RP wrapper if not all patterns are base"

    Paren l :: L
l e :: PExp L
e      -> do
                  Pat L
p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
                  Pat L -> P (Pat L)
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Pat L -> Pat L
forall l. l -> Pat l -> Pat l
PParen L
l Pat L
p)
    AsPat l :: L
l n :: Name L
n e :: PExp L
e    -> do
                  Pat L
p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
                  Pat L -> P (Pat L)
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Name L -> Pat L -> Pat L
forall l. l -> Name l -> Pat l -> Pat l
PAsPat L
l Name L
n Pat L
p)
    WildCard l :: L
l   -> Pat L -> P (Pat L)
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Pat L
forall l. l -> Pat l
PWildCard L
l)
    IrrPat l :: L
l e :: PExp L
e   -> do
                  Pat L
p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
                  Pat L -> P (Pat L)
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Pat L -> Pat L
forall l. l -> Pat l -> Pat l
PIrrPat L
l Pat L
p)
    ViewPat l :: L
l e :: PExp L
e p :: Pat L
p  -> do
                  Exp L
e1 <- PExp L -> P (Exp L)
checkExpr PExp L
e
                  Pat L -> P (Pat L)
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Exp L -> Pat L -> Pat L
forall l. l -> Exp l -> Pat l -> Pat l
PViewPat L
l Exp L
e1 Pat L
p)
    RecConstr l :: L
l c :: QName L
c fs :: [PFieldUpdate L]
fs   -> do
                  [PatField L]
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)
mapM PFieldUpdate L -> P (PatField L)
checkPatField [PFieldUpdate L]
fs
                  Pat L -> P (Pat L)
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> QName L -> [PatField L] -> Pat L
forall l. l -> QName l -> [PatField l] -> Pat l
PRec L
l QName L
c [PatField L]
fs')
    NegApp l :: L
l (Lit _ lit :: Literal L
lit) ->
                  let siSign :: SrcSpan
siSign = [SrcSpan] -> SrcSpan
forall a. [a] -> a
last ([SrcSpan] -> SrcSpan) -> (L -> [SrcSpan]) -> L -> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L -> [SrcSpan]
srcInfoPoints (L -> SrcSpan) -> L -> SrcSpan
forall a b. (a -> b) -> a -> b
$ L
l
                      lSign :: L
lSign = SrcSpan -> [SrcSpan] -> L
infoSpan SrcSpan
siSign [SrcSpan
siSign]
                  in do
                    Bool -> P () -> P ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> (Literal L -> Bool) -> Literal L -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Literal L -> Bool
forall a. Literal a -> Bool
isNegatableLiteral (Literal L -> Bool) -> Literal L -> Bool
forall a b. (a -> b) -> a -> b
$ Literal L
lit) (String -> P ()
forall a. String -> P a
patFail (String -> P ()) -> String -> P ()
forall a b. (a -> b) -> a -> b
$ PExp L -> String
forall a. Pretty a => a -> String
prettyPrint PExp L
e')
                    Pat L -> P (Pat L)
forall (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
l e :: PExp L
e t :: 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
                  Pat L
p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
                  Pat L -> P (Pat L)
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Pat L -> Type L -> Pat L
forall l. l -> Pat l -> Type l -> Pat l
PatTypeSig L
l Pat L
p Type L
t)

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

    -- Template Haskell
    SpliceExp l :: L
l e :: Splice L
e -> Pat L -> P (Pat L)
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
l n :: String
n q :: String
q -> Pat L -> P (Pat L)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat L -> P (Pat L)) -> Pat L -> P (Pat L)
forall a b. (a -> b) -> a -> b
$ L -> String -> String -> Pat L
forall l. l -> String -> String -> Pat l
PQuasiQuote L
l String
n String
q

    -- BangPatterns
    BangPat l :: L
l e :: PExp L
e -> do
        Pat L
p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
        Pat L -> P (Pat L)
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 -> Pat L -> Pat L
forall l. l -> Pat l -> Pat l
PBangPat L
l Pat L
p

    PreOp l :: L
l (QVarOp _ (UnQual _ (Symbol _ "!"))) e :: PExp L
e -> do
        KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
BangPatterns
        Pat L
p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
        Pat L -> P (Pat L)
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 -> Pat L -> Pat L
forall l. l -> Pat l -> Pat l
PBangPat L
l Pat L
p

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

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

isNegatableLiteral :: Literal a -> Bool
isNegatableLiteral :: Literal a -> Bool
isNegatableLiteral (Int _ _ _) = Bool
True
isNegatableLiteral (Frac _ _ _) = Bool
True
isNegatableLiteral (PrimInt _ _ _) = Bool
True
isNegatableLiteral (PrimFloat _ _ _) = Bool
True
isNegatableLiteral (PrimDouble _ _ _) = Bool
True
isNegatableLiteral _ = Bool
False

splitBang :: PExp L -> [PExp L] -> (PExp L, [PExp L])
splitBang :: PExp L -> [PExp L] -> (PExp L, [PExp L])
splitBang (App _ f :: PExp L
f x :: PExp L
x) es :: [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 e :: PExp L
e es :: [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
l n :: QName L
n e :: PExp L
e) = do
    Pat L
p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
e []
    PatField L -> P (PatField L)
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> QName L -> Pat L -> PatField L
forall l. l -> QName l -> Pat l -> PatField l
PFieldPat L
l QName L
n Pat L
p)
checkPatField (FieldPun l :: L
l n :: QName L
n) = PatField L -> P (PatField L)
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
l) = PatField L -> P (PatField L)
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
l n :: XName L
n v :: PExp L
v) = do Pat L
p <- PExp L -> [Pat L] -> P (Pat L)
checkPat PExp L
v []
                              PXAttr L -> P (PXAttr L)
forall (m :: * -> *) a. Monad m => a -> m a
return (PXAttr L -> P (PXAttr L)) -> PXAttr L -> P (PXAttr L)
forall a b. (a -> b) -> a -> b
$ L -> XName L -> Pat L -> PXAttr L
forall l. l -> XName l -> Pat l -> PXAttr l
PXAttr L
l XName L
n Pat L
p

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

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

checkRPatOp :: QOp L -> P (RPatOp L)
checkRPatOp :: QOp L -> P (RPatOp L)
checkRPatOp o :: QOp L
o@(QVarOp l :: L
l (UnQual _ (Symbol _ sym :: String
sym))) =
    case String
sym of
     "*"  -> RPatOp L -> P (RPatOp L)
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
     "*!" -> RPatOp L -> P (RPatOp L)
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
     "+"  -> RPatOp L -> P (RPatOp L)
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
     "+!" -> RPatOp L -> P (RPatOp L)
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
     "?"  -> RPatOp L -> P (RPatOp L)
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
     "?!" -> RPatOp L -> P (RPatOp L)
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
     _    -> QOp L -> P (RPatOp L)
forall a b. Pretty a => a -> P b
rpOpFail QOp L
o
checkRPatOp o :: 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 :: a -> P b
rpOpFail sym :: a
sym = String -> P b
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> P b) -> String -> P b
forall a b. (a -> b) -> a -> b
$ "Unrecognized regular pattern operator: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Pretty a => a -> String
prettyPrint a
sym

fixRPOpPrec :: RPat L -> RPat L
fixRPOpPrec :: RPat L -> RPat L
fixRPOpPrec rp' :: RPat L
rp' = case RPat L
rp' of
    RPOp l :: L
l rp :: RPat L
rp rpop :: 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
l rp1 :: RPat L
rp1 rp2 :: 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
l rps :: [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
l n :: Name L
n rp :: 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
l n :: Name L
n rp :: 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
l rp :: 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
rp'

  where fPrecOp :: RPat L -> (RPat L -> RPat L) -> RPat L
        fPrecOp :: RPat L -> (RPat L -> RPat L) -> RPat L
fPrecOp (RPOp l :: L
l rp :: RPat L
rp rpop :: RPatOp L
rpop) f :: 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
l n :: Name L
n rp :: RPat L
rp) f :: 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
l n :: Name L
n rp :: RPat L
rp) f :: 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 rp :: RPat L
rp f :: 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
l n :: Name L
n rp :: RPat L
rp) f :: RPat L -> RPat L
f g :: 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
l n :: Name L
n rp :: RPat L
rp) f :: RPat L -> RPat L
f g :: 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 rp :: RPat L
rp f :: RPat L -> RPat L
f g :: 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 ps' :: [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 [] qs :: [Pat L]
qs = [Pat L] -> [Pat L]
forall a. [a] -> [a]
reverse [Pat L]
qs
        mkCPAux (p :: Pat L
p:ps :: [Pat L]
ps) qs :: [Pat L]
qs = case Pat L
p of
            (PRPat l :: L
l rps :: [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 (\q :: Pat L
q -> L -> Pat L -> RPat L
forall l. l -> Pat l -> RPat l
RPPat (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]
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
l [] rps :: [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 _ (p :: Pat L
p:ps :: [Pat L]
ps) rps :: [RPat L]
rps = case Pat L
p of
            (PXRPats l :: L
l rqs :: [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)
            _               -> L -> [Pat L] -> [RPat L] -> Pat L
mkCRP (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 (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 e' :: PExp L
e' = case PExp L
e' of
    Var l :: L
l v :: QName L
v               -> Exp L -> P (Exp L)
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
l v :: String
v   -> Exp L -> P (Exp L)
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp L -> P (Exp L)) -> Exp L -> P (Exp L)
forall a b. (a -> b) -> a -> b
$ L -> String -> Exp L
forall l. l -> String -> Exp l
S.OverloadedLabel L
l String
v
    IPVar l :: L
l v :: IPName L
v             -> Exp L -> P (Exp L)
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
l c :: QName L
c               -> Exp L -> P (Exp L)
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
l lit :: Literal L
lit             -> Exp L -> P (Exp L)
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
l e1 :: PExp L
e1 op :: QOp L
op e2 :: 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
l e1 :: PExp L
e1 e2 :: 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 _ (Lit _ (PrimWord _ _ _))
                          -> String -> P (Exp L)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> P (Exp L)) -> String -> P (Exp L)
forall a b. (a -> b) -> a -> b
$ "Parse error: negative primitive word literal: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PExp L -> String
forall a. Pretty a => a -> String
prettyPrint PExp L
e'
    NegApp l :: L
l e :: 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 loc :: L
loc ps :: [Pat L]
ps e :: 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
l bs :: Binds L
bs e :: 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
l e1 :: PExp L
e1 e2 :: PExp L
e2 e3 :: 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
l alts :: [GuardedRhs L]
alts        -> Exp L -> P (Exp L)
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
l e :: PExp L
e alts :: [Alt L]
alts         -> do
                     Exp L
e1 <- PExp L -> P (Exp L)
checkExpr PExp L
e
                     Exp L -> P (Exp L)
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Exp L -> [Alt L] -> Exp L
forall l. l -> Exp l -> [Alt l] -> Exp l
S.Case L
l Exp L
e1 [Alt L]
alts)
    Do l :: L
l stmts :: [Stmt L]
stmts            -> [Stmt L] -> P ()
forall t. [Stmt t] -> P ()
checkDo [Stmt L]
stmts P () -> P (Exp L) -> P (Exp L)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Exp L -> P (Exp L)
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
l stmts :: [Stmt L]
stmts           -> [Stmt L] -> P ()
forall t. [Stmt t] -> P ()
checkDo [Stmt L]
stmts P () -> P (Exp L) -> P (Exp L)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Exp L -> P (Exp L)
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
l bx :: Boxed
bx mes :: [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
                                     [Maybe (Exp L)]
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)
mapM Maybe (PExp L) -> P (Maybe (Exp L))
mCheckExpr [Maybe (PExp L)]
mes
                                     Exp L -> P (Exp L)
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 -> Boxed -> [Maybe (Exp L)] -> Exp L
forall l. l -> Boxed -> [Maybe (Exp l)] -> Exp l
S.TupleSection L
l Boxed
bx [Maybe (Exp L)]
mes'
    UnboxedSum l :: L
l before :: Int
before after :: Int
after e :: 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
l es :: [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
l es :: [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
l e :: PExp L
e         -> case PExp L
e of
                          PostOp _ e1 :: PExp L
e1 op :: 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  _ op :: QOp L
op e2 :: 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 -> (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
l c :: QName L
c fields :: [PFieldUpdate L]
fields      -> do
                     [FieldUpdate L]
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)
mapM PFieldUpdate L -> P (FieldUpdate L)
checkField [PFieldUpdate L]
fields
                     Exp L -> P (Exp L)
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> QName L -> [FieldUpdate L] -> Exp L
forall l. l -> QName l -> [FieldUpdate l] -> Exp l
S.RecConstr L
l QName L
c [FieldUpdate L]
fields1)
    RecUpdate l :: L
l e :: PExp L
e fields :: [PFieldUpdate L]
fields      -> do
                     [FieldUpdate L]
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)
mapM PFieldUpdate L -> P (FieldUpdate L)
checkField [PFieldUpdate L]
fields
                     Exp L
e1 <- PExp L -> P (Exp L)
checkExpr PExp L
e
                     Exp L -> P (Exp L)
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Exp L -> [FieldUpdate L] -> Exp L
forall l. l -> Exp l -> [FieldUpdate l] -> Exp l
S.RecUpdate L
l Exp L
e1 [FieldUpdate L]
fields1)
    EnumFrom l :: L
l e :: 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
l e1 :: PExp L
e1 e2 :: 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
l e1 :: PExp L
e1 e2 :: 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
l e1 :: PExp L
e1 e2 :: PExp L
e2 e3 :: 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
l e1 :: PExp L
e1 e2 :: 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
l e1 :: PExp L
e1 e2 :: PExp L
e2 e3 :: 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
l e :: PExp L
e qualss :: [[QualStmt L]]
qualss        -> do
                     Exp L
e1 <- PExp L -> P (Exp L)
checkExpr PExp L
e
                     case [[QualStmt L]]
qualss of
                      [quals :: [QualStmt L]
quals] -> Exp L -> P (Exp L)
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)
                      _       -> Exp L -> P (Exp L)
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
l e :: PExp L
e qualss :: [[QualStmt L]]
qualss        -> do
                     Exp L
e1 <- PExp L -> P (Exp L)
checkExpr PExp L
e
                     Exp L -> P (Exp L)
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.ParArrayComp L
l Exp L
e1 [[QualStmt L]]
qualss)
    ExpTypeSig loc :: L
loc e :: PExp L
e ty :: Type L
ty     -> do
                     Exp L
e1 <- PExp L -> P (Exp L)
checkExpr PExp L
e
                     Exp L -> P (Exp L)
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> Exp L -> Type L -> Exp L
forall l. l -> Exp l -> Type l -> Exp l
S.ExpTypeSig L
loc Exp L
e1 Type L
ty)

    --Template Haskell
    BracketExp l :: L
l e :: Bracket L
e        -> Exp L -> P (Exp L)
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
l e :: Splice L
e         -> Exp L -> P (Exp L)
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
l q :: QName L
q          -> Exp L -> P (Exp L)
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
l q :: QName L
q          -> Exp L -> P (Exp L)
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
l n :: String
n q :: String
q      -> Exp L -> P (Exp L)
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp L -> P (Exp L)) -> Exp L -> P (Exp L)
forall a b. (a -> b) -> a -> b
$ L -> String -> String -> Exp L
forall l. l -> String -> String -> Exp l
S.QuasiQuote L
l String
n String
q

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

    -- Arrows
    Proc l :: L
l p :: Pat L
p e :: PExp L
e              -> do Exp L
e1 <- PExp L -> P (Exp L)
checkExpr PExp L
e
                                  Exp L -> P (Exp L)
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 -> Pat L -> Exp L -> Exp L
forall l. l -> Pat l -> Exp l -> Exp l
S.Proc L
l Pat L
p Exp L
e1
    LeftArrApp l :: L
l e1 :: PExp L
e1 e2 :: 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
l e1 :: PExp L
e1 e2 :: 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
l e1 :: PExp L
e1 e2 :: 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
l e1 :: PExp L
e1 e2 :: 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)

    -- LamdaCase
    LCase l :: L
l alts :: [Alt L]
alts -> Exp L -> P (Exp L)
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
l ty :: Type L
ty   -> Exp L -> P (Exp L)
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

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

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

checkDo :: [Stmt t] -> P ()
checkDo :: [Stmt t] -> P ()
checkDo [] = String -> P ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Parse error: Last statement in a do-block must be an expression"
checkDo [Qualifier _ _] = () -> P ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkDo (_:xs :: [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 :: PExp L -> (Exp L -> a) -> P a
check1Expr e1 :: PExp L
e1 f :: Exp L -> a
f = do
    Exp L
e1' <- PExp L -> P (Exp L)
checkExpr PExp L
e1
    a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp L -> a
f Exp L
e1')

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

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

checkManyExprs :: [PExp L] -> ([S.Exp L] -> a) -> P a
checkManyExprs :: [PExp L] -> ([Exp L] -> a) -> P a
checkManyExprs es :: [PExp L]
es f :: [Exp L] -> a
f = do
    [Exp L]
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)
mapM PExp L -> P (Exp L)
checkExpr [PExp L]
es
    a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Exp L] -> a
f [Exp L]
es')

mCheckExpr :: Maybe (PExp L) -> P (Maybe (S.Exp L))
mCheckExpr :: Maybe (PExp L) -> P (Maybe (Exp L))
mCheckExpr Nothing = Maybe (Exp L) -> P (Maybe (Exp L))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Exp L)
forall a. Maybe a
Nothing
mCheckExpr (Just e :: 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (Exp L) -> P (Maybe (Exp L))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Exp L) -> P (Maybe (Exp L)))
-> (Exp L -> Maybe (Exp L)) -> Exp L -> P (Maybe (Exp L))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp L -> Maybe (Exp L)
forall a. a -> Maybe a
Just

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

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

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

-- A variable binding is parsed as a PatBind.

isFunLhs :: PExp L -> [PExp L] -> P (Maybe (Name L, [PExp L], Bool, [S]))
isFunLhs :: PExp L -> [PExp L] -> P (Maybe (Name L, [PExp L], Bool, [SrcSpan]))
isFunLhs (InfixApp _ l :: PExp L
l (QVarOp loc :: L
loc (UnQual _ op :: Name L
op)) r :: PExp L
r) es :: [PExp L]
es
    | Name L
op Name L -> Name () -> Bool
forall (a :: * -> *) l1 l2.
(Annotated a, Eq (a ())) =>
a l1 -> a l2 -> Bool
=~= () -> String -> Name ()
forall l. l -> String -> Name l
Symbol () "!" = do
        [KnownExtension]
exts <- P [KnownExtension]
getExtensions
        if KnownExtension
BangPatterns KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts
         then let (b :: PExp L
b,bs :: [PExp L]
bs) = PExp L -> [PExp L] -> (PExp L, [PExp L])
splitBang PExp L
r []
                  loc' :: L
loc' = L -> L -> L
combSpanInfo L
loc (PExp L -> L
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PExp L
b)
               in PExp L -> [PExp L] -> P (Maybe (Name L, [PExp L], Bool, [SrcSpan]))
isFunLhs PExp L
l (L -> PExp L -> PExp L
forall l. l -> PExp l -> PExp l
BangPat L
loc' PExp L
b PExp L -> [PExp L] -> [PExp L]
forall a. a -> [a] -> [a]
: [PExp L]
bs [PExp L] -> [PExp L] -> [PExp L]
forall a. [a] -> [a] -> [a]
++ [PExp L]
es)
         else Maybe (Name L, [PExp L], Bool, [SrcSpan])
-> P (Maybe (Name L, [PExp L], Bool, [SrcSpan]))
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, []) -- 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 (ast :: * -> *) l.
Annotated ast =>
(l -> l) -> ast l -> ast l
amap (\s :: L
s -> L
s { srcInfoPoints :: [SrcSpan]
srcInfoPoints = [SrcSpan]
infos }) Name L
op
        in (Maybe (Name L, [PExp L], Bool, [SrcSpan])
-> P (Maybe (Name L, [PExp L], Bool, [SrcSpan]))
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 _ (Var l :: L
l (UnQual _ f :: Name L
f)) e :: PExp L
e) es :: [PExp L]
es = Maybe (Name L, [PExp L], Bool, [SrcSpan])
-> P (Maybe (Name L, [PExp L], Bool, [SrcSpan]))
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 _ f :: PExp L
f e :: PExp L
e) es :: [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 _ (UnQual _ f :: Name L
f)) es :: [PExp L]
es@(_:_) = Maybe (Name L, [PExp L], Bool, [SrcSpan])
-> P (Maybe (Name L, [PExp L], Bool, [SrcSpan]))
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
l f :: PExp L
f) es :: [PExp L]
es@(_:_) = do Maybe (Name L, [PExp L], Bool, [SrcSpan])
mlhs <- PExp L -> [PExp L] -> P (Maybe (Name L, [PExp L], Bool, [SrcSpan]))
isFunLhs PExp L
f [PExp L]
es
                                   case Maybe (Name L, [PExp L], Bool, [SrcSpan])
mlhs of
                                    Just (f' :: Name L
f',es' :: [PExp L]
es',b :: Bool
b,pts :: [SrcSpan]
pts) ->
                                       let [x :: SrcSpan
x,y :: SrcSpan
y] = L -> [SrcSpan]
srcInfoPoints L
l
                                        in Maybe (Name L, [PExp L], Bool, [SrcSpan])
-> P (Maybe (Name L, [PExp L], Bool, [SrcSpan]))
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])
-> P (Maybe (Name L, [PExp L], Bool, [SrcSpan]))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Name L, [PExp L], Bool, [SrcSpan])
forall a. Maybe a
Nothing
isFunLhs _ _ = Maybe (Name L, [PExp L], Bool, [SrcSpan])
-> P (Maybe (Name L, [PExp L], Bool, [SrcSpan]))
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 _ (UnQual l :: L
l n :: Name L
n)) = Name L -> P (Name L)
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 (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 e :: PExp L
e = String -> P (Name L)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> P (Name L)) -> String -> P (Name L)
forall a b. (a -> b) -> a -> b
$ "Left-hand side of type signature is not a variable: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PExp L -> String
forall a. Pretty a => a -> String
prettyPrint PExp L
e

checkExplicitPatSyn :: S -> S -> ([Decl L], [S]) -> S -> P (PatternSynDirection L)
checkExplicitPatSyn :: SrcSpan
-> SrcSpan
-> ([Decl L], [SrcSpan])
-> SrcSpan
-> P (PatternSynDirection L)
checkExplicitPatSyn whereLoc :: SrcSpan
whereLoc openLoc :: SrcSpan
openLoc (decls :: [Decl L]
decls, semis :: [SrcSpan]
semis) closeLoc :: 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)
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 _ pat :: Pat L
pat _ _) =
      case Pat L
pat of
        PApp _ _ _        -> Decl L -> P (Decl L)
forall (m :: * -> *) a. Monad m => a -> m a
return Decl L
p
        PInfixApp _ _ _ _ ->  Decl L -> P (Decl L)
forall (m :: * -> *) a. Monad m => a -> m a
return Decl L
p
        _ -> String -> P (Decl L)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Illegal pattern binding in PatternSynonym"
    checkDecls _                 = String -> P (Decl L)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "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 decls :: [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 (m :: * -> *) a. Monad m => a -> m a
return [ClassDecl L]
decls
  where checkClassMethodDef :: ClassDecl L -> P ()
checkClassMethodDef (ClsDecl _ decl :: Decl L
decl) = Decl L -> P ()
checkMethodDef Decl L
decl
        checkClassMethodDef _ = () -> P ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

checkInstBody :: [InstDecl L] -> P [InstDecl L]
checkInstBody :: [InstDecl L] -> P [InstDecl L]
checkInstBody decls :: [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 (m :: * -> *) a. Monad m => a -> m a
return [InstDecl L]
decls
  where checkInstMethodDef :: InstDecl L -> P ()
checkInstMethodDef (InsDecl _ decl :: Decl L
decl) = Decl L -> P ()
checkMethodDef Decl L
decl
        checkInstMethodDef _ = () -> P ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

checkMethodDef :: Decl L -> P ()
checkMethodDef :: Decl L -> P ()
checkMethodDef (PatBind _ (PVar _ _) _ _) = () -> P ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkMethodDef (PatBind loc :: L
loc _ _ _) =
    String -> P ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "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 _ = () -> P ()
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 loc :: L
loc [name :: Name L
name] typ :: Type L
typ) =
  let (b :: SrcSpan
b:_) = L -> [SrcSpan]
srcInfoPoints L
loc in (Name L, Type L, SrcSpan) -> P (Name L, Type L, SrcSpan)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name L
name,Type L
typ,SrcSpan
b)
checkDefSigDef (TypeSig _ _ _) =
    String -> P (Name L, Type L, SrcSpan)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "default signature must be for a single name"
checkDefSigDef _ =
    String -> P (Name L, Type L, SrcSpan)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "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  _ _ _) = String -> P (Name L)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Illegal qualified name"
checkUnQual (UnQual  l :: L
l n :: Name L
n) = Name L -> P (Name L)
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 (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 _ _) = String -> P (Name L)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Illegal special name"

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


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

checkPrec :: Integer -> P Int
checkPrec :: Integer -> P Int
checkPrec i :: Integer
i | 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
<= 9 = Int -> P Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
i)
            | Bool
otherwise        = String -> P Int
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ("Illegal precedence " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
i)

mkRecConstrOrUpdate :: PExp L -> [PFieldUpdate L] -> P (PExp L)
mkRecConstrOrUpdate :: PExp L -> [PFieldUpdate L] -> P (PExp L)
mkRecConstrOrUpdate (Con l :: L
l c :: QName L
c) fs :: [PFieldUpdate L]
fs       = PExp L -> P (PExp L)
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 e :: PExp L
e         fs :: [PFieldUpdate L]
fs@(_:_) = PExp L -> P (PExp L)
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 (ast :: * -> *) l. Annotated ast => ast l -> l
ann PExp L
e) PExp L
e [PFieldUpdate L]
fs)
mkRecConstrOrUpdate _         _        = String -> P (PExp L)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Empty record update"

updateQNameLoc :: l -> QName l -> QName l
updateQNameLoc :: l -> QName l -> QName l
updateQNameLoc l :: l
l (Qual _ mn :: ModuleName l
mn n :: 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
l (UnQual _ n :: Name l
n)  = l -> Name l -> QName l
forall l. l -> Name l -> QName l
UnQual l
l Name l
n
updateQNameLoc l :: l
l (Special _ s :: 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 [d :: Decl L
d] = Decl L -> P (Decl L)
forall (m :: * -> *) a. Monad m => a -> m a
return Decl L
d
checkSingleDecl ds :: [Decl L]
ds =
    String -> P (Decl L)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> P (Decl L)) -> String -> P (Decl L)
forall a b. (a -> b) -> a -> b
$ "Expected a single declaration, found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Decl L] -> Int
forall (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 revDs :: [Decl L]
revDs [] = [Decl L] -> P [Decl L]
forall (m :: * -> *) a. Monad m => a -> m a
return [Decl L]
revDs
    mergeFunBinds revDs :: [Decl L]
revDs (FunBind l' :: L
l' ms1 :: [Match L]
ms1@(Match _ name :: Name L
name ps :: [Pat L]
ps _ _:_):ds1 :: [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 (t :: * -> *) a. Foldable t => t a -> Int
length [Pat L]
ps
        mergeMatches :: [Match L] -> [Decl L] -> L -> P [Decl L]
mergeMatches ms' :: [Match L]
ms' (FunBind _ ms :: [Match L]
ms@(Match loc :: L
loc name' :: Name L
name' ps' :: [Pat L]
ps' _ _:_):ds :: [Decl L]
ds) l :: 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
            Bool
ignoreArity <- P Bool
getIgnoreFunctionArity
            if [Pat L] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat L]
ps' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
arity Bool -> Bool -> Bool
|| Bool
ignoreArity
              then [Match L] -> [Decl L] -> L -> P [Decl L]
mergeMatches ([Match L]
ms[Match L] -> [Match L] -> [Match L]
forall a. [a] -> [a] -> [a]
++[Match L]
ms') [Decl L]
ds (L
loc L -> L -> L
<++> L
l)
              else String -> P [Decl L]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ("arity mismatch for '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name L -> String
forall a. Pretty a => a -> String
prettyPrint Name L
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'")
                    P [Decl L] -> SrcLoc -> P [Decl L]
forall a. P a -> SrcLoc -> P a
`atSrcLoc` L -> SrcLoc
forall si. SrcInfo si => L -> si
fromSrcInfo L
loc
        mergeMatches ms' :: [Match L]
ms' ds :: [Decl L]
ds l :: 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 revDs :: [Decl L]
revDs (FunBind l' :: L
l' ims1 :: [Match L]
ims1@(InfixMatch _ _ name :: Name L
name _ _ _:_):ds1 :: [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 ims' :: [Match L]
ims' (FunBind _ ims :: [Match L]
ims@(InfixMatch loc :: L
loc _ name' :: Name L
name' _ _ _:_):ds :: [Decl L]
ds) l :: 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 ms' :: [Match L]
ms' ds :: [Decl L]
ds l :: 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 revDs :: [Decl L]
revDs (d :: Decl L
d:ds :: [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 revDs :: [ClassDecl L]
revDs [] = [ClassDecl L] -> P [ClassDecl L]
forall (m :: * -> *) a. Monad m => a -> m a
return [ClassDecl L]
revDs
    mergeClsFunBinds revDs :: [ClassDecl L]
revDs (ClsDecl l' :: L
l' (FunBind _ ms1 :: [Match L]
ms1@(Match _ name :: Name L
name ps :: [Pat L]
ps _ _:_)):ds1 :: [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 (t :: * -> *) a. Foldable t => t a -> Int
length [Pat L]
ps
        mergeMatches :: [Match L] -> [ClassDecl L] -> L -> P [ClassDecl L]
mergeMatches ms' :: [Match L]
ms' (ClsDecl _ (FunBind _ ms :: [Match L]
ms@(Match loc :: L
loc name' :: Name L
name' ps' :: [Pat L]
ps' _ _:_)):ds :: [ClassDecl L]
ds) l :: 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
            Bool
ignoreArity <- P Bool
getIgnoreFunctionArity
            if [Pat L] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat L]
ps' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
arity Bool -> Bool -> Bool
|| Bool
ignoreArity
              then [Match L] -> [ClassDecl L] -> L -> P [ClassDecl L]
mergeMatches ([Match L]
ms[Match L] -> [Match L] -> [Match L]
forall a. [a] -> [a] -> [a]
++[Match L]
ms') [ClassDecl L]
ds (L
loc L -> L -> L
<++> L
l)
              else String -> P [ClassDecl L]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ("arity mismatch for '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name L -> String
forall a. Pretty a => a -> String
prettyPrint Name L
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'")
                    P [ClassDecl L] -> SrcLoc -> P [ClassDecl L]
forall a. P a -> SrcLoc -> P a
`atSrcLoc` L -> SrcLoc
forall si. SrcInfo si => L -> si
fromSrcInfo L
loc
        mergeMatches ms' :: [Match L]
ms' ds :: [ClassDecl L]
ds l :: 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 revDs :: [ClassDecl L]
revDs (ClsDecl l' :: L
l' (FunBind _ ims1 :: [Match L]
ims1@(InfixMatch _ _ name :: Name L
name _ _ _:_)):ds1 :: [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 ims' :: [Match L]
ims' (ClsDecl _ (FunBind _ ims :: [Match L]
ims@(InfixMatch loc :: L
loc _ name' :: Name L
name' _ _ _:_)):ds :: [ClassDecl L]
ds) l :: 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 ms' :: [Match L]
ms' ds :: [ClassDecl L]
ds l :: 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 revDs :: [ClassDecl L]
revDs (d :: ClassDecl L
d:ds :: [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 revDs :: [InstDecl L]
revDs [] = [InstDecl L] -> P [InstDecl L]
forall (m :: * -> *) a. Monad m => a -> m a
return [InstDecl L]
revDs
    mergeInstFunBinds revDs :: [InstDecl L]
revDs (InsDecl l' :: L
l' (FunBind _ ms1 :: [Match L]
ms1@(Match _ name :: Name L
name ps :: [Pat L]
ps _ _:_)):ds1 :: [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 (t :: * -> *) a. Foldable t => t a -> Int
length [Pat L]
ps
        mergeMatches :: [Match L] -> [InstDecl L] -> L -> P [InstDecl L]
mergeMatches ms' :: [Match L]
ms' (InsDecl _ (FunBind _ ms :: [Match L]
ms@(Match loc :: L
loc name' :: Name L
name' ps' :: [Pat L]
ps' _ _:_)):ds :: [InstDecl L]
ds) l :: 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
            Bool
ignoreArity <- P Bool
getIgnoreFunctionArity
            if [Pat L] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat L]
ps' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
arity Bool -> Bool -> Bool
|| Bool
ignoreArity
              then [Match L] -> [InstDecl L] -> L -> P [InstDecl L]
mergeMatches ([Match L]
ms[Match L] -> [Match L] -> [Match L]
forall a. [a] -> [a] -> [a]
++[Match L]
ms') [InstDecl L]
ds (L
loc L -> L -> L
<++> L
l)
              else String -> P [InstDecl L]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ("arity mismatch for '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name L -> String
forall a. Pretty a => a -> String
prettyPrint Name L
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'")
                    P [InstDecl L] -> SrcLoc -> P [InstDecl L]
forall a. P a -> SrcLoc -> P a
`atSrcLoc` L -> SrcLoc
forall si. SrcInfo si => L -> si
fromSrcInfo L
loc
        mergeMatches ms' :: [Match L]
ms' ds :: [InstDecl L]
ds l :: 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 revDs :: [InstDecl L]
revDs (InsDecl l' :: L
l' (FunBind _ ims1 :: [Match L]
ims1@(InfixMatch _ _ name :: Name L
name _ _ _:_)):ds1 :: [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 ims' :: [Match L]
ims' (InsDecl _ (FunBind _ ims :: [Match L]
ims@(InfixMatch loc :: L
loc _ name' :: Name L
name' _ _ _:_)):ds :: [InstDecl L]
ds) l :: 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 ms' :: [Match L]
ms' ds :: [InstDecl L]
ds l :: 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 revDs :: [InstDecl L]
revDs (d :: InstDecl L
d:ds :: [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 _) _  = () -> P ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkDataOrNew (NewType _) [QualConDecl _ _ _ x :: ConDecl L
x] = ConDecl L -> P ()
forall (m :: * -> *) l. MonadFail m => ConDecl l -> m ()
cX ConDecl L
x P () -> P () -> P ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> P ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where cX :: ConDecl l -> m ()
cX (ConDecl _ _ [_]) = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        cX (RecDecl _ _ [_]) = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        cX _ = String -> m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "newtype declaration constructor must have exactly one parameter."
checkDataOrNew _        _  = String -> P ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "newtype declaration must have exactly one constructor."

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

checkSimpleType :: PType L -> P (DeclHead L)
checkSimpleType :: PType L -> P (DeclHead L)
checkSimpleType = String -> PType L -> P (DeclHead L)
checkSimple "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 mstrict :: Maybe (L -> BangType L, SrcSpan)
mstrict munpack :: Maybe (Unpackedness L)
munpack ty :: PType L
ty =
  case (Maybe (L -> BangType L, SrcSpan)
mstrict,Maybe (Unpackedness L)
munpack) of
    (Nothing, Just upack :: 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 (ast :: * -> *) l. Annotated ast => ast l -> l
ann Unpackedness L
upack L -> L -> 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 (strict :: L -> BangType L
strict, pos :: SrcSpan
pos), _)  ->
      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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 (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
    (Nothing, Nothing) -> PType L
ty


checkType :: PType L -> P (S.Type L)
checkType :: PType L -> P (Type L)
checkType t :: 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 t :: PType L
t simple :: Bool
simple = case PType L
t of
    TyForall l :: L
l Nothing cs :: Maybe (PContext L)
cs pt :: 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
            Maybe (Context L)
ctxt <- Maybe (PContext L) -> P (Maybe (Context L))
checkContext Maybe (PContext L)
cs
            PType L -> (Type L -> Type L) -> P (Type L)
check1Type PType L
pt (L -> Maybe [TyVarBind L] -> Maybe (Context L) -> Type L -> Type L
forall l.
l -> Maybe [TyVarBind l] -> Maybe (Context l) -> Type l -> Type l
S.TyForall L
l Maybe [TyVarBind L]
forall a. Maybe a
Nothing Maybe (Context L)
ctxt)
    TyForall l :: L
l tvs :: Maybe [TyVarBind L]
tvs cs :: Maybe (PContext L)
cs pt :: PType L
pt -> do
            KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
ExplicitForAll
            Maybe (Context L)
ctxt <- Maybe (PContext L) -> P (Maybe (Context L))
checkContext Maybe (PContext L)
cs
            PType L -> (Type L -> Type L) -> P (Type L)
check1Type PType L
pt (L -> Maybe [TyVarBind L] -> Maybe (Context L) -> Type L -> Type L
forall l.
l -> Maybe [TyVarBind l] -> Maybe (Context l) -> Type l -> Type l
S.TyForall L
l Maybe [TyVarBind L]
tvs Maybe (Context L)
ctxt)
    TyStar  l :: L
l         -> Type L -> P (Type L)
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
l at :: PType L
at rt :: 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
l b :: Boxed
b pts :: [PType L]
pts   -> [PType L] -> P [Type L]
checkTypes [PType L]
pts P [Type L] -> ([Type L] -> P (Type L)) -> P (Type L)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type L -> P (Type L)
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
l es :: [PType L]
es -> [PType L] -> P [Type L]
checkTypes [PType L]
es P [Type L] -> ([Type L] -> P (Type L)) -> P (Type L)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type L -> P (Type L)
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
l pt :: 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
l pt :: 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
l ft :: PType L
ft at :: 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
l n :: Name L
n       -> Type L -> P (Type L)
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
l n :: QName L
n       -> do
            QName L -> P ()
checkAndWarnTypeOperators QName L
n
            Type L -> P (Type L)
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
l pt :: 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
l at :: PType L
at op :: MaybePromotedName L
op bt :: 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 (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
l pt :: PType L
pt k :: 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
l p :: Promoted L
p -> Type L -> P (Type L)
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
l at :: PType L
at bt :: 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
l s :: Splice L
s        -> do
                              KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
TemplateHaskell
                              Type L -> P (Type L)
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
l b :: BangType L
b u :: Unpackedness L
u t' :: 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
l mn :: Maybe (Name L)
mn -> Type L -> P (Type L)
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
l n :: String
n s :: String
s -> do
                              KnownExtension -> P ()
forall e. (Show e, Enabled e) => e -> P ()
checkEnabled KnownExtension
QuasiQuotes
                              Type L -> P (Type L)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type L -> P (Type L)) -> Type L -> P (Type L)
forall a b. (a -> b) -> a -> b
$ L -> String -> String -> Type L
forall l. l -> String -> String -> Type l
S.TyQuasiQuote L
l String
n String
s
    _   -> String -> P (Type L)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> P (Type L)) -> String -> P (Type L)
forall a b. (a -> b) -> a -> b
$ "Parse error in type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PType L -> String
forall a. Pretty a => a -> String
prettyPrint PType L
t

getMaybePromotedQName :: MaybePromotedName l -> QName l
getMaybePromotedQName :: MaybePromotedName l -> QName l
getMaybePromotedQName (PromotedName _ q :: QName l
q) = QName l
q
getMaybePromotedQName (UnpromotedName _ q :: 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 pt :: PType L
pt f :: 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type L -> P (Type L)
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 at :: PType L
at bt :: PType L
bt f :: 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a :: 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \b :: Type L
b -> Type L -> P (Type L)
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)
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 n :: Name L
n = do
  [KnownExtension]
e <- P [KnownExtension]
getExtensions
  PType L -> P (PType L)
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
$
    case Name L
n of
      Ident il :: L
il ('_':ident :: String
ident) | KnownExtension
NamedWildCards KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
e ->
        L -> Maybe (Name L) -> PType L
forall l. l -> Maybe (Name l) -> PType l
TyWildCard L
il (Name L -> Maybe (Name L)
forall a. a -> Maybe a
Just (L -> String -> Name L
forall l. l -> String -> Name l
Ident (L -> L
reduceSrcSpanInfo L
il) String
ident))
      _ ->
        L -> Name L -> PType L
forall l. l -> Name l -> PType l
TyVar (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 spaninfo :: L
spaninfo =
      let ss :: SrcSpan
ss = L -> SrcSpan
srcInfoSpan L
spaninfo
          ss' :: SrcSpan
ss' = SrcSpan
ss { srcSpanStartColumn :: Int
srcSpanStartColumn = SrcSpan -> Int
srcSpanStartColumn SrcSpan
ss Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1 }
      in  L
spaninfo { srcInfoSpan :: SrcSpan
srcInfoSpan = SrcSpan
ss' }
---------------------------------------
-- Check kinds

-- ConstraintKinds allow the kind "Constraint", but not "Nat", etc. Specifically
-- test for that.
checkKind :: Kind l -> P ()
checkKind :: Kind l -> P ()
checkKind k :: Kind l
k = case Kind l
k of
        S.TyVar _ q :: 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 :: Name l
name = case Name l
name of
                    Ident _ n :: String
n -> String
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "Constraint"
                    _                      -> Bool
False

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

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

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

---------------------------------------
-- 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
l mtvs :: Maybe [TyVarBind L]
mtvs ctxt :: Maybe (PContext L)
ctxt ty :: PType L
ty =
    case (Maybe (PContext L)
ctxt, PType L
ty) of
        (Nothing, TyForall _ Nothing ctxt2 :: Maybe (PContext L)
ctxt2 ty2 :: 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
        _                                       -> 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 String, L)] -> P (Decl L)
mkRoleAnnotDecl l1 :: SrcSpan
l1 l2 :: SrcSpan
l2 tycon :: QName L
tycon roles :: [(Maybe String, L)]
roles
  = do [Role L]
roles' <- ((Maybe String, L) -> P (Role L))
-> [(Maybe String, L)] -> P [Role L]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe String, L) -> P (Role L)
forall (m :: * -> *) l.
MonadFail m =>
(Maybe String, l) -> m (Role l)
parse_role [(Maybe String, L)]
roles
       Decl L -> P (Decl L)
forall (m :: * -> *) a. Monad m => a -> m a
return (L -> QName L -> [Role L] -> Decl L
forall l. l -> QName l -> [Role l] -> Decl l
RoleAnnotDecl L
loc' QName L
tycon [Role L]
roles')
  where
    loc' :: L
loc' =
      case [(Maybe String, L)]
roles of
        [] -> (SrcSpan
l1 SrcSpan -> SrcSpan -> L
<^^> SrcSpan
l2 L -> L -> L
<++> QName L -> L
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann QName L
tycon) L -> [SrcSpan] -> L
<** [SrcSpan
l1, SrcSpan
l2]
        _  -> (SrcSpan
l1 SrcSpan -> SrcSpan -> L
<^^> SrcSpan
l2 L -> L -> 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 (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 L -> L -> L
(<++>) (((Maybe String, L) -> L) -> [(Maybe String, L)] -> [L]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe String, L) -> L
forall a b. (a, b) -> b
snd [(Maybe String, L)]
roles)) L -> [SrcSpan] -> L
<** [SrcSpan
l1, SrcSpan
l2]
    possible_roles :: [(String, l -> Role l)]
possible_roles = [ ("phantom", l -> Role l
forall l. l -> Role l
S.Phantom)
                     , ("representational", l -> Role l
forall l. l -> Role l
S.Representational)
                     , ("nominal", l -> Role l
forall l. l -> Role l
S.Nominal)]

    parse_role :: (Maybe String, l) -> m (Role l)
parse_role (Nothing, loc_role :: l
loc_role) = Role l -> m (Role l)
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 role :: String
role, loc_role :: l
loc_role)
      = case String -> [(String, l -> Role l)] -> Maybe (l -> Role l)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
role [(String, l -> Role l)]
forall l. [(String, l -> Role l)]
possible_roles of
          Just found_role :: l -> Role l
found_role -> Role l -> m (Role l)
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
          Nothing         ->
            String -> m (Role l)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ("Illegal role name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
role)




mkAssocType :: S -> PType L -> (Maybe (ResultSig L), Maybe (S, S.Type L), Maybe (InjectivityInfo L)) -> P (ClassDecl L)
mkAssocType :: SrcSpan
-> PType L
-> (Maybe (ResultSig L), Maybe (SrcSpan, Type L),
    Maybe (InjectivityInfo L))
-> P (ClassDecl L)
mkAssocType tyloc :: SrcSpan
tyloc ty :: PType L
ty (mres :: Maybe (ResultSig L)
mres, mty :: Maybe (SrcSpan, Type L)
mty, minj :: Maybe (InjectivityInfo L)
minj)  =
  case (Maybe (ResultSig L)
mres,Maybe (SrcSpan, Type L)
mty, Maybe (InjectivityInfo L)
minj) of
    -- No additional information
    (Nothing, Nothing, Nothing) -> do
      DeclHead L
dh <- PType L -> P (DeclHead L)
checkSimpleType PType L
ty
      ClassDecl L -> P (ClassDecl L)
forall (m :: * -> *) a. Monad m => a -> m a
return (ClassDecl L -> P (ClassDecl L)) -> ClassDecl L -> P (ClassDecl L)
forall a b. (a -> b) -> a -> b
$ L
-> DeclHead L
-> Maybe (ResultSig L)
-> Maybe (InjectivityInfo L)
-> ClassDecl L
forall l.
l
-> DeclHead l
-> Maybe (ResultSig l)
-> Maybe (InjectivityInfo l)
-> ClassDecl l
ClsTyFam (SrcSpan -> L
noInfoSpan SrcSpan
tyloc L -> L -> L
<++> PType L -> L
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PType L
ty) DeclHead L
dh Maybe (ResultSig L)
forall a. Maybe a
Nothing Maybe (InjectivityInfo L)
forall a. Maybe a
Nothing
    -- Type default
    (_, Just (eqloc :: SrcSpan
eqloc, rhsty :: Type L
rhsty), Nothing) -> do
      Type L
ty' <- PType L -> P (Type L)
checkType PType L
ty
      let tyeq :: TypeEqn L
tyeq = L -> Type L -> Type L -> TypeEqn L
forall l. l -> Type l -> Type l -> TypeEqn l
TypeEqn (PType L -> L
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PType L
ty L -> L -> 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
      ClassDecl L -> P (ClassDecl L)
forall (m :: * -> *) a. Monad m => a -> m a
return (ClassDecl L -> P (ClassDecl L)) -> ClassDecl L -> P (ClassDecl L)
forall a b. (a -> b) -> a -> b
$ L -> TypeEqn L -> ClassDecl L
forall l. l -> TypeEqn l -> ClassDecl l
ClsTyDef (SrcSpan -> L
noInfoSpan SrcSpan
tyloc L -> L -> L
<++> PType L -> L
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PType L
ty L -> [SrcSpan] -> L
<** [SrcSpan
tyloc]) TypeEqn L
tyeq
    -- Declaration with kind sig
    (Just ressig :: ResultSig L
ressig, _, _) -> do
      DeclHead L
dh <- PType L -> P (DeclHead L)
checkSimpleType PType L
ty
      ClassDecl L -> P (ClassDecl L)
forall (m :: * -> *) a. Monad m => a -> m a
return (ClassDecl L -> P (ClassDecl L)) -> ClassDecl L -> P (ClassDecl L)
forall a b. (a -> b) -> a -> b
$ L
-> DeclHead L
-> Maybe (ResultSig L)
-> Maybe (InjectivityInfo L)
-> ClassDecl L
forall l.
l
-> DeclHead l
-> Maybe (ResultSig l)
-> Maybe (InjectivityInfo l)
-> ClassDecl l
ClsTyFam (SrcSpan -> L
noInfoSpan SrcSpan
tyloc L -> L -> L
<++> ResultSig L -> L
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann ResultSig L
ressig L -> [SrcSpan] -> L
<** [SrcSpan
tyloc]) DeclHead L
dh (ResultSig L -> Maybe (ResultSig L)
forall a. a -> Maybe a
Just ResultSig L
ressig) Maybe (InjectivityInfo L)
forall a. Maybe a
Nothing
    -- Decl with inj info
    (Nothing, Just (eqloc :: SrcSpan
eqloc, rhsty :: Type L
rhsty), Just injinfo :: InjectivityInfo L
injinfo) -> do
      ResultSig L
ressig <- SrcSpan -> Type L -> P (ResultSig L)
checkKTyVar SrcSpan
eqloc Type L
rhsty
      DeclHead L
dh <- PType L -> P (DeclHead L)
checkSimpleType PType L
ty
      ClassDecl L -> P (ClassDecl L)
forall (m :: * -> *) a. Monad m => a -> m a
return (ClassDecl L -> P (ClassDecl L)) -> ClassDecl L -> P (ClassDecl L)
forall a b. (a -> b) -> a -> b
$ L
-> DeclHead L
-> Maybe (ResultSig L)
-> Maybe (InjectivityInfo L)
-> ClassDecl L
forall l.
l
-> DeclHead l
-> Maybe (ResultSig l)
-> Maybe (InjectivityInfo l)
-> ClassDecl l
ClsTyFam (SrcSpan -> L
noInfoSpan SrcSpan
tyloc L -> L -> L
<++> InjectivityInfo L -> L
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann InjectivityInfo L
injinfo L -> [SrcSpan] -> L
<** [SrcSpan
tyloc]) DeclHead L
dh (ResultSig L -> Maybe (ResultSig L)
forall a. a -> Maybe a
Just ResultSig L
ressig) Maybe (InjectivityInfo L)
minj
    _ -> String -> P (ClassDecl L)
forall a. HasCallStack => String -> a
error "mkAssocType"

  where
    checkKTyVar :: S -> S.Type L -> P (ResultSig L)
    checkKTyVar :: SrcSpan -> Type L -> P (ResultSig L)
checkKTyVar eqloc :: SrcSpan
eqloc rhsty :: Type L
rhsty =
      case Type L
rhsty of
       S.TyVar l :: L
l n :: Name L
n -> ResultSig L -> P (ResultSig L)
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
l (S.TyVar _ n :: Name L
n) k :: Type L
k -> ResultSig L -> P (ResultSig L)
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)
       _ -> String -> P (ResultSig L)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ("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 t :: PType L
t = PType L -> PType L
go PType L
t
  where go :: PType L -> PType L
go (TyApp loc :: L
loc t1 :: PType L
t1 t2 :: PType L
t2)
          | TyBang _ (LazyTy eqloc :: L
eqloc) (NoUnpackPragma _) t2' :: 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 eqloc :: L
eqloc tl :: PType L
tl tr :: 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 (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 (ast :: * -> *) l. Annotated ast => ast l -> l
ann PType L
tr L -> L -> L
<++> PType L -> L
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann PType L
t2) PType L
tr PType L
t2)
              t' :: 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 t' :: 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 loc :: L
loc qn :: QName L
qn mcns :: [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 (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 (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 _ = 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)
               (\(n :: Int
n,Left s :: 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 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 :: Either a b -> Bool
checkLeft (Left _) = Bool
True
    checkLeft _ = 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 :: Int -> (a -> Bool) -> [a] -> Maybe (Int, a)
findWithIndex _ _ [] = Maybe (Int, a)
forall a. Maybe a
Nothing
    findWithIndex n :: Int
n p :: a -> Bool
p (x :: a
x:xs :: [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
+ 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 Unboxed s :: L
s (SSum before :: Int
before after :: Int
after e :: PExp L
e) = PExp L -> P (PExp L)
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 boxity :: Boxed
boxity s :: L
s (STuple ms :: [Maybe (PExp L)]
ms) =
    PExp L -> P (PExp L)
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 _s :: L
_s (SSum {}) = String -> P (PExp L)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Boxed sums are not implemented"