{-# LANGUAGE TemplateHaskell, LambdaCase, CPP, ScopedTypeVariables,
TupleSections, DeriveDataTypeable, DeriveGeneric #-}
module Language.Haskell.TH.Desugar.Core where
import Prelude hiding (mapM, foldl, foldr, all, elem, exp, concatMap, and)
import Language.Haskell.TH hiding (match, clause, cxt)
import Language.Haskell.TH.Syntax hiding (lift)
import Language.Haskell.TH.Datatype ( resolveTypeSynonyms )
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative
#endif
import Control.Monad hiding (forM_, mapM)
import qualified Control.Monad.Fail as Fail
import Control.Monad.Zip
import Control.Monad.Writer hiding (forM_, mapM)
import Data.Data (Data, Typeable)
import Data.Either (lefts)
import Data.Foldable as F hiding (concat, notElem)
import qualified Data.Map as M
import Data.Map (Map)
import Data.Maybe (mapMaybe)
import qualified Data.Set as S
import Data.Set (Set)
import Data.Traversable
#if __GLASGOW_HASKELL__ > 710
import Data.Maybe (isJust)
#endif
#if __GLASGOW_HASKELL__ >= 800
import qualified Control.Monad.Fail as MonadFail
#endif
#if __GLASGOW_HASKELL__ >= 803
import GHC.OverloadedLabels ( fromLabel )
#endif
#if __GLASGOW_HASKELL__ >= 807
import GHC.Classes (IP(..))
#endif
import GHC.Exts
import GHC.Generics (Generic)
import Language.Haskell.TH.Desugar.AST
import Language.Haskell.TH.Desugar.FV
import qualified Language.Haskell.TH.Desugar.OSet as OS
import Language.Haskell.TH.Desugar.OSet (OSet)
import Language.Haskell.TH.Desugar.Util
import Language.Haskell.TH.Desugar.Reify
dsExp :: DsMonad q => Exp -> q DExp
dsExp :: Exp -> q DExp
dsExp (VarE n :: Name
n) = DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DVarE Name
n
dsExp (ConE n :: Name
n) = DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DConE Name
n
dsExp (LitE lit :: Lit
lit) = DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ Lit -> DExp
DLitE Lit
lit
dsExp (AppE e1 :: Exp
e1 e2 :: Exp
e2) = DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
e1 q (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
e2
dsExp (InfixE Nothing op :: Exp
op Nothing) = Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
op
dsExp (InfixE (Just lhs :: Exp
lhs) op :: Exp
op Nothing) = DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
op) q (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
lhs)
dsExp (InfixE Nothing op :: Exp
op (Just rhs :: Exp
rhs)) = do
Name
lhsName <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName "lhs"
DExp
op' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
op
DExp
rhs' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
rhs
DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [Name] -> DExp -> DExp
DLamE [Name
lhsName] ((DExp -> DExp -> DExp) -> DExp -> [DExp] -> DExp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DExp -> DExp -> DExp
DAppE DExp
op' [Name -> DExp
DVarE Name
lhsName, DExp
rhs'])
dsExp (InfixE (Just lhs :: Exp
lhs) op :: Exp
op (Just rhs :: Exp
rhs)) =
DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
op q (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
lhs) q (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
rhs
dsExp (UInfixE _ _ _) =
String -> q DExp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Cannot desugar unresolved infix operators."
dsExp (ParensE exp :: Exp
exp) = Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
dsExp (LamE pats :: [Pat]
pats exp :: Exp
exp) = [Pat] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [Pat] -> DExp -> q DExp
dsLam [Pat]
pats (DExp -> q DExp) -> q DExp -> q DExp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
dsExp (LamCaseE matches :: [Match]
matches) = do
Name
x <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName "x"
[DMatch]
matches' <- Name -> [Match] -> q [DMatch]
forall (q :: * -> *). DsMonad q => Name -> [Match] -> q [DMatch]
dsMatches Name
x [Match]
matches
DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [Name] -> DExp -> DExp
DLamE [Name
x] (DExp -> [DMatch] -> DExp
DCaseE (Name -> DExp
DVarE Name
x) [DMatch]
matches')
dsExp (TupE exps :: [Exp]
exps) = (Int -> Name) -> [Exp] -> q DExp
forall (q :: * -> *). DsMonad q => (Int -> Name) -> [Exp] -> q DExp
dsTup Int -> Name
tupleDataName [Exp]
exps
dsExp (UnboxedTupE exps :: [Exp]
exps) = (Int -> Name) -> [Exp] -> q DExp
forall (q :: * -> *). DsMonad q => (Int -> Name) -> [Exp] -> q DExp
dsTup Int -> Name
unboxedTupleDataName [Exp]
exps
dsExp (CondE e1 :: Exp
e1 e2 :: Exp
e2 e3 :: Exp
e3) =
Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp (Exp -> [Match] -> Exp
CaseE Exp
e1 [ Pat -> Body -> [Dec] -> Match
Match (Name -> [Pat] -> Pat
ConP 'True []) (Exp -> Body
NormalB Exp
e2) []
, Pat -> Body -> [Dec] -> Match
Match (Name -> [Pat] -> Pat
ConP 'False []) (Exp -> Body
NormalB Exp
e3) [] ])
dsExp (MultiIfE guarded_exps :: [(Guard, Exp)]
guarded_exps) =
let failure :: DExp
failure = DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'error) (Lit -> DExp
DLitE (String -> Lit
StringL "Non-exhaustive guards in multi-way if")) in
[(Guard, Exp)] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [(Guard, Exp)] -> DExp -> q DExp
dsGuards [(Guard, Exp)]
guarded_exps DExp
failure
dsExp (LetE decs :: [Dec]
decs exp :: Exp
exp) = do
(decs' :: [DLetDec]
decs', ip_binder :: DExp -> DExp
ip_binder) <- [Dec] -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
decs
DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
DLetE [DLetDec]
decs' (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp
ip_binder DExp
exp'
dsExp (CaseE (VarE scrutinee :: Name
scrutinee) matches :: [Match]
matches) = do
[DMatch]
matches' <- Name -> [Match] -> q [DMatch]
forall (q :: * -> *). DsMonad q => Name -> [Match] -> q [DMatch]
dsMatches Name
scrutinee [Match]
matches
DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ DExp -> [DMatch] -> DExp
DCaseE (Name -> DExp
DVarE Name
scrutinee) [DMatch]
matches'
dsExp (CaseE exp :: Exp
exp matches :: [Match]
matches) = do
Name
scrutinee <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName "scrutinee"
DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
[DMatch]
matches' <- Name -> [Match] -> q [DMatch]
forall (q :: * -> *). DsMonad q => Name -> [Match] -> q [DMatch]
dsMatches Name
scrutinee [Match]
matches
DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
DLetE [DPat -> DExp -> DLetDec
DValD (Name -> DPat
DVarP Name
scrutinee) DExp
exp'] (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$
DExp -> [DMatch] -> DExp
DCaseE (Name -> DExp
DVarE Name
scrutinee) [DMatch]
matches'
dsExp (DoE stmts :: [Stmt]
stmts) = [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsDoStmts [Stmt]
stmts
dsExp (CompE stmts :: [Stmt]
stmts) = [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp [Stmt]
stmts
dsExp (ArithSeqE (FromR exp :: Exp
exp)) = DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'enumFrom) (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
dsExp (ArithSeqE (FromThenR exp1 :: Exp
exp1 exp2 :: Exp
exp2)) =
DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'enumFromThen) (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp1) q (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp2
dsExp (ArithSeqE (FromToR exp1 :: Exp
exp1 exp2 :: Exp
exp2)) =
DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'enumFromTo) (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp1) q (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp2
dsExp (ArithSeqE (FromThenToR e1 :: Exp
e1 e2 :: Exp
e2 e3 :: Exp
e3)) =
DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'enumFromThenTo) (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
e1) q (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
e2) q (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
e3
dsExp (ListE exps :: [Exp]
exps) = [Exp] -> q DExp
forall (m :: * -> *). DsMonad m => [Exp] -> m DExp
go [Exp]
exps
where go :: [Exp] -> m DExp
go [] = DExp -> m DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> m DExp) -> DExp -> m DExp
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DConE '[]
go (h :: Exp
h : t :: [Exp]
t) = DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> m DExp -> m (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> DExp -> DExp
DAppE (Name -> DExp
DConE '(:)) (DExp -> DExp) -> m DExp -> m DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> m DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
h) m (DExp -> DExp) -> m DExp -> m DExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Exp] -> m DExp
go [Exp]
t
dsExp (SigE exp :: Exp
exp ty :: Type
ty) = DExp -> DType -> DExp
DSigE (DExp -> DType -> DExp) -> q DExp -> q (DType -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp q (DType -> DExp) -> q DType -> q DExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty
dsExp (RecConE con_name :: Name
con_name field_exps :: [FieldExp]
field_exps) = do
Con
con <- Name -> q Con
forall (q :: * -> *). DsMonad q => Name -> q Con
dataConNameToCon Name
con_name
[DExp]
reordered <- Con -> q [DExp]
forall (m :: * -> *). DsMonad m => Con -> m [DExp]
reorder Con
con
DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ (DExp -> DExp -> DExp) -> DExp -> [DExp] -> DExp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DExp -> DExp -> DExp
DAppE (Name -> DExp
DConE Name
con_name) [DExp]
reordered
where
reorder :: Con -> m [DExp]
reorder con :: Con
con = case Con
con of
NormalC _name :: Name
_name fields :: [BangType]
fields -> [BangType] -> m [DExp]
forall (m :: * -> *) (t :: * -> *) a.
(Foldable t, MonadFail m) =>
t a -> m [DExp]
non_record [BangType]
fields
InfixC field1 :: BangType
field1 _name :: Name
_name field2 :: BangType
field2 -> [BangType] -> m [DExp]
forall (m :: * -> *) (t :: * -> *) a.
(Foldable t, MonadFail m) =>
t a -> m [DExp]
non_record [BangType
field1, BangType
field2]
RecC _name :: Name
_name fields :: [VarBangType]
fields -> [VarBangType] -> m [DExp]
forall (q :: * -> *). DsMonad q => [VarBangType] -> q [DExp]
reorder_fields [VarBangType]
fields
ForallC _ _ c :: Con
c -> Con -> m [DExp]
reorder Con
c
#if __GLASGOW_HASKELL__ >= 800
GadtC _names :: [Name]
_names fields :: [BangType]
fields _ret_ty :: Type
_ret_ty -> [BangType] -> m [DExp]
forall (m :: * -> *) (t :: * -> *) a.
(Foldable t, MonadFail m) =>
t a -> m [DExp]
non_record [BangType]
fields
RecGadtC _names :: [Name]
_names fields :: [VarBangType]
fields _ret_ty :: Type
_ret_ty -> [VarBangType] -> m [DExp]
forall (q :: * -> *). DsMonad q => [VarBangType] -> q [DExp]
reorder_fields [VarBangType]
fields
#endif
reorder_fields :: [VarBangType] -> q [DExp]
reorder_fields fields :: [VarBangType]
fields = Name -> [VarBangType] -> [FieldExp] -> [DExp] -> q [DExp]
forall (q :: * -> *).
DsMonad q =>
Name -> [VarBangType] -> [FieldExp] -> [DExp] -> q [DExp]
reorderFields Name
con_name [VarBangType]
fields [FieldExp]
field_exps
(DExp -> [DExp]
forall a. a -> [a]
repeat (DExp -> [DExp]) -> DExp -> [DExp]
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DVarE 'undefined)
non_record :: t a -> m [DExp]
non_record fields :: t a
fields | [FieldExp] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldExp]
field_exps
= [DExp] -> m [DExp]
forall (m :: * -> *) a. Monad m => a -> m a
return ([DExp] -> m [DExp]) -> [DExp] -> m [DExp]
forall a b. (a -> b) -> a -> b
$ Int -> DExp -> [DExp]
forall a. Int -> a -> [a]
replicate (t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
fields) (DExp -> [DExp]) -> DExp -> [DExp]
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DVarE 'undefined
| Bool
otherwise =
String -> m [DExp]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible (String -> m [DExp]) -> String -> m [DExp]
forall a b. (a -> b) -> a -> b
$ "Record syntax used with non-record constructor "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Name -> String
forall a. Show a => a -> String
show Name
con_name) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "."
dsExp (RecUpdE exp :: Exp
exp field_exps :: [FieldExp]
field_exps) = do
Name
first_name <- case [FieldExp]
field_exps of
((name :: Name
name, _) : _) -> Name -> q Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
name
_ -> String -> q Name
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "Record update with no fields listed."
Info
info <- Name -> q Info
forall (q :: * -> *). DsMonad q => Name -> q Info
reifyWithLocals Name
first_name
Type
applied_type <- case Info
info of
#if __GLASGOW_HASKELL__ > 710
VarI _name :: Name
_name ty :: Type
ty _m_dec :: Maybe Dec
_m_dec -> Type -> q Type
forall (q :: * -> *). DsMonad q => Type -> q Type
extract_first_arg Type
ty
#else
VarI _name ty _m_dec _fixity -> extract_first_arg ty
#endif
_ -> String -> q Type
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "Record update with an invalid field name."
Name
type_name <- Type -> q Name
forall (q :: * -> *). DsMonad q => Type -> q Name
extract_type_name Type
applied_type
(_, cons :: [Con]
cons) <- String -> Name -> q ([TyVarBndr], [Con])
forall (q :: * -> *).
DsMonad q =>
String -> Name -> q ([TyVarBndr], [Con])
getDataD "This seems to be an error in GHC." Name
type_name
let filtered_cons :: [Con]
filtered_cons = [Con] -> [Name] -> [Con]
forall (t :: * -> *). Foldable t => [Con] -> t Name -> [Con]
filter_cons_with_names [Con]
cons ((FieldExp -> Name) -> [FieldExp] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldExp -> Name
forall a b. (a, b) -> a
fst [FieldExp]
field_exps)
DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
[DMatch]
matches <- (Con -> q DMatch) -> [Con] -> q [DMatch]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Con -> q DMatch
forall (q :: * -> *). DsMonad q => Con -> q DMatch
con_to_dmatch [Con]
filtered_cons
let all_matches :: [DMatch]
all_matches
| [Con] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Con]
filtered_cons Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Con] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Con]
cons = [DMatch]
matches
| Bool
otherwise = [DMatch]
matches [DMatch] -> [DMatch] -> [DMatch]
forall a. [a] -> [a] -> [a]
++ [DMatch
error_match]
DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ DExp -> [DMatch] -> DExp
DCaseE DExp
exp' [DMatch]
all_matches
where
extract_first_arg :: DsMonad q => Type -> q Type
extract_first_arg :: Type -> q Type
extract_first_arg (AppT (AppT ArrowT arg :: Type
arg) _) = Type -> q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
arg
extract_first_arg (ForallT _ _ t :: Type
t) = Type -> q Type
forall (q :: * -> *). DsMonad q => Type -> q Type
extract_first_arg Type
t
extract_first_arg (SigT t :: Type
t _) = Type -> q Type
forall (q :: * -> *). DsMonad q => Type -> q Type
extract_first_arg Type
t
extract_first_arg _ = String -> q Type
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "Record selector not a function."
extract_type_name :: DsMonad q => Type -> q Name
extract_type_name :: Type -> q Name
extract_type_name (AppT t1 :: Type
t1 _) = Type -> q Name
forall (q :: * -> *). DsMonad q => Type -> q Name
extract_type_name Type
t1
extract_type_name (SigT t :: Type
t _) = Type -> q Name
forall (q :: * -> *). DsMonad q => Type -> q Name
extract_type_name Type
t
extract_type_name (ConT n :: Name
n) = Name -> q Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
extract_type_name _ = String -> q Name
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "Record selector domain not a datatype."
filter_cons_with_names :: [Con] -> t Name -> [Con]
filter_cons_with_names cons :: [Con]
cons field_names :: t Name
field_names =
(Con -> Bool) -> [Con] -> [Con]
forall a. (a -> Bool) -> [a] -> [a]
filter Con -> Bool
has_names [Con]
cons
where
args_contain_names :: [(Name, b, c)] -> Bool
args_contain_names args :: [(Name, b, c)]
args =
let con_field_names :: [Name]
con_field_names = ((Name, b, c) -> Name) -> [(Name, b, c)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, b, c) -> Name
forall a b c. (a, b, c) -> a
fst_of_3 [(Name, b, c)]
args in
(Name -> Bool) -> t Name -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
con_field_names) t Name
field_names
has_names :: Con -> Bool
has_names (RecC _con_name :: Name
_con_name args :: [VarBangType]
args) =
[VarBangType] -> Bool
forall b c. [(Name, b, c)] -> Bool
args_contain_names [VarBangType]
args
#if __GLASGOW_HASKELL__ >= 800
has_names (RecGadtC _con_name :: [Name]
_con_name args :: [VarBangType]
args _ret_ty :: Type
_ret_ty) =
[VarBangType] -> Bool
forall b c. [(Name, b, c)] -> Bool
args_contain_names [VarBangType]
args
#endif
has_names (ForallC _ _ c :: Con
c) = Con -> Bool
has_names Con
c
has_names _ = Bool
False
rec_con_to_dmatch :: Name -> [VarBangType] -> m DMatch
rec_con_to_dmatch con_name :: Name
con_name args :: [VarBangType]
args = do
let con_field_names :: [Name]
con_field_names = (VarBangType -> Name) -> [VarBangType] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Name
forall a b c. (a, b, c) -> a
fst_of_3 [VarBangType]
args
[Name]
field_var_names <- (Name -> m Name) -> [Name] -> m [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> m Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName (String -> m Name) -> (Name -> String) -> Name -> m Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) [Name]
con_field_names
DPat -> DExp -> DMatch
DMatch (Name -> [DPat] -> DPat
DConP Name
con_name ((Name -> DPat) -> [Name] -> [DPat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DPat
DVarP [Name]
field_var_names)) (DExp -> DMatch) -> m DExp -> m DMatch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
((DExp -> DExp -> DExp) -> DExp -> [DExp] -> DExp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DExp -> DExp -> DExp
DAppE (Name -> DExp
DConE Name
con_name) ([DExp] -> DExp) -> m [DExp] -> m DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(Name -> [VarBangType] -> [FieldExp] -> [DExp] -> m [DExp]
forall (q :: * -> *).
DsMonad q =>
Name -> [VarBangType] -> [FieldExp] -> [DExp] -> q [DExp]
reorderFields Name
con_name [VarBangType]
args [FieldExp]
field_exps ((Name -> DExp) -> [Name] -> [DExp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DExp
DVarE [Name]
field_var_names)))
con_to_dmatch :: DsMonad q => Con -> q DMatch
con_to_dmatch :: Con -> q DMatch
con_to_dmatch (RecC con_name :: Name
con_name args :: [VarBangType]
args) = Name -> [VarBangType] -> q DMatch
forall (m :: * -> *).
DsMonad m =>
Name -> [VarBangType] -> m DMatch
rec_con_to_dmatch Name
con_name [VarBangType]
args
#if __GLASGOW_HASKELL__ >= 800
con_to_dmatch (RecGadtC [con_name :: Name
con_name] args :: [VarBangType]
args _ret_ty :: Type
_ret_ty) = Name -> [VarBangType] -> q DMatch
forall (m :: * -> *).
DsMonad m =>
Name -> [VarBangType] -> m DMatch
rec_con_to_dmatch Name
con_name [VarBangType]
args
#endif
con_to_dmatch (ForallC _ _ c :: Con
c) = Con -> q DMatch
forall (q :: * -> *). DsMonad q => Con -> q DMatch
con_to_dmatch Con
c
con_to_dmatch _ = String -> q DMatch
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "Internal error within th-desugar."
error_match :: DMatch
error_match = DPat -> DExp -> DMatch
DMatch DPat
DWildP (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'error)
(Lit -> DExp
DLitE (String -> Lit
StringL "Non-exhaustive patterns in record update")))
fst_of_3 :: (a, b, c) -> a
fst_of_3 (x :: a
x, _, _) = a
x
#if __GLASGOW_HASKELL__ >= 709
dsExp (StaticE exp :: Exp
exp) = DExp -> DExp
DStaticE (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
#endif
#if __GLASGOW_HASKELL__ > 710
dsExp (UnboundVarE n :: Name
n) = DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> DExp
DVarE Name
n)
#endif
#if __GLASGOW_HASKELL__ >= 801
dsExp (AppTypeE exp :: Exp
exp ty :: Type
ty) = DExp -> DType -> DExp
DAppTypeE (DExp -> DType -> DExp) -> q DExp -> q (DType -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp q (DType -> DExp) -> q DType -> q DExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty
dsExp (UnboxedSumE exp :: Exp
exp alt :: Int
alt arity :: Int
arity) =
DExp -> DExp -> DExp
DAppE (Name -> DExp
DConE (Name -> DExp) -> Name -> DExp
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Name
unboxedSumDataName Int
alt Int
arity) (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
#endif
#if __GLASGOW_HASKELL__ >= 803
dsExp (LabelE str :: String
str) = DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DVarE 'fromLabel DExp -> DType -> DExp
`DAppTypeE` TyLit -> DType
DLitT (String -> TyLit
StrTyLit String
str)
#endif
#if __GLASGOW_HASKELL__ >= 807
dsExp (ImplicitParamVarE n :: String
n) = DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DVarE 'ip DExp -> DType -> DExp
`DAppTypeE` TyLit -> DType
DLitT (String -> TyLit
StrTyLit String
n)
dsExp (MDoE {}) = String -> q DExp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "th-desugar currently does not support RecursiveDo"
#endif
#if __GLASGOW_HASKELL__ >= 809
dsTup :: DsMonad q => (Int -> Name) -> [Maybe Exp] -> q DExp
dsTup = ds_tup
#else
dsTup :: DsMonad q => (Int -> Name) -> [Exp] -> q DExp
dsTup :: (Int -> Name) -> [Exp] -> q DExp
dsTup tuple_data_name :: Int -> Name
tuple_data_name = (Int -> Name) -> [Maybe Exp] -> q DExp
forall (q :: * -> *).
DsMonad q =>
(Int -> Name) -> [Maybe Exp] -> q DExp
ds_tup Int -> Name
tuple_data_name ([Maybe Exp] -> q DExp)
-> ([Exp] -> [Maybe Exp]) -> [Exp] -> q DExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp -> Maybe Exp) -> [Exp] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Maybe Exp
forall a. a -> Maybe a
Just
#endif
ds_tup :: forall q. DsMonad q
=> (Int -> Name)
-> [Maybe Exp]
-> q DExp
ds_tup :: (Int -> Name) -> [Maybe Exp] -> q DExp
ds_tup tuple_data_name :: Int -> Name
tuple_data_name mb_exps :: [Maybe Exp]
mb_exps = do
[Either Name DExp]
section_exps <- (Maybe Exp -> q (Either Name DExp))
-> [Maybe Exp] -> q [Either Name DExp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Maybe Exp -> q (Either Name DExp)
ds_section_exp [Maybe Exp]
mb_exps
let section_vars :: [Name]
section_vars = [Either Name DExp] -> [Name]
forall a b. [Either a b] -> [a]
lefts [Either Name DExp]
section_exps
tup_body :: DExp
tup_body = [Either Name DExp] -> DExp
mk_tup_body [Either Name DExp]
section_exps
if [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
section_vars
then DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return DExp
tup_body
else [Pat] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [Pat] -> DExp -> q DExp
dsLam ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
section_vars) DExp
tup_body
where
ds_section_exp :: Maybe Exp -> q (Either Name DExp)
ds_section_exp :: Maybe Exp -> q (Either Name DExp)
ds_section_exp = q (Either Name DExp)
-> (Exp -> q (Either Name DExp))
-> Maybe Exp
-> q (Either Name DExp)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> Either Name DExp
forall a b. a -> Either a b
Left (Name -> Either Name DExp) -> q Name -> q (Either Name DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
qNewName "ts") ((DExp -> Either Name DExp) -> q DExp -> q (Either Name DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DExp -> Either Name DExp
forall a b. b -> Either a b
Right (q DExp -> q (Either Name DExp))
-> (Exp -> q DExp) -> Exp -> q (Either Name DExp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp)
mk_tup_body :: [Either Name DExp] -> DExp
mk_tup_body :: [Either Name DExp] -> DExp
mk_tup_body section_exps :: [Either Name DExp]
section_exps =
(DExp -> Either Name DExp -> DExp)
-> DExp -> [Either Name DExp] -> DExp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DExp -> Either Name DExp -> DExp
apply_tup_body (Name -> DExp
DConE (Name -> DExp) -> Name -> DExp
forall a b. (a -> b) -> a -> b
$ Int -> Name
tuple_data_name ([Either Name DExp] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either Name DExp]
section_exps))
[Either Name DExp]
section_exps
apply_tup_body :: DExp -> Either Name DExp -> DExp
apply_tup_body :: DExp -> Either Name DExp -> DExp
apply_tup_body f :: DExp
f (Left n :: Name
n) = DExp
f DExp -> DExp -> DExp
`DAppE` Name -> DExp
DVarE Name
n
apply_tup_body f :: DExp
f (Right e :: DExp
e) = DExp
f DExp -> DExp -> DExp
`DAppE` DExp
e
dsLam :: DsMonad q => [Pat] -> DExp -> q DExp
dsLam :: [Pat] -> DExp -> q DExp
dsLam = (Pat -> Maybe Name)
-> ([Pat] -> DExp -> q ([DPat], DExp)) -> [Pat] -> DExp -> q DExp
forall (q :: * -> *) pat.
DsMonad q =>
(pat -> Maybe Name)
-> ([pat] -> DExp -> q ([DPat], DExp)) -> [pat] -> DExp -> q DExp
mkLam Pat -> Maybe Name
stripVarP_maybe [Pat] -> DExp -> q ([DPat], DExp)
forall (q :: * -> *).
DsMonad q =>
[Pat] -> DExp -> q ([DPat], DExp)
dsPatsOverExp
mkDLamEFromDPats :: DsMonad q => [DPat] -> DExp -> q DExp
mkDLamEFromDPats :: [DPat] -> DExp -> q DExp
mkDLamEFromDPats = (DPat -> Maybe Name)
-> ([DPat] -> DExp -> q ([DPat], DExp)) -> [DPat] -> DExp -> q DExp
forall (q :: * -> *) pat.
DsMonad q =>
(pat -> Maybe Name)
-> ([pat] -> DExp -> q ([DPat], DExp)) -> [pat] -> DExp -> q DExp
mkLam DPat -> Maybe Name
stripDVarP_maybe (\pats :: [DPat]
pats exp :: DExp
exp -> ([DPat], DExp) -> q ([DPat], DExp)
forall (m :: * -> *) a. Monad m => a -> m a
return ([DPat]
pats, DExp
exp))
where
stripDVarP_maybe :: DPat -> Maybe Name
stripDVarP_maybe :: DPat -> Maybe Name
stripDVarP_maybe (DVarP n :: Name
n) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
stripDVarP_maybe _ = Maybe Name
forall a. Maybe a
Nothing
mkLam :: DsMonad q
=> (pat -> Maybe Name)
-> ([pat] -> DExp -> q ([DPat], DExp))
-> [pat] -> DExp -> q DExp
mkLam :: (pat -> Maybe Name)
-> ([pat] -> DExp -> q ([DPat], DExp)) -> [pat] -> DExp -> q DExp
mkLam mb_strip_var_pat :: pat -> Maybe Name
mb_strip_var_pat process_pats_over_exp :: [pat] -> DExp -> q ([DPat], DExp)
process_pats_over_exp pats :: [pat]
pats exp :: DExp
exp
| Just names :: [Name]
names <- (pat -> Maybe Name) -> [pat] -> Maybe [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM pat -> Maybe Name
mb_strip_var_pat [pat]
pats
= DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [Name] -> DExp -> DExp
DLamE [Name]
names DExp
exp
| Bool
otherwise
= do [Name]
arg_names <- Int -> q Name -> q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([pat] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [pat]
pats) (String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName "arg")
let scrutinee :: DExp
scrutinee = [DExp] -> DExp
mkTupleDExp ((Name -> DExp) -> [Name] -> [DExp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DExp
DVarE [Name]
arg_names)
(pats' :: [DPat]
pats', exp' :: DExp
exp') <- [pat] -> DExp -> q ([DPat], DExp)
process_pats_over_exp [pat]
pats DExp
exp
let match :: DMatch
match = DPat -> DExp -> DMatch
DMatch ([DPat] -> DPat
mkTupleDPat [DPat]
pats') DExp
exp'
DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [Name] -> DExp -> DExp
DLamE [Name]
arg_names (DExp -> [DMatch] -> DExp
DCaseE DExp
scrutinee [DMatch
match])
dsMatches :: DsMonad q
=> Name
-> [Match]
-> q [DMatch]
dsMatches :: Name -> [Match] -> q [DMatch]
dsMatches scr :: Name
scr = [Match] -> q [DMatch]
forall (q :: * -> *). DsMonad q => [Match] -> q [DMatch]
go
where
go :: DsMonad q => [Match] -> q [DMatch]
go :: [Match] -> q [DMatch]
go [] = [DMatch] -> q [DMatch]
forall (m :: * -> *) a. Monad m => a -> m a
return []
go (Match pat :: Pat
pat body :: Body
body where_decs :: [Dec]
where_decs : rest :: [Match]
rest) = do
[DMatch]
rest' <- [Match] -> q [DMatch]
forall (q :: * -> *). DsMonad q => [Match] -> q [DMatch]
go [Match]
rest
let failure :: DExp
failure = DExp -> [DMatch] -> DExp
DCaseE (Name -> DExp
DVarE Name
scr) [DMatch]
rest'
DExp
exp' <- Body -> [Dec] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => Body -> [Dec] -> DExp -> q DExp
dsBody Body
body [Dec]
where_decs DExp
failure
(pat' :: DPat
pat', exp'' :: DExp
exp'') <- Pat -> DExp -> q (DPat, DExp)
forall (q :: * -> *). DsMonad q => Pat -> DExp -> q (DPat, DExp)
dsPatOverExp Pat
pat DExp
exp'
Bool
uni_pattern <- DPat -> q Bool
forall (q :: * -> *). DsMonad q => DPat -> q Bool
isUniversalPattern DPat
pat'
if Bool
uni_pattern
then [DMatch] -> q [DMatch]
forall (m :: * -> *) a. Monad m => a -> m a
return [DPat -> DExp -> DMatch
DMatch DPat
pat' DExp
exp'']
else [DMatch] -> q [DMatch]
forall (m :: * -> *) a. Monad m => a -> m a
return (DPat -> DExp -> DMatch
DMatch DPat
pat' DExp
exp'' DMatch -> [DMatch] -> [DMatch]
forall a. a -> [a] -> [a]
: [DMatch]
rest')
dsBody :: DsMonad q
=> Body
-> [Dec]
-> DExp
-> q DExp
dsBody :: Body -> [Dec] -> DExp -> q DExp
dsBody (NormalB exp :: Exp
exp) decs :: [Dec]
decs _ = do
(decs' :: [DLetDec]
decs', ip_binder :: DExp -> DExp
ip_binder) <- [Dec] -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
decs
DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
maybeDLetE [DLetDec]
decs' (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp
ip_binder DExp
exp'
dsBody (GuardedB guarded_exps :: [(Guard, Exp)]
guarded_exps) decs :: [Dec]
decs failure :: DExp
failure = do
(decs' :: [DLetDec]
decs', ip_binder :: DExp -> DExp
ip_binder) <- [Dec] -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
decs
DExp
guarded_exp' <- [(Guard, Exp)] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [(Guard, Exp)] -> DExp -> q DExp
dsGuards [(Guard, Exp)]
guarded_exps DExp
failure
DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
maybeDLetE [DLetDec]
decs' (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp
ip_binder DExp
guarded_exp'
maybeDLetE :: [DLetDec] -> DExp -> DExp
maybeDLetE :: [DLetDec] -> DExp -> DExp
maybeDLetE [] exp :: DExp
exp = DExp
exp
maybeDLetE decs :: [DLetDec]
decs exp :: DExp
exp = [DLetDec] -> DExp -> DExp
DLetE [DLetDec]
decs DExp
exp
maybeDCaseE :: String -> DExp -> [DMatch] -> DExp
maybeDCaseE :: String -> DExp -> [DMatch] -> DExp
maybeDCaseE err :: String
err _ [] = DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'error) (Lit -> DExp
DLitE (String -> Lit
StringL String
err))
maybeDCaseE _ scrut :: DExp
scrut matches :: [DMatch]
matches = DExp -> [DMatch] -> DExp
DCaseE DExp
scrut [DMatch]
matches
dsGuards :: DsMonad q
=> [(Guard, Exp)]
-> DExp
-> q DExp
dsGuards :: [(Guard, Exp)] -> DExp -> q DExp
dsGuards [] thing_inside :: DExp
thing_inside = DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return DExp
thing_inside
dsGuards ((NormalG gd :: Exp
gd, exp :: Exp
exp) : rest :: [(Guard, Exp)]
rest) thing_inside :: DExp
thing_inside =
[(Guard, Exp)] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [(Guard, Exp)] -> DExp -> q DExp
dsGuards (([Stmt] -> Guard
PatG [Exp -> Stmt
NoBindS Exp
gd], Exp
exp) (Guard, Exp) -> [(Guard, Exp)] -> [(Guard, Exp)]
forall a. a -> [a] -> [a]
: [(Guard, Exp)]
rest) DExp
thing_inside
dsGuards ((PatG stmts :: [Stmt]
stmts, exp :: Exp
exp) : rest :: [(Guard, Exp)]
rest) thing_inside :: DExp
thing_inside = do
DExp
success <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
DExp
failure <- [(Guard, Exp)] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [(Guard, Exp)] -> DExp -> q DExp
dsGuards [(Guard, Exp)]
rest DExp
thing_inside
[Stmt] -> DExp -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> DExp -> DExp -> q DExp
dsGuardStmts [Stmt]
stmts DExp
success DExp
failure
dsGuardStmts :: DsMonad q
=> [Stmt]
-> DExp
-> DExp
-> q DExp
dsGuardStmts :: [Stmt] -> DExp -> DExp -> q DExp
dsGuardStmts [] success :: DExp
success _failure :: DExp
_failure = DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return DExp
success
dsGuardStmts (BindS pat :: Pat
pat exp :: Exp
exp : rest :: [Stmt]
rest) success :: DExp
success failure :: DExp
failure = do
DExp
success' <- [Stmt] -> DExp -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> DExp -> DExp -> q DExp
dsGuardStmts [Stmt]
rest DExp
success DExp
failure
(pat' :: DPat
pat', success'' :: DExp
success'') <- Pat -> DExp -> q (DPat, DExp)
forall (q :: * -> *). DsMonad q => Pat -> DExp -> q (DPat, DExp)
dsPatOverExp Pat
pat DExp
success'
DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ DExp -> [DMatch] -> DExp
DCaseE DExp
exp' [DPat -> DExp -> DMatch
DMatch DPat
pat' DExp
success'', DPat -> DExp -> DMatch
DMatch DPat
DWildP DExp
failure]
dsGuardStmts (LetS decs :: [Dec]
decs : rest :: [Stmt]
rest) success :: DExp
success failure :: DExp
failure = do
(decs' :: [DLetDec]
decs', ip_binder :: DExp -> DExp
ip_binder) <- [Dec] -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
decs
DExp
success' <- [Stmt] -> DExp -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> DExp -> DExp -> q DExp
dsGuardStmts [Stmt]
rest DExp
success DExp
failure
DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
DLetE [DLetDec]
decs' (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp
ip_binder DExp
success'
dsGuardStmts [NoBindS exp :: Exp
exp] success :: DExp
success _failure :: DExp
_failure
| VarE name :: Name
name <- Exp
exp
, Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== 'otherwise
= DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return DExp
success
| ConE name :: Name
name <- Exp
exp
, Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== 'True
= DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return DExp
success
dsGuardStmts (NoBindS exp :: Exp
exp : rest :: [Stmt]
rest) success :: DExp
success failure :: DExp
failure = do
DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
DExp
success' <- [Stmt] -> DExp -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> DExp -> DExp -> q DExp
dsGuardStmts [Stmt]
rest DExp
success DExp
failure
DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ DExp -> [DMatch] -> DExp
DCaseE DExp
exp' [ DPat -> DExp -> DMatch
DMatch (Name -> [DPat] -> DPat
DConP 'True []) DExp
success'
, DPat -> DExp -> DMatch
DMatch (Name -> [DPat] -> DPat
DConP 'False []) DExp
failure ]
dsGuardStmts (ParS _ : _) _ _ = String -> q DExp
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "Parallel comprehension in a pattern guard."
#if __GLASGOW_HASKELL__ >= 807
dsGuardStmts (RecS {} : _) _ _ = String -> q DExp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "th-desugar currently does not support RecursiveDo"
#endif
dsDoStmts :: DsMonad q => [Stmt] -> q DExp
dsDoStmts :: [Stmt] -> q DExp
dsDoStmts [] = String -> q DExp
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "do-expression ended with something other than bare statement."
dsDoStmts [NoBindS exp :: Exp
exp] = Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
dsDoStmts (BindS pat :: Pat
pat exp :: Exp
exp : rest :: [Stmt]
rest) = do
DExp
rest' <- [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsDoStmts [Stmt]
rest
Exp -> Pat -> DExp -> String -> q DExp
forall (q :: * -> *).
DsMonad q =>
Exp -> Pat -> DExp -> String -> q DExp
dsBindS Exp
exp Pat
pat DExp
rest' "do expression"
dsDoStmts (LetS decs :: [Dec]
decs : rest :: [Stmt]
rest) = do
(decs' :: [DLetDec]
decs', ip_binder :: DExp -> DExp
ip_binder) <- [Dec] -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
decs
DExp
rest' <- [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsDoStmts [Stmt]
rest
DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
DLetE [DLetDec]
decs' (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp
ip_binder DExp
rest'
dsDoStmts (NoBindS exp :: Exp
exp : rest :: [Stmt]
rest) = do
DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
DExp
rest' <- [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsDoStmts [Stmt]
rest
DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE '(>>)) DExp
exp') DExp
rest'
dsDoStmts (ParS _ : _) = String -> q DExp
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "Parallel comprehension in a do-statement."
#if __GLASGOW_HASKELL__ >= 807
dsDoStmts (RecS {} : _) = String -> q DExp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "th-desugar currently does not support RecursiveDo"
#endif
dsComp :: DsMonad q => [Stmt] -> q DExp
dsComp :: [Stmt] -> q DExp
dsComp [] = String -> q DExp
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "List/monad comprehension ended with something other than a bare statement."
dsComp [NoBindS exp :: Exp
exp] = DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'return) (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
dsComp (BindS pat :: Pat
pat exp :: Exp
exp : rest :: [Stmt]
rest) = do
DExp
rest' <- [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp [Stmt]
rest
Exp -> Pat -> DExp -> String -> q DExp
forall (q :: * -> *).
DsMonad q =>
Exp -> Pat -> DExp -> String -> q DExp
dsBindS Exp
exp Pat
pat DExp
rest' "monad comprehension"
dsComp (LetS decs :: [Dec]
decs : rest :: [Stmt]
rest) = do
(decs' :: [DLetDec]
decs', ip_binder :: DExp -> DExp
ip_binder) <- [Dec] -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
decs
DExp
rest' <- [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp [Stmt]
rest
DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
DLetE [DLetDec]
decs' (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp
ip_binder DExp
rest'
dsComp (NoBindS exp :: Exp
exp : rest :: [Stmt]
rest) = do
DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
DExp
rest' <- [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp [Stmt]
rest
DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE '(>>)) (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'guard) DExp
exp')) DExp
rest'
dsComp (ParS stmtss :: [[Stmt]]
stmtss : rest :: [Stmt]
rest) = do
(pat :: Pat
pat, exp :: DExp
exp) <- [[Stmt]] -> q (Pat, DExp)
forall (q :: * -> *). DsMonad q => [[Stmt]] -> q (Pat, DExp)
dsParComp [[Stmt]]
stmtss
DExp
rest' <- [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp [Stmt]
rest
DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE '(>>=)) DExp
exp) (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pat] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [Pat] -> DExp -> q DExp
dsLam [Pat
pat] DExp
rest'
#if __GLASGOW_HASKELL__ >= 807
dsComp (RecS {} : _) = String -> q DExp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "th-desugar currently does not support RecursiveDo"
#endif
dsBindS :: forall q. DsMonad q => Exp -> Pat -> DExp -> String -> q DExp
dsBindS :: Exp -> Pat -> DExp -> String -> q DExp
dsBindS bind_arg_exp :: Exp
bind_arg_exp success_pat :: Pat
success_pat success_exp :: DExp
success_exp ctxt :: String
ctxt = do
DExp
bind_arg_exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
bind_arg_exp
(success_pat' :: DPat
success_pat', success_exp' :: DExp
success_exp') <- Pat -> DExp -> q (DPat, DExp)
forall (q :: * -> *). DsMonad q => Pat -> DExp -> q (DPat, DExp)
dsPatOverExp Pat
success_pat DExp
success_exp
Bool
is_univ_pat <- DPat -> q Bool
forall (q :: * -> *). DsMonad q => DPat -> q Bool
isUniversalPattern DPat
success_pat'
let bind_into :: DExp -> DExp
bind_into = DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE '(>>=)) DExp
bind_arg_exp')
if Bool
is_univ_pat
then DExp -> DExp
bind_into (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DPat] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [DPat] -> DExp -> q DExp
mkDLamEFromDPats [DPat
success_pat'] DExp
success_exp'
else do Name
arg_name <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName "arg"
Name
fail_name <- q Name
mk_fail_name
DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp
bind_into (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$ [Name] -> DExp -> DExp
DLamE [Name
arg_name] (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$ DExp -> [DMatch] -> DExp
DCaseE (Name -> DExp
DVarE Name
arg_name)
[ DPat -> DExp -> DMatch
DMatch DPat
success_pat' DExp
success_exp'
, DPat -> DExp -> DMatch
DMatch DPat
DWildP (DExp -> DMatch) -> DExp -> DMatch
forall a b. (a -> b) -> a -> b
$
Name -> DExp
DVarE Name
fail_name DExp -> DExp -> DExp
`DAppE`
Lit -> DExp
DLitE (String -> Lit
StringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ "Pattern match failure in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ctxt)
]
where
mk_fail_name :: q Name
#if __GLASGOW_HASKELL__ >= 807
mk_fail_name :: q Name
mk_fail_name = Name -> q Name
forall (m :: * -> *) a. Monad m => a -> m a
return 'MonadFail.fail
#elif __GLASGOW_HASKELL__ >= 800
mk_fail_name = do
mfd <- qIsExtEnabled MonadFailDesugaring
return $ if mfd then 'MonadFail.fail else 'Prelude.fail
#else
mk_fail_name = return 'Prelude.fail
#endif
dsParComp :: DsMonad q => [[Stmt]] -> q (Pat, DExp)
dsParComp :: [[Stmt]] -> q (Pat, DExp)
dsParComp [] = String -> q (Pat, DExp)
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "Empty list of parallel comprehension statements."
dsParComp [r :: [Stmt]
r] = do
let rv :: OSet Name
rv = (Stmt -> OSet Name) -> [Stmt] -> OSet Name
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Stmt -> OSet Name
extractBoundNamesStmt [Stmt]
r
DExp
dsR <- [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp ([Stmt]
r [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [OSet Name -> Stmt
mk_tuple_stmt OSet Name
rv])
(Pat, DExp) -> q (Pat, DExp)
forall (m :: * -> *) a. Monad m => a -> m a
return (OSet Name -> Pat
mk_tuple_pat OSet Name
rv, DExp
dsR)
dsParComp (q :: [Stmt]
q : rest :: [[Stmt]]
rest) = do
let qv :: OSet Name
qv = (Stmt -> OSet Name) -> [Stmt] -> OSet Name
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Stmt -> OSet Name
extractBoundNamesStmt [Stmt]
q
(rest_pat :: Pat
rest_pat, rest_exp :: DExp
rest_exp) <- [[Stmt]] -> q (Pat, DExp)
forall (q :: * -> *). DsMonad q => [[Stmt]] -> q (Pat, DExp)
dsParComp [[Stmt]]
rest
DExp
dsQ <- [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp ([Stmt]
q [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [OSet Name -> Stmt
mk_tuple_stmt OSet Name
qv])
let zipped :: DExp
zipped = DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'mzip) DExp
dsQ) DExp
rest_exp
(Pat, DExp) -> q (Pat, DExp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [Pat] -> Pat
ConP (Int -> Name
tupleDataName 2) [OSet Name -> Pat
mk_tuple_pat OSet Name
qv, Pat
rest_pat], DExp
zipped)
mk_tuple_stmt :: OSet Name -> Stmt
mk_tuple_stmt :: OSet Name -> Stmt
mk_tuple_stmt name_set :: OSet Name
name_set =
Exp -> Stmt
NoBindS ([Exp] -> Exp
mkTupleExp ((Name -> [Exp] -> [Exp]) -> [Exp] -> OSet Name -> [Exp]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr ((:) (Exp -> [Exp] -> [Exp]) -> (Name -> Exp) -> Name -> [Exp] -> [Exp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE) [] OSet Name
name_set))
mk_tuple_pat :: OSet Name -> Pat
mk_tuple_pat :: OSet Name -> Pat
mk_tuple_pat name_set :: OSet Name
name_set =
[Pat] -> Pat
mkTuplePat ((Name -> [Pat] -> [Pat]) -> [Pat] -> OSet Name -> [Pat]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr ((:) (Pat -> [Pat] -> [Pat]) -> (Name -> Pat) -> Name -> [Pat] -> [Pat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Pat
VarP) [] OSet Name
name_set)
dsPatOverExp :: DsMonad q => Pat -> DExp -> q (DPat, DExp)
dsPatOverExp :: Pat -> DExp -> q (DPat, DExp)
dsPatOverExp pat :: Pat
pat exp :: DExp
exp = do
(pat' :: DPat
pat', vars :: [(Name, DExp)]
vars) <- WriterT [(Name, DExp)] q DPat -> q (DPat, [(Name, DExp)])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT [(Name, DExp)] q DPat -> q (DPat, [(Name, DExp)]))
-> WriterT [(Name, DExp)] q DPat -> q (DPat, [(Name, DExp)])
forall a b. (a -> b) -> a -> b
$ Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat
let name_decs :: [DLetDec]
name_decs = ([Name] -> [DExp] -> [DLetDec]) -> ([Name], [DExp]) -> [DLetDec]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Name -> DExp -> DLetDec) -> [Name] -> [DExp] -> [DLetDec]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (DPat -> DExp -> DLetDec
DValD (DPat -> DExp -> DLetDec)
-> (Name -> DPat) -> Name -> DExp -> DLetDec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> DPat
DVarP)) (([Name], [DExp]) -> [DLetDec]) -> ([Name], [DExp]) -> [DLetDec]
forall a b. (a -> b) -> a -> b
$ [(Name, DExp)] -> ([Name], [DExp])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Name, DExp)]
vars
(DPat, DExp) -> q (DPat, DExp)
forall (m :: * -> *) a. Monad m => a -> m a
return (DPat
pat', [DLetDec] -> DExp -> DExp
maybeDLetE [DLetDec]
name_decs DExp
exp)
dsPatsOverExp :: DsMonad q => [Pat] -> DExp -> q ([DPat], DExp)
dsPatsOverExp :: [Pat] -> DExp -> q ([DPat], DExp)
dsPatsOverExp pats :: [Pat]
pats exp :: DExp
exp = do
(pats' :: [DPat]
pats', vars :: [(Name, DExp)]
vars) <- WriterT [(Name, DExp)] q [DPat] -> q ([DPat], [(Name, DExp)])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT [(Name, DExp)] q [DPat] -> q ([DPat], [(Name, DExp)]))
-> WriterT [(Name, DExp)] q [DPat] -> q ([DPat], [(Name, DExp)])
forall a b. (a -> b) -> a -> b
$ (Pat -> WriterT [(Name, DExp)] q DPat)
-> [Pat] -> WriterT [(Name, DExp)] q [DPat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat [Pat]
pats
let name_decs :: [DLetDec]
name_decs = ([Name] -> [DExp] -> [DLetDec]) -> ([Name], [DExp]) -> [DLetDec]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Name -> DExp -> DLetDec) -> [Name] -> [DExp] -> [DLetDec]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (DPat -> DExp -> DLetDec
DValD (DPat -> DExp -> DLetDec)
-> (Name -> DPat) -> Name -> DExp -> DLetDec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> DPat
DVarP)) (([Name], [DExp]) -> [DLetDec]) -> ([Name], [DExp]) -> [DLetDec]
forall a b. (a -> b) -> a -> b
$ [(Name, DExp)] -> ([Name], [DExp])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Name, DExp)]
vars
([DPat], DExp) -> q ([DPat], DExp)
forall (m :: * -> *) a. Monad m => a -> m a
return ([DPat]
pats', [DLetDec] -> DExp -> DExp
maybeDLetE [DLetDec]
name_decs DExp
exp)
dsPatX :: DsMonad q => Pat -> q (DPat, [(Name, DExp)])
dsPatX :: Pat -> q (DPat, [(Name, DExp)])
dsPatX = WriterT [(Name, DExp)] q DPat -> q (DPat, [(Name, DExp)])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT [(Name, DExp)] q DPat -> q (DPat, [(Name, DExp)]))
-> (Pat -> WriterT [(Name, DExp)] q DPat)
-> Pat
-> q (DPat, [(Name, DExp)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat
type PatM q = WriterT [(Name, DExp)] q
dsPat :: DsMonad q => Pat -> PatM q DPat
dsPat :: Pat -> PatM q DPat
dsPat (LitP lit :: Lit
lit) = DPat -> PatM q DPat
forall (m :: * -> *) a. Monad m => a -> m a
return (DPat -> PatM q DPat) -> DPat -> PatM q DPat
forall a b. (a -> b) -> a -> b
$ Lit -> DPat
DLitP Lit
lit
dsPat (VarP n :: Name
n) = DPat -> PatM q DPat
forall (m :: * -> *) a. Monad m => a -> m a
return (DPat -> PatM q DPat) -> DPat -> PatM q DPat
forall a b. (a -> b) -> a -> b
$ Name -> DPat
DVarP Name
n
dsPat (TupP pats :: [Pat]
pats) = Name -> [DPat] -> DPat
DConP (Int -> Name
tupleDataName ([Pat] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat]
pats)) ([DPat] -> DPat) -> WriterT [(Name, DExp)] q [DPat] -> PatM q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pat -> PatM q DPat) -> [Pat] -> WriterT [(Name, DExp)] q [DPat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pat -> PatM q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat [Pat]
pats
dsPat (UnboxedTupP pats :: [Pat]
pats) = Name -> [DPat] -> DPat
DConP (Int -> Name
unboxedTupleDataName ([Pat] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat]
pats)) ([DPat] -> DPat) -> WriterT [(Name, DExp)] q [DPat] -> PatM q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(Pat -> PatM q DPat) -> [Pat] -> WriterT [(Name, DExp)] q [DPat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pat -> PatM q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat [Pat]
pats
dsPat (ConP name :: Name
name pats :: [Pat]
pats) = Name -> [DPat] -> DPat
DConP Name
name ([DPat] -> DPat) -> WriterT [(Name, DExp)] q [DPat] -> PatM q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pat -> PatM q DPat) -> [Pat] -> WriterT [(Name, DExp)] q [DPat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pat -> PatM q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat [Pat]
pats
dsPat (InfixP p1 :: Pat
p1 name :: Name
name p2 :: Pat
p2) = Name -> [DPat] -> DPat
DConP Name
name ([DPat] -> DPat) -> WriterT [(Name, DExp)] q [DPat] -> PatM q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pat -> PatM q DPat) -> [Pat] -> WriterT [(Name, DExp)] q [DPat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pat -> PatM q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat [Pat
p1, Pat
p2]
dsPat (UInfixP _ _ _) =
String -> PatM q DPat
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Cannot desugar unresolved infix operators."
dsPat (ParensP pat :: Pat
pat) = Pat -> PatM q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat
dsPat (TildeP pat :: Pat
pat) = DPat -> DPat
DTildeP (DPat -> DPat) -> PatM q DPat -> PatM q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pat -> PatM q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat
dsPat (BangP pat :: Pat
pat) = DPat -> DPat
DBangP (DPat -> DPat) -> PatM q DPat -> PatM q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pat -> PatM q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat
dsPat (AsP name :: Name
name pat :: Pat
pat) = do
DPat
pat' <- Pat -> PatM q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat
DPat
pat'' <- q DPat -> PatM q DPat
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (q DPat -> PatM q DPat) -> q DPat -> PatM q DPat
forall a b. (a -> b) -> a -> b
$ DPat -> q DPat
forall (q :: * -> *). DsMonad q => DPat -> q DPat
removeWilds DPat
pat'
[(Name, DExp)] -> WriterT [(Name, DExp)] q ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(Name
name, DPat -> DExp
dPatToDExp DPat
pat'')]
DPat -> PatM q DPat
forall (m :: * -> *) a. Monad m => a -> m a
return DPat
pat''
dsPat WildP = DPat -> PatM q DPat
forall (m :: * -> *) a. Monad m => a -> m a
return DPat
DWildP
dsPat (RecP con_name :: Name
con_name field_pats :: [FieldPat]
field_pats) = do
Con
con <- q Con -> WriterT [(Name, DExp)] q Con
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (q Con -> WriterT [(Name, DExp)] q Con)
-> q Con -> WriterT [(Name, DExp)] q Con
forall a b. (a -> b) -> a -> b
$ Name -> q Con
forall (q :: * -> *). DsMonad q => Name -> q Con
dataConNameToCon Name
con_name
[DPat]
reordered <- Con -> WriterT [(Name, DExp)] q [DPat]
forall (m :: * -> *).
DsMonad m =>
Con -> WriterT [(Name, DExp)] m [DPat]
reorder Con
con
DPat -> PatM q DPat
forall (m :: * -> *) a. Monad m => a -> m a
return (DPat -> PatM q DPat) -> DPat -> PatM q DPat
forall a b. (a -> b) -> a -> b
$ Name -> [DPat] -> DPat
DConP Name
con_name [DPat]
reordered
where
reorder :: Con -> WriterT [(Name, DExp)] m [DPat]
reorder con :: Con
con = case Con
con of
NormalC _name :: Name
_name fields :: [BangType]
fields -> [BangType] -> WriterT [(Name, DExp)] m [DPat]
forall (t :: * -> *) (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(Foldable t, MonadTrans t, Monad (t m), MonadFail m) =>
t a -> t m [DPat]
non_record [BangType]
fields
InfixC field1 :: BangType
field1 _name :: Name
_name field2 :: BangType
field2 -> [BangType] -> WriterT [(Name, DExp)] m [DPat]
forall (t :: * -> *) (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(Foldable t, MonadTrans t, Monad (t m), MonadFail m) =>
t a -> t m [DPat]
non_record [BangType
field1, BangType
field2]
RecC _name :: Name
_name fields :: [VarBangType]
fields -> [VarBangType] -> WriterT [(Name, DExp)] m [DPat]
forall (q :: * -> *). DsMonad q => [VarBangType] -> PatM q [DPat]
reorder_fields_pat [VarBangType]
fields
ForallC _ _ c :: Con
c -> Con -> WriterT [(Name, DExp)] m [DPat]
reorder Con
c
#if __GLASGOW_HASKELL__ >= 800
GadtC _names :: [Name]
_names fields :: [BangType]
fields _ret_ty :: Type
_ret_ty -> [BangType] -> WriterT [(Name, DExp)] m [DPat]
forall (t :: * -> *) (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(Foldable t, MonadTrans t, Monad (t m), MonadFail m) =>
t a -> t m [DPat]
non_record [BangType]
fields
RecGadtC _names :: [Name]
_names fields :: [VarBangType]
fields _ret_ty :: Type
_ret_ty -> [VarBangType] -> WriterT [(Name, DExp)] m [DPat]
forall (q :: * -> *). DsMonad q => [VarBangType] -> PatM q [DPat]
reorder_fields_pat [VarBangType]
fields
#endif
reorder_fields_pat :: [VarBangType] -> PatM q [DPat]
reorder_fields_pat fields :: [VarBangType]
fields = Name -> [VarBangType] -> [FieldPat] -> PatM q [DPat]
forall (q :: * -> *).
DsMonad q =>
Name -> [VarBangType] -> [FieldPat] -> PatM q [DPat]
reorderFieldsPat Name
con_name [VarBangType]
fields [FieldPat]
field_pats
non_record :: t a -> t m [DPat]
non_record fields :: t a
fields | [FieldPat] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldPat]
field_pats
= [DPat] -> t m [DPat]
forall (m :: * -> *) a. Monad m => a -> m a
return ([DPat] -> t m [DPat]) -> [DPat] -> t m [DPat]
forall a b. (a -> b) -> a -> b
$ Int -> DPat -> [DPat]
forall a. Int -> a -> [a]
replicate (t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
fields) DPat
DWildP
| Bool
otherwise = m [DPat] -> t m [DPat]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [DPat] -> t m [DPat]) -> m [DPat] -> t m [DPat]
forall a b. (a -> b) -> a -> b
$ String -> m [DPat]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible
(String -> m [DPat]) -> String -> m [DPat]
forall a b. (a -> b) -> a -> b
$ "Record syntax used with non-record constructor "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Name -> String
forall a. Show a => a -> String
show Name
con_name) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "."
dsPat (ListP pats :: [Pat]
pats) = [Pat] -> PatM q DPat
forall (q :: * -> *).
DsMonad q =>
[Pat] -> WriterT [(Name, DExp)] q DPat
go [Pat]
pats
where go :: [Pat] -> WriterT [(Name, DExp)] q DPat
go [] = DPat -> WriterT [(Name, DExp)] q DPat
forall (m :: * -> *) a. Monad m => a -> m a
return (DPat -> WriterT [(Name, DExp)] q DPat)
-> DPat -> WriterT [(Name, DExp)] q DPat
forall a b. (a -> b) -> a -> b
$ Name -> [DPat] -> DPat
DConP '[] []
go (h :: Pat
h : t :: [Pat]
t) = do
DPat
h' <- Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
h
DPat
t' <- [Pat] -> WriterT [(Name, DExp)] q DPat
go [Pat]
t
DPat -> WriterT [(Name, DExp)] q DPat
forall (m :: * -> *) a. Monad m => a -> m a
return (DPat -> WriterT [(Name, DExp)] q DPat)
-> DPat -> WriterT [(Name, DExp)] q DPat
forall a b. (a -> b) -> a -> b
$ Name -> [DPat] -> DPat
DConP '(:) [DPat
h', DPat
t']
dsPat (SigP pat :: Pat
pat ty :: Type
ty) = DPat -> DType -> DPat
DSigP (DPat -> DType -> DPat)
-> PatM q DPat -> WriterT [(Name, DExp)] q (DType -> DPat)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pat -> PatM q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat WriterT [(Name, DExp)] q (DType -> DPat)
-> WriterT [(Name, DExp)] q DType -> PatM q DPat
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> WriterT [(Name, DExp)] q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty
#if __GLASGOW_HASKELL__ >= 801
dsPat (UnboxedSumP pat :: Pat
pat alt :: Int
alt arity :: Int
arity) =
Name -> [DPat] -> DPat
DConP (Int -> Int -> Name
unboxedSumDataName Int
alt Int
arity) ([DPat] -> DPat) -> WriterT [(Name, DExp)] q [DPat] -> PatM q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((DPat -> [DPat] -> [DPat]
forall a. a -> [a] -> [a]
:[]) (DPat -> [DPat]) -> PatM q DPat -> WriterT [(Name, DExp)] q [DPat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pat -> PatM q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat)
#endif
dsPat (ViewP _ _) =
String -> PatM q DPat
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "View patterns are not supported in th-desugar. Use pattern guards instead."
dPatToDExp :: DPat -> DExp
dPatToDExp :: DPat -> DExp
dPatToDExp (DLitP lit :: Lit
lit) = Lit -> DExp
DLitE Lit
lit
dPatToDExp (DVarP name :: Name
name) = Name -> DExp
DVarE Name
name
dPatToDExp (DConP name :: Name
name pats :: [DPat]
pats) = (DExp -> DExp -> DExp) -> DExp -> [DExp] -> DExp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DExp -> DExp -> DExp
DAppE (Name -> DExp
DConE Name
name) ((DPat -> DExp) -> [DPat] -> [DExp]
forall a b. (a -> b) -> [a] -> [b]
map DPat -> DExp
dPatToDExp [DPat]
pats)
dPatToDExp (DTildeP pat :: DPat
pat) = DPat -> DExp
dPatToDExp DPat
pat
dPatToDExp (DBangP pat :: DPat
pat) = DPat -> DExp
dPatToDExp DPat
pat
dPatToDExp (DSigP pat :: DPat
pat ty :: DType
ty) = DExp -> DType -> DExp
DSigE (DPat -> DExp
dPatToDExp DPat
pat) DType
ty
dPatToDExp DWildP = String -> DExp
forall a. HasCallStack => String -> a
error "Internal error in th-desugar: wildcard in rhs of as-pattern"
removeWilds :: DsMonad q => DPat -> q DPat
removeWilds :: DPat -> q DPat
removeWilds p :: DPat
p@(DLitP _) = DPat -> q DPat
forall (m :: * -> *) a. Monad m => a -> m a
return DPat
p
removeWilds p :: DPat
p@(DVarP _) = DPat -> q DPat
forall (m :: * -> *) a. Monad m => a -> m a
return DPat
p
removeWilds (DConP con_name :: Name
con_name pats :: [DPat]
pats) = Name -> [DPat] -> DPat
DConP Name
con_name ([DPat] -> DPat) -> q [DPat] -> q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DPat -> q DPat) -> [DPat] -> q [DPat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DPat -> q DPat
forall (q :: * -> *). DsMonad q => DPat -> q DPat
removeWilds [DPat]
pats
removeWilds (DTildeP pat :: DPat
pat) = DPat -> DPat
DTildeP (DPat -> DPat) -> q DPat -> q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DPat -> q DPat
forall (q :: * -> *). DsMonad q => DPat -> q DPat
removeWilds DPat
pat
removeWilds (DBangP pat :: DPat
pat) = DPat -> DPat
DBangP (DPat -> DPat) -> q DPat -> q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DPat -> q DPat
forall (q :: * -> *). DsMonad q => DPat -> q DPat
removeWilds DPat
pat
removeWilds (DSigP pat :: DPat
pat ty :: DType
ty) = DPat -> DType -> DPat
DSigP (DPat -> DType -> DPat) -> q DPat -> q (DType -> DPat)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DPat -> q DPat
forall (q :: * -> *). DsMonad q => DPat -> q DPat
removeWilds DPat
pat q (DType -> DPat) -> q DType -> q DPat
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DType -> q DType
forall (f :: * -> *) a. Applicative f => a -> f a
pure DType
ty
removeWilds DWildP = Name -> DPat
DVarP (Name -> DPat) -> q Name -> q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName "wild"
dsInfo :: DsMonad q => Info -> q DInfo
dsInfo :: Info -> q DInfo
dsInfo (ClassI dec :: Dec
dec instances :: [Dec]
instances) = do
[ddec :: DDec
ddec] <- Dec -> q [DDec]
forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsDec Dec
dec
[DDec]
dinstances <- [Dec] -> q [DDec]
forall (q :: * -> *). DsMonad q => [Dec] -> q [DDec]
dsDecs [Dec]
instances
DInfo -> q DInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (DInfo -> q DInfo) -> DInfo -> q DInfo
forall a b. (a -> b) -> a -> b
$ DDec -> Maybe [DDec] -> DInfo
DTyConI DDec
ddec ([DDec] -> Maybe [DDec]
forall a. a -> Maybe a
Just [DDec]
dinstances)
#if __GLASGOW_HASKELL__ > 710
dsInfo (ClassOpI name :: Name
name ty :: Type
ty parent :: Name
parent) =
#else
dsInfo (ClassOpI name ty parent _fixity) =
#endif
Name -> DType -> Maybe Name -> DInfo
DVarI Name
name (DType -> Maybe Name -> DInfo)
-> q DType -> q (Maybe Name -> DInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty q (Maybe Name -> DInfo) -> q (Maybe Name) -> q DInfo
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Name -> q (Maybe Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
parent)
dsInfo (TyConI dec :: Dec
dec) = do
[ddec :: DDec
ddec] <- Dec -> q [DDec]
forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsDec Dec
dec
DInfo -> q DInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (DInfo -> q DInfo) -> DInfo -> q DInfo
forall a b. (a -> b) -> a -> b
$ DDec -> Maybe [DDec] -> DInfo
DTyConI DDec
ddec Maybe [DDec]
forall a. Maybe a
Nothing
dsInfo (FamilyI dec :: Dec
dec instances :: [Dec]
instances) = do
[ddec :: DDec
ddec] <- Dec -> q [DDec]
forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsDec Dec
dec
[DDec]
dinstances <- [Dec] -> q [DDec]
forall (q :: * -> *). DsMonad q => [Dec] -> q [DDec]
dsDecs [Dec]
instances
DInfo -> q DInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (DInfo -> q DInfo) -> DInfo -> q DInfo
forall a b. (a -> b) -> a -> b
$ DDec -> Maybe [DDec] -> DInfo
DTyConI DDec
ddec ([DDec] -> Maybe [DDec]
forall a. a -> Maybe a
Just [DDec]
dinstances)
dsInfo (PrimTyConI name :: Name
name arity :: Int
arity unlifted :: Bool
unlifted) =
DInfo -> q DInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (DInfo -> q DInfo) -> DInfo -> q DInfo
forall a b. (a -> b) -> a -> b
$ Name -> Int -> Bool -> DInfo
DPrimTyConI Name
name Int
arity Bool
unlifted
#if __GLASGOW_HASKELL__ > 710
dsInfo (DataConI name :: Name
name ty :: Type
ty parent :: Name
parent) =
Name -> DType -> Maybe Name -> DInfo
DVarI Name
name (DType -> Maybe Name -> DInfo)
-> q DType -> q (Maybe Name -> DInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty q (Maybe Name -> DInfo) -> q (Maybe Name) -> q DInfo
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Name -> q (Maybe Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
parent)
dsInfo (VarI name :: Name
name ty :: Type
ty Nothing) =
Name -> DType -> Maybe Name -> DInfo
DVarI Name
name (DType -> Maybe Name -> DInfo)
-> q DType -> q (Maybe Name -> DInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty q (Maybe Name -> DInfo) -> q (Maybe Name) -> q DInfo
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Name -> q (Maybe Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Name
forall a. Maybe a
Nothing
dsInfo (VarI name :: Name
name _ (Just _)) =
String -> q DInfo
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible (String -> q DInfo) -> String -> q DInfo
forall a b. (a -> b) -> a -> b
$ "Declaration supplied with variable: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
name
#else
dsInfo (DataConI name ty parent _fixity) =
DVarI name <$> dsType ty <*> pure (Just parent)
dsInfo (VarI name ty Nothing _fixity) =
DVarI name <$> dsType ty <*> pure Nothing
dsInfo (VarI name _ (Just _) _) =
impossible $ "Declaration supplied with variable: " ++ show name
#endif
dsInfo (TyVarI name :: Name
name ty :: Type
ty) = Name -> DType -> DInfo
DTyVarI Name
name (DType -> DInfo) -> q DType -> q DInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty
#if __GLASGOW_HASKELL__ >= 801
dsInfo (PatSynI name :: Name
name ty :: Type
ty) = Name -> DType -> DInfo
DPatSynI Name
name (DType -> DInfo) -> q DType -> q DInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty
#endif
dsDecs :: DsMonad q => [Dec] -> q [DDec]
dsDecs :: [Dec] -> q [DDec]
dsDecs = (Dec -> q [DDec]) -> [Dec] -> q [DDec]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM Dec -> q [DDec]
forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsDec
dsDec :: DsMonad q => Dec -> q [DDec]
dsDec :: Dec -> q [DDec]
dsDec d :: Dec
d@(FunD {}) = Dec -> q [DDec]
forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsTopLevelLetDec Dec
d
dsDec d :: Dec
d@(ValD {}) = Dec -> q [DDec]
forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsTopLevelLetDec Dec
d
#if __GLASGOW_HASKELL__ > 710
dsDec (DataD cxt :: Cxt
cxt n :: Name
n tvbs :: [TyVarBndr]
tvbs mk :: Maybe Type
mk cons :: [Con]
cons derivings :: [DerivClause]
derivings) =
NewOrData
-> Cxt
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
forall (q :: * -> *).
DsMonad q =>
NewOrData
-> Cxt
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
dsDataDec NewOrData
Data Cxt
cxt Name
n [TyVarBndr]
tvbs Maybe Type
mk [Con]
cons [DerivClause]
derivings
dsDec (NewtypeD cxt :: Cxt
cxt n :: Name
n tvbs :: [TyVarBndr]
tvbs mk :: Maybe Type
mk con :: Con
con derivings :: [DerivClause]
derivings) =
NewOrData
-> Cxt
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
forall (q :: * -> *).
DsMonad q =>
NewOrData
-> Cxt
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
dsDataDec NewOrData
Newtype Cxt
cxt Name
n [TyVarBndr]
tvbs Maybe Type
mk [Con
con] [DerivClause]
derivings
#else
dsDec (DataD cxt n tvbs cons derivings) =
dsDataDec Data cxt n tvbs Nothing cons derivings
dsDec (NewtypeD cxt n tvbs con derivings) =
dsDataDec Newtype cxt n tvbs Nothing [con] derivings
#endif
dsDec (TySynD n :: Name
n tvbs :: [TyVarBndr]
tvbs ty :: Type
ty) =
(DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> [DTyVarBndr] -> DType -> DDec
DTySynD Name
n ([DTyVarBndr] -> DType -> DDec)
-> q [DTyVarBndr] -> q (DType -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVarBndr -> q DTyVarBndr) -> [TyVarBndr] -> q [DTyVarBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> q DTyVarBndr
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndr
dsTvb [TyVarBndr]
tvbs q (DType -> DDec) -> q DType -> q DDec
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty)
dsDec (ClassD cxt :: Cxt
cxt n :: Name
n tvbs :: [TyVarBndr]
tvbs fds :: [FunDep]
fds decs :: [Dec]
decs) =
(DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DCxt -> Name -> [DTyVarBndr] -> [FunDep] -> [DDec] -> DDec
DClassD (DCxt -> Name -> [DTyVarBndr] -> [FunDep] -> [DDec] -> DDec)
-> q DCxt -> q (Name -> [DTyVarBndr] -> [FunDep] -> [DDec] -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt -> q DCxt
forall (q :: * -> *). DsMonad q => Cxt -> q DCxt
dsCxt Cxt
cxt q (Name -> [DTyVarBndr] -> [FunDep] -> [DDec] -> DDec)
-> q Name -> q ([DTyVarBndr] -> [FunDep] -> [DDec] -> DDec)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> q Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n q ([DTyVarBndr] -> [FunDep] -> [DDec] -> DDec)
-> q [DTyVarBndr] -> q ([FunDep] -> [DDec] -> DDec)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TyVarBndr -> q DTyVarBndr) -> [TyVarBndr] -> q [DTyVarBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> q DTyVarBndr
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndr
dsTvb [TyVarBndr]
tvbs
q ([FunDep] -> [DDec] -> DDec) -> q [FunDep] -> q ([DDec] -> DDec)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [FunDep] -> q [FunDep]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FunDep]
fds q ([DDec] -> DDec) -> q [DDec] -> q DDec
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Dec] -> q [DDec]
forall (q :: * -> *). DsMonad q => [Dec] -> q [DDec]
dsDecs [Dec]
decs)
#if __GLASGOW_HASKELL__ >= 711
dsDec (InstanceD over :: Maybe Overlap
over cxt :: Cxt
cxt ty :: Type
ty decs :: [Dec]
decs) =
(DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe Overlap
-> Maybe [DTyVarBndr] -> DCxt -> DType -> [DDec] -> DDec
DInstanceD Maybe Overlap
over Maybe [DTyVarBndr]
forall a. Maybe a
Nothing (DCxt -> DType -> [DDec] -> DDec)
-> q DCxt -> q (DType -> [DDec] -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt -> q DCxt
forall (q :: * -> *). DsMonad q => Cxt -> q DCxt
dsCxt Cxt
cxt q (DType -> [DDec] -> DDec) -> q DType -> q ([DDec] -> DDec)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty q ([DDec] -> DDec) -> q [DDec] -> q DDec
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Dec] -> q [DDec]
forall (q :: * -> *). DsMonad q => [Dec] -> q [DDec]
dsDecs [Dec]
decs)
#else
dsDec (InstanceD cxt ty decs) =
(:[]) <$> (DInstanceD Nothing Nothing <$> dsCxt cxt <*> dsType ty <*> dsDecs decs)
#endif
dsDec d :: Dec
d@(SigD {}) = Dec -> q [DDec]
forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsTopLevelLetDec Dec
d
dsDec (ForeignD f :: Foreign
f) = (DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DForeign -> DDec
DForeignD (DForeign -> DDec) -> q DForeign -> q DDec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Foreign -> q DForeign
forall (q :: * -> *). DsMonad q => Foreign -> q DForeign
dsForeign Foreign
f)
dsDec d :: Dec
d@(InfixD {}) = Dec -> q [DDec]
forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsTopLevelLetDec Dec
d
dsDec d :: Dec
d@(PragmaD {}) = Dec -> q [DDec]
forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsTopLevelLetDec Dec
d
#if __GLASGOW_HASKELL__ > 710
dsDec (OpenTypeFamilyD tfHead :: TypeFamilyHead
tfHead) =
(DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DTypeFamilyHead -> DDec
DOpenTypeFamilyD (DTypeFamilyHead -> DDec) -> q DTypeFamilyHead -> q DDec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeFamilyHead -> q DTypeFamilyHead
forall (q :: * -> *).
DsMonad q =>
TypeFamilyHead -> q DTypeFamilyHead
dsTypeFamilyHead TypeFamilyHead
tfHead)
dsDec (DataFamilyD n :: Name
n tvbs :: [TyVarBndr]
tvbs m_k :: Maybe Type
m_k) =
(DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> [DTyVarBndr] -> Maybe DType -> DDec
DDataFamilyD Name
n ([DTyVarBndr] -> Maybe DType -> DDec)
-> q [DTyVarBndr] -> q (Maybe DType -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVarBndr -> q DTyVarBndr) -> [TyVarBndr] -> q [DTyVarBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> q DTyVarBndr
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndr
dsTvb [TyVarBndr]
tvbs q (Maybe DType -> DDec) -> q (Maybe DType) -> q DDec
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Type -> q DType) -> Maybe Type -> q (Maybe DType)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Maybe Type
m_k)
#else
dsDec (FamilyD TypeFam n tvbs m_k) = do
(:[]) <$> (DOpenTypeFamilyD <$> dsTypeFamilyHead n tvbs m_k)
dsDec (FamilyD DataFam n tvbs m_k) =
(:[]) <$> (DDataFamilyD n <$> mapM dsTvb tvbs <*> mapM dsType m_k)
#endif
#if __GLASGOW_HASKELL__ >= 807
dsDec (DataInstD cxt :: Cxt
cxt mtvbs :: Maybe [TyVarBndr]
mtvbs lhs :: Type
lhs mk :: Maybe Type
mk cons :: [Con]
cons derivings :: [DerivClause]
derivings) =
case Type -> (Type, [TypeArg])
unfoldType Type
lhs of
(ConT n :: Name
n, tys :: [TypeArg]
tys) -> NewOrData
-> Cxt
-> Name
-> Maybe [TyVarBndr]
-> [TypeArg]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
forall (q :: * -> *).
DsMonad q =>
NewOrData
-> Cxt
-> Name
-> Maybe [TyVarBndr]
-> [TypeArg]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
dsDataInstDec NewOrData
Data Cxt
cxt Name
n Maybe [TyVarBndr]
mtvbs [TypeArg]
tys Maybe Type
mk [Con]
cons [DerivClause]
derivings
(_, _) -> String -> q [DDec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q [DDec]) -> String -> q [DDec]
forall a b. (a -> b) -> a -> b
$ "Unexpected data instance LHS: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
lhs
dsDec (NewtypeInstD cxt :: Cxt
cxt mtvbs :: Maybe [TyVarBndr]
mtvbs lhs :: Type
lhs mk :: Maybe Type
mk con :: Con
con derivings :: [DerivClause]
derivings) =
case Type -> (Type, [TypeArg])
unfoldType Type
lhs of
(ConT n :: Name
n, tys :: [TypeArg]
tys) -> NewOrData
-> Cxt
-> Name
-> Maybe [TyVarBndr]
-> [TypeArg]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
forall (q :: * -> *).
DsMonad q =>
NewOrData
-> Cxt
-> Name
-> Maybe [TyVarBndr]
-> [TypeArg]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
dsDataInstDec NewOrData
Newtype Cxt
cxt Name
n Maybe [TyVarBndr]
mtvbs [TypeArg]
tys Maybe Type
mk [Con
con] [DerivClause]
derivings
(_, _) -> String -> q [DDec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q [DDec]) -> String -> q [DDec]
forall a b. (a -> b) -> a -> b
$ "Unexpected newtype instance LHS: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
lhs
#elif __GLASGOW_HASKELL__ > 710
dsDec (DataInstD cxt n tys mk cons derivings) =
dsDataInstDec Data cxt n Nothing (map TANormal tys) mk cons derivings
dsDec (NewtypeInstD cxt n tys mk con derivings) =
dsDataInstDec Newtype cxt n Nothing (map TANormal tys) mk [con] derivings
#else
dsDec (DataInstD cxt n tys cons derivings) =
dsDataInstDec Data cxt n Nothing (map TANormal tys) Nothing cons derivings
dsDec (NewtypeInstD cxt n tys con derivings) =
dsDataInstDec Newtype cxt n Nothing (map TANormal tys) Nothing [con] derivings
#endif
#if __GLASGOW_HASKELL__ >= 807
dsDec (TySynInstD eqn :: TySynEqn
eqn) = (DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DTySynEqn -> DDec
DTySynInstD (DTySynEqn -> DDec) -> q DTySynEqn -> q DDec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> TySynEqn -> q DTySynEqn
forall (q :: * -> *). DsMonad q => Name -> TySynEqn -> q DTySynEqn
dsTySynEqn Name
forall a. a
unusedArgument TySynEqn
eqn)
#else
dsDec (TySynInstD n eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn n eqn)
#endif
#if __GLASGOW_HASKELL__ > 710
dsDec (ClosedTypeFamilyD tfHead :: TypeFamilyHead
tfHead eqns :: [TySynEqn]
eqns) =
(DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DTypeFamilyHead -> [DTySynEqn] -> DDec
DClosedTypeFamilyD (DTypeFamilyHead -> [DTySynEqn] -> DDec)
-> q DTypeFamilyHead -> q ([DTySynEqn] -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeFamilyHead -> q DTypeFamilyHead
forall (q :: * -> *).
DsMonad q =>
TypeFamilyHead -> q DTypeFamilyHead
dsTypeFamilyHead TypeFamilyHead
tfHead
q ([DTySynEqn] -> DDec) -> q [DTySynEqn] -> q DDec
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TySynEqn -> q DTySynEqn) -> [TySynEqn] -> q [DTySynEqn]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> TySynEqn -> q DTySynEqn
forall (q :: * -> *). DsMonad q => Name -> TySynEqn -> q DTySynEqn
dsTySynEqn (TypeFamilyHead -> Name
typeFamilyHeadName TypeFamilyHead
tfHead)) [TySynEqn]
eqns)
#else
dsDec (ClosedTypeFamilyD n tvbs m_k eqns) = do
(:[]) <$> (DClosedTypeFamilyD <$> dsTypeFamilyHead n tvbs m_k
<*> mapM (dsTySynEqn n) eqns)
#endif
dsDec (RoleAnnotD n :: Name
n roles :: [Role]
roles) = [DDec] -> q [DDec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> [Role] -> DDec
DRoleAnnotD Name
n [Role]
roles]
#if __GLASGOW_HASKELL__ >= 709
#if __GLASGOW_HASKELL__ >= 801
dsDec (PatSynD n :: Name
n args :: PatSynArgs
args dir :: PatSynDir
dir pat :: Pat
pat) = do
DPatSynDir
dir' <- Name -> PatSynDir -> q DPatSynDir
forall (q :: * -> *).
DsMonad q =>
Name -> PatSynDir -> q DPatSynDir
dsPatSynDir Name
n PatSynDir
dir
(pat' :: DPat
pat', vars :: [(Name, DExp)]
vars) <- Pat -> q (DPat, [(Name, DExp)])
forall (q :: * -> *). DsMonad q => Pat -> q (DPat, [(Name, DExp)])
dsPatX Pat
pat
Bool -> q () -> q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(Name, DExp)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Name, DExp)]
vars) (q () -> q ()) -> q () -> q ()
forall a b. (a -> b) -> a -> b
$
String -> q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q ()) -> String -> q ()
forall a b. (a -> b) -> a -> b
$ "Pattern synonym definition cannot contain as-patterns (@)."
[DDec] -> q [DDec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> PatSynArgs -> DPatSynDir -> DPat -> DDec
DPatSynD Name
n PatSynArgs
args DPatSynDir
dir' DPat
pat']
dsDec (PatSynSigD n :: Name
n ty :: Type
ty) = (DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> DType -> DDec
DPatSynSigD Name
n (DType -> DDec) -> q DType -> q DDec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty)
dsDec (StandaloneDerivD mds :: Maybe DerivStrategy
mds cxt :: Cxt
cxt ty :: Type
ty) =
(DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe DDerivStrategy -> Maybe [DTyVarBndr] -> DCxt -> DType -> DDec
DStandaloneDerivD (Maybe DDerivStrategy
-> Maybe [DTyVarBndr] -> DCxt -> DType -> DDec)
-> q (Maybe DDerivStrategy)
-> q (Maybe [DTyVarBndr] -> DCxt -> DType -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DerivStrategy -> q DDerivStrategy)
-> Maybe DerivStrategy -> q (Maybe DDerivStrategy)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DerivStrategy -> q DDerivStrategy
forall (q :: * -> *).
DsMonad q =>
DerivStrategy -> q DDerivStrategy
dsDerivStrategy Maybe DerivStrategy
mds
q (Maybe [DTyVarBndr] -> DCxt -> DType -> DDec)
-> q (Maybe [DTyVarBndr]) -> q (DCxt -> DType -> DDec)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe [DTyVarBndr] -> q (Maybe [DTyVarBndr])
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [DTyVarBndr]
forall a. Maybe a
Nothing q (DCxt -> DType -> DDec) -> q DCxt -> q (DType -> DDec)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Cxt -> q DCxt
forall (q :: * -> *). DsMonad q => Cxt -> q DCxt
dsCxt Cxt
cxt q (DType -> DDec) -> q DType -> q DDec
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty)
#else
dsDec (StandaloneDerivD cxt ty) =
(:[]) <$> (DStandaloneDerivD Nothing Nothing <$> dsCxt cxt <*> dsType ty)
#endif
dsDec (DefaultSigD n :: Name
n ty :: Type
ty) = (DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> DType -> DDec
DDefaultSigD Name
n (DType -> DDec) -> q DType -> q DDec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty)
#endif
#if __GLASGOW_HASKELL__ >= 807
dsDec (ImplicitParamBindD {}) = String -> q [DDec]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "Non-`let`-bound implicit param binding"
#endif
dsDataDec :: DsMonad q
=> NewOrData -> Cxt -> Name -> [TyVarBndr]
-> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec]
dsDataDec :: NewOrData
-> Cxt
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
dsDataDec nd :: NewOrData
nd cxt :: Cxt
cxt n :: Name
n tvbs :: [TyVarBndr]
tvbs mk :: Maybe Type
mk cons :: [Con]
cons derivings :: [DerivClause]
derivings = do
[DTyVarBndr]
tvbs' <- (TyVarBndr -> q DTyVarBndr) -> [TyVarBndr] -> q [DTyVarBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> q DTyVarBndr
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndr
dsTvb [TyVarBndr]
tvbs
let h98_tvbs :: [DTyVarBndr]
h98_tvbs = case Maybe Type
mk of
Just {} -> [DTyVarBndr]
forall a. a
unusedArgument
Nothing -> [DTyVarBndr]
tvbs'
h98_return_type :: DType
h98_return_type = Name -> [DTyVarBndr] -> DType
nonFamilyDataReturnType Name
n [DTyVarBndr]
tvbs'
(DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NewOrData
-> DCxt
-> Name
-> [DTyVarBndr]
-> Maybe DType
-> [DCon]
-> [DDerivClause]
-> DDec
DDataD NewOrData
nd (DCxt
-> Name
-> [DTyVarBndr]
-> Maybe DType
-> [DCon]
-> [DDerivClause]
-> DDec)
-> q DCxt
-> q (Name
-> [DTyVarBndr] -> Maybe DType -> [DCon] -> [DDerivClause] -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt -> q DCxt
forall (q :: * -> *). DsMonad q => Cxt -> q DCxt
dsCxt Cxt
cxt q (Name
-> [DTyVarBndr] -> Maybe DType -> [DCon] -> [DDerivClause] -> DDec)
-> q Name
-> q ([DTyVarBndr]
-> Maybe DType -> [DCon] -> [DDerivClause] -> DDec)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> q Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
q ([DTyVarBndr] -> Maybe DType -> [DCon] -> [DDerivClause] -> DDec)
-> q [DTyVarBndr]
-> q (Maybe DType -> [DCon] -> [DDerivClause] -> DDec)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [DTyVarBndr] -> q [DTyVarBndr]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [DTyVarBndr]
tvbs' q (Maybe DType -> [DCon] -> [DDerivClause] -> DDec)
-> q (Maybe DType) -> q ([DCon] -> [DDerivClause] -> DDec)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Type -> q DType) -> Maybe Type -> q (Maybe DType)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Maybe Type
mk
q ([DCon] -> [DDerivClause] -> DDec)
-> q [DCon] -> q ([DDerivClause] -> DDec)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Con -> q [DCon]) -> [Con] -> q [DCon]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM ([DTyVarBndr] -> DType -> Con -> q [DCon]
forall (q :: * -> *).
DsMonad q =>
[DTyVarBndr] -> DType -> Con -> q [DCon]
dsCon [DTyVarBndr]
h98_tvbs DType
h98_return_type) [Con]
cons
q ([DDerivClause] -> DDec) -> q [DDerivClause] -> q DDec
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (DerivClause -> q DDerivClause)
-> [DerivClause] -> q [DDerivClause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DerivClause -> q DDerivClause
forall (q :: * -> *). DsMonad q => DerivClause -> q DDerivClause
dsDerivClause [DerivClause]
derivings)
dsDataInstDec :: DsMonad q
=> NewOrData -> Cxt -> Name -> Maybe [TyVarBndr] -> [TypeArg]
-> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec]
dsDataInstDec :: NewOrData
-> Cxt
-> Name
-> Maybe [TyVarBndr]
-> [TypeArg]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
dsDataInstDec nd :: NewOrData
nd cxt :: Cxt
cxt n :: Name
n mtvbs :: Maybe [TyVarBndr]
mtvbs tys :: [TypeArg]
tys mk :: Maybe Type
mk cons :: [Con]
cons derivings :: [DerivClause]
derivings = do
Maybe [DTyVarBndr]
mtvbs' <- ([TyVarBndr] -> q [DTyVarBndr])
-> Maybe [TyVarBndr] -> q (Maybe [DTyVarBndr])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((TyVarBndr -> q DTyVarBndr) -> [TyVarBndr] -> q [DTyVarBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> q DTyVarBndr
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndr
dsTvb) Maybe [TyVarBndr]
mtvbs
[DTypeArg]
tys' <- (TypeArg -> q DTypeArg) -> [TypeArg] -> q [DTypeArg]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TypeArg -> q DTypeArg
forall (q :: * -> *). DsMonad q => TypeArg -> q DTypeArg
dsTypeArg [TypeArg]
tys
let lhs' :: DType
lhs' = DType -> [DTypeArg] -> DType
applyDType (Name -> DType
DConT Name
n) [DTypeArg]
tys'
h98_tvbs :: [DTyVarBndr]
h98_tvbs =
case (Maybe Type
mk, Maybe [DTyVarBndr]
mtvbs') of
(Just {}, _) -> [DTyVarBndr]
forall a. a
unusedArgument
(Nothing, Just tvbs' :: [DTyVarBndr]
tvbs') -> [DTyVarBndr]
tvbs'
(Nothing, Nothing) -> [DTypeArg] -> [DTyVarBndr]
dataFamInstTvbs [DTypeArg]
tys'
h98_fam_inst_type :: DType
h98_fam_inst_type = Name -> [DTypeArg] -> DType
dataFamInstReturnType Name
n [DTypeArg]
tys'
(DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NewOrData
-> DCxt
-> Maybe [DTyVarBndr]
-> DType
-> Maybe DType
-> [DCon]
-> [DDerivClause]
-> DDec
DDataInstD NewOrData
nd (DCxt
-> Maybe [DTyVarBndr]
-> DType
-> Maybe DType
-> [DCon]
-> [DDerivClause]
-> DDec)
-> q DCxt
-> q (Maybe [DTyVarBndr]
-> DType -> Maybe DType -> [DCon] -> [DDerivClause] -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt -> q DCxt
forall (q :: * -> *). DsMonad q => Cxt -> q DCxt
dsCxt Cxt
cxt q (Maybe [DTyVarBndr]
-> DType -> Maybe DType -> [DCon] -> [DDerivClause] -> DDec)
-> q (Maybe [DTyVarBndr])
-> q (DType -> Maybe DType -> [DCon] -> [DDerivClause] -> DDec)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe [DTyVarBndr] -> q (Maybe [DTyVarBndr])
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [DTyVarBndr]
mtvbs'
q (DType -> Maybe DType -> [DCon] -> [DDerivClause] -> DDec)
-> q DType -> q (Maybe DType -> [DCon] -> [DDerivClause] -> DDec)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DType -> q DType
forall (f :: * -> *) a. Applicative f => a -> f a
pure DType
lhs' q (Maybe DType -> [DCon] -> [DDerivClause] -> DDec)
-> q (Maybe DType) -> q ([DCon] -> [DDerivClause] -> DDec)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Type -> q DType) -> Maybe Type -> q (Maybe DType)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Maybe Type
mk
q ([DCon] -> [DDerivClause] -> DDec)
-> q [DCon] -> q ([DDerivClause] -> DDec)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Con -> q [DCon]) -> [Con] -> q [DCon]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM ([DTyVarBndr] -> DType -> Con -> q [DCon]
forall (q :: * -> *).
DsMonad q =>
[DTyVarBndr] -> DType -> Con -> q [DCon]
dsCon [DTyVarBndr]
h98_tvbs DType
h98_fam_inst_type) [Con]
cons
q ([DDerivClause] -> DDec) -> q [DDerivClause] -> q DDec
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (DerivClause -> q DDerivClause)
-> [DerivClause] -> q [DDerivClause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DerivClause -> q DDerivClause
forall (q :: * -> *). DsMonad q => DerivClause -> q DDerivClause
dsDerivClause [DerivClause]
derivings)
mkExtraKindBinders :: DsMonad q => Maybe Kind -> q [DTyVarBndr]
=
q DType -> (Type -> q DType) -> Maybe Type -> q DType
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (DType -> q DType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> DType
DConT Name
typeKindName)) (Q Type -> q Type
forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ (Q Type -> q Type) -> (Type -> Q Type) -> Type -> q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Q Type
resolveTypeSynonyms (Type -> q Type) -> (Type -> q DType) -> Type -> q DType
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType)
(Maybe Type -> q DType)
-> (DType -> q [DTyVarBndr]) -> Maybe Type -> q [DTyVarBndr]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> DType -> q [DTyVarBndr]
forall (q :: * -> *). Quasi q => DType -> q [DTyVarBndr]
mkExtraDKindBinders'
mkExtraDKindBinders' :: Quasi q => DKind -> q [DTyVarBndr]
= (DType -> ([DTyVarBndr], DCxt, DCxt, DType))
-> (Name -> DType -> DTyVarBndr) -> DType -> q [DTyVarBndr]
forall (q :: * -> *) kind tyVarBndr pred.
Quasi q =>
(kind -> ([tyVarBndr], [pred], [kind], kind))
-> (Name -> kind -> tyVarBndr) -> kind -> q [tyVarBndr]
mkExtraKindBindersGeneric DType -> ([DTyVarBndr], DCxt, DCxt, DType)
unravel Name -> DType -> DTyVarBndr
DKindedTV
#if __GLASGOW_HASKELL__ > 710
dsFamilyResultSig :: DsMonad q => FamilyResultSig -> q DFamilyResultSig
dsFamilyResultSig :: FamilyResultSig -> q DFamilyResultSig
dsFamilyResultSig NoSig = DFamilyResultSig -> q DFamilyResultSig
forall (m :: * -> *) a. Monad m => a -> m a
return DFamilyResultSig
DNoSig
dsFamilyResultSig (KindSig k :: Type
k) = DType -> DFamilyResultSig
DKindSig (DType -> DFamilyResultSig) -> q DType -> q DFamilyResultSig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
k
dsFamilyResultSig (TyVarSig tvb :: TyVarBndr
tvb) = DTyVarBndr -> DFamilyResultSig
DTyVarSig (DTyVarBndr -> DFamilyResultSig)
-> q DTyVarBndr -> q DFamilyResultSig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyVarBndr -> q DTyVarBndr
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndr
dsTvb TyVarBndr
tvb
dsTypeFamilyHead :: DsMonad q => TypeFamilyHead -> q DTypeFamilyHead
dsTypeFamilyHead :: TypeFamilyHead -> q DTypeFamilyHead
dsTypeFamilyHead (TypeFamilyHead n :: Name
n tvbs :: [TyVarBndr]
tvbs result :: FamilyResultSig
result inj :: Maybe InjectivityAnn
inj)
= Name
-> [DTyVarBndr]
-> DFamilyResultSig
-> Maybe InjectivityAnn
-> DTypeFamilyHead
DTypeFamilyHead Name
n ([DTyVarBndr]
-> DFamilyResultSig -> Maybe InjectivityAnn -> DTypeFamilyHead)
-> q [DTyVarBndr]
-> q (DFamilyResultSig -> Maybe InjectivityAnn -> DTypeFamilyHead)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVarBndr -> q DTyVarBndr) -> [TyVarBndr] -> q [DTyVarBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> q DTyVarBndr
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndr
dsTvb [TyVarBndr]
tvbs
q (DFamilyResultSig -> Maybe InjectivityAnn -> DTypeFamilyHead)
-> q DFamilyResultSig
-> q (Maybe InjectivityAnn -> DTypeFamilyHead)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FamilyResultSig -> q DFamilyResultSig
forall (q :: * -> *).
DsMonad q =>
FamilyResultSig -> q DFamilyResultSig
dsFamilyResultSig FamilyResultSig
result
q (Maybe InjectivityAnn -> DTypeFamilyHead)
-> q (Maybe InjectivityAnn) -> q DTypeFamilyHead
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe InjectivityAnn -> q (Maybe InjectivityAnn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe InjectivityAnn
inj
typeFamilyHeadName :: TypeFamilyHead -> Name
typeFamilyHeadName :: TypeFamilyHead -> Name
typeFamilyHeadName (TypeFamilyHead n :: Name
n _ _ _) = Name
n
#else
dsTypeFamilyHead :: DsMonad q
=> Name -> [TyVarBndr] -> Maybe Kind -> q DTypeFamilyHead
dsTypeFamilyHead n tvbs m_kind = do
result_sig <- case m_kind of
Nothing -> return DNoSig
Just k -> DKindSig <$> dsType k
DTypeFamilyHead n <$> mapM dsTvb tvbs
<*> pure result_sig
<*> pure Nothing
#endif
dsLetDecs :: DsMonad q => [Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs :: [Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs decs :: [Dec]
decs = do
(let_decss :: [[DLetDec]]
let_decss, ip_binders :: [DExp -> DExp]
ip_binders) <- (Dec -> q ([DLetDec], DExp -> DExp))
-> [Dec] -> q ([[DLetDec]], [DExp -> DExp])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM Dec -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
Dec -> q ([DLetDec], DExp -> DExp)
dsLetDec [Dec]
decs
let let_decs :: [DLetDec]
let_decs :: [DLetDec]
let_decs = [[DLetDec]] -> [DLetDec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[DLetDec]]
let_decss
ip_binder :: DExp -> DExp
ip_binder :: DExp -> DExp
ip_binder = ((DExp -> DExp) -> (DExp -> DExp) -> DExp -> DExp)
-> (DExp -> DExp) -> [DExp -> DExp] -> DExp -> DExp
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (DExp -> DExp) -> (DExp -> DExp) -> DExp -> DExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) DExp -> DExp
forall a. a -> a
id [DExp -> DExp]
ip_binders
([DLetDec], DExp -> DExp) -> q ([DLetDec], DExp -> DExp)
forall (m :: * -> *) a. Monad m => a -> m a
return ([DLetDec]
let_decs, DExp -> DExp
ip_binder)
dsLetDec :: DsMonad q => Dec -> q ([DLetDec], DExp -> DExp)
dsLetDec :: Dec -> q ([DLetDec], DExp -> DExp)
dsLetDec (FunD name :: Name
name clauses :: [Clause]
clauses) = do
[DClause]
clauses' <- Name -> [Clause] -> q [DClause]
forall (q :: * -> *). DsMonad q => Name -> [Clause] -> q [DClause]
dsClauses Name
name [Clause]
clauses
([DLetDec], DExp -> DExp) -> q ([DLetDec], DExp -> DExp)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name -> [DClause] -> DLetDec
DFunD Name
name [DClause]
clauses'], DExp -> DExp
forall a. a -> a
id)
dsLetDec (ValD pat :: Pat
pat body :: Body
body where_decs :: [Dec]
where_decs) = do
(pat' :: DPat
pat', vars :: [(Name, DExp)]
vars) <- Pat -> q (DPat, [(Name, DExp)])
forall (q :: * -> *). DsMonad q => Pat -> q (DPat, [(Name, DExp)])
dsPatX Pat
pat
DExp
body' <- Body -> [Dec] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => Body -> [Dec] -> DExp -> q DExp
dsBody Body
body [Dec]
where_decs DExp
error_exp
let extras :: [DLetDec]
extras = ([Name] -> [DExp] -> [DLetDec]) -> ([Name], [DExp]) -> [DLetDec]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Name -> DExp -> DLetDec) -> [Name] -> [DExp] -> [DLetDec]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (DPat -> DExp -> DLetDec
DValD (DPat -> DExp -> DLetDec)
-> (Name -> DPat) -> Name -> DExp -> DLetDec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> DPat
DVarP)) (([Name], [DExp]) -> [DLetDec]) -> ([Name], [DExp]) -> [DLetDec]
forall a b. (a -> b) -> a -> b
$ [(Name, DExp)] -> ([Name], [DExp])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Name, DExp)]
vars
([DLetDec], DExp -> DExp) -> q ([DLetDec], DExp -> DExp)
forall (m :: * -> *) a. Monad m => a -> m a
return (DPat -> DExp -> DLetDec
DValD DPat
pat' DExp
body' DLetDec -> [DLetDec] -> [DLetDec]
forall a. a -> [a] -> [a]
: [DLetDec]
extras, DExp -> DExp
forall a. a -> a
id)
where
error_exp :: DExp
error_exp = DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'error) (Lit -> DExp
DLitE
(String -> Lit
StringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ "Non-exhaustive patterns for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pat -> String
forall a. Ppr a => a -> String
pprint Pat
pat))
dsLetDec (SigD name :: Name
name ty :: Type
ty) = do
DType
ty' <- Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty
([DLetDec], DExp -> DExp) -> q ([DLetDec], DExp -> DExp)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name -> DType -> DLetDec
DSigD Name
name DType
ty'], DExp -> DExp
forall a. a -> a
id)
dsLetDec (InfixD fixity :: Fixity
fixity name :: Name
name) = ([DLetDec], DExp -> DExp) -> q ([DLetDec], DExp -> DExp)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Fixity -> Name -> DLetDec
DInfixD Fixity
fixity Name
name], DExp -> DExp
forall a. a -> a
id)
dsLetDec (PragmaD prag :: Pragma
prag) = do
DPragma
prag' <- Pragma -> q DPragma
forall (q :: * -> *). DsMonad q => Pragma -> q DPragma
dsPragma Pragma
prag
([DLetDec], DExp -> DExp) -> q ([DLetDec], DExp -> DExp)
forall (m :: * -> *) a. Monad m => a -> m a
return ([DPragma -> DLetDec
DPragmaD DPragma
prag'], DExp -> DExp
forall a. a -> a
id)
#if __GLASGOW_HASKELL__ >= 807
dsLetDec (ImplicitParamBindD n :: String
n e :: Exp
e) = do
Name
new_n_name <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
qNewName (String -> q Name) -> String -> q Name
forall a b. (a -> b) -> a -> b
$ "new_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ "_val"
DExp
e' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
e
let let_dec :: DLetDec
let_dec :: DLetDec
let_dec = DPat -> DExp -> DLetDec
DValD (Name -> DPat
DVarP Name
new_n_name) DExp
e'
ip_binder :: DExp -> DExp
ip_binder :: DExp -> DExp
ip_binder = (Name -> DExp
DVarE 'bindIP DExp -> DType -> DExp
`DAppTypeE`
TyLit -> DType
DLitT (String -> TyLit
StrTyLit String
n) DExp -> DExp -> DExp
`DAppE`
Name -> DExp
DVarE Name
new_n_name DExp -> DExp -> DExp
`DAppE`)
([DLetDec], DExp -> DExp) -> q ([DLetDec], DExp -> DExp)
forall (m :: * -> *) a. Monad m => a -> m a
return ([DLetDec
let_dec], DExp -> DExp
ip_binder)
#endif
dsLetDec _dec :: Dec
_dec = String -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "Illegal declaration in let expression."
dsTopLevelLetDec :: DsMonad q => Dec -> q [DDec]
dsTopLevelLetDec :: Dec -> q [DDec]
dsTopLevelLetDec = (([DLetDec], DExp -> DExp) -> [DDec])
-> q ([DLetDec], DExp -> DExp) -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((DLetDec -> DDec) -> [DLetDec] -> [DDec]
forall a b. (a -> b) -> [a] -> [b]
map DLetDec -> DDec
DLetDec ([DLetDec] -> [DDec])
-> (([DLetDec], DExp -> DExp) -> [DLetDec])
-> ([DLetDec], DExp -> DExp)
-> [DDec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([DLetDec], DExp -> DExp) -> [DLetDec]
forall a b. (a, b) -> a
fst) (q ([DLetDec], DExp -> DExp) -> q [DDec])
-> (Dec -> q ([DLetDec], DExp -> DExp)) -> Dec -> q [DDec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dec -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
Dec -> q ([DLetDec], DExp -> DExp)
dsLetDec
dsCon :: DsMonad q
=> [DTyVarBndr]
-> DType
-> Con -> q [DCon]
dsCon :: [DTyVarBndr] -> DType -> Con -> q [DCon]
dsCon univ_dtvbs :: [DTyVarBndr]
univ_dtvbs data_type :: DType
data_type con :: Con
con = do
[(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
dcons' <- Con -> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall (q :: * -> *).
DsMonad q =>
Con -> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
dsCon' Con
con
[DCon] -> q [DCon]
forall (m :: * -> *) a. Monad m => a -> m a
return ([DCon] -> q [DCon]) -> [DCon] -> q [DCon]
forall a b. (a -> b) -> a -> b
$ (((Name, [DTyVarBndr], DCxt, DConFields, Maybe DType) -> DCon)
-> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)] -> [DCon])
-> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
-> ((Name, [DTyVarBndr], DCxt, DConFields, Maybe DType) -> DCon)
-> [DCon]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Name, [DTyVarBndr], DCxt, DConFields, Maybe DType) -> DCon)
-> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)] -> [DCon]
forall a b. (a -> b) -> [a] -> [b]
map [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
dcons' (((Name, [DTyVarBndr], DCxt, DConFields, Maybe DType) -> DCon)
-> [DCon])
-> ((Name, [DTyVarBndr], DCxt, DConFields, Maybe DType) -> DCon)
-> [DCon]
forall a b. (a -> b) -> a -> b
$ \(n :: Name
n, dtvbs :: [DTyVarBndr]
dtvbs, dcxt :: DCxt
dcxt, fields :: DConFields
fields, m_gadt_type :: Maybe DType
m_gadt_type) ->
case Maybe DType
m_gadt_type of
Nothing ->
let ex_dtvbs :: [DTyVarBndr]
ex_dtvbs = [DTyVarBndr]
dtvbs
expl_dtvbs :: [DTyVarBndr]
expl_dtvbs = [DTyVarBndr]
univ_dtvbs [DTyVarBndr] -> [DTyVarBndr] -> [DTyVarBndr]
forall a. [a] -> [a] -> [a]
++ [DTyVarBndr]
ex_dtvbs
impl_dtvbs :: [DTyVarBndr]
impl_dtvbs = DCxt -> [DTyVarBndr]
toposortTyVarsOf (DCxt -> [DTyVarBndr]) -> DCxt -> [DTyVarBndr]
forall a b. (a -> b) -> a -> b
$ (DTyVarBndr -> Maybe DType) -> [DTyVarBndr] -> DCxt
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DTyVarBndr -> Maybe DType
extractTvbKind [DTyVarBndr]
expl_dtvbs in
[DTyVarBndr] -> DCxt -> Name -> DConFields -> DType -> DCon
DCon ([DTyVarBndr]
impl_dtvbs [DTyVarBndr] -> [DTyVarBndr] -> [DTyVarBndr]
forall a. [a] -> [a] -> [a]
++ [DTyVarBndr]
expl_dtvbs) DCxt
dcxt Name
n DConFields
fields DType
data_type
Just gadt_type :: DType
gadt_type ->
let univ_ex_dtvbs :: [DTyVarBndr]
univ_ex_dtvbs = [DTyVarBndr]
dtvbs in
[DTyVarBndr] -> DCxt -> Name -> DConFields -> DType -> DCon
DCon [DTyVarBndr]
univ_ex_dtvbs DCxt
dcxt Name
n DConFields
fields DType
gadt_type
dsCon' :: DsMonad q
=> Con -> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
dsCon' :: Con -> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
dsCon' (NormalC n :: Name
n stys :: [BangType]
stys) = do
[DBangType]
dtys <- (BangType -> q DBangType) -> [BangType] -> q [DBangType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM BangType -> q DBangType
forall (q :: * -> *). DsMonad q => BangType -> q DBangType
dsBangType [BangType]
stys
[(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
-> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Name
n, [], [], Bool -> [DBangType] -> DConFields
DNormalC Bool
False [DBangType]
dtys, Maybe DType
forall a. Maybe a
Nothing)]
dsCon' (RecC n :: Name
n vstys :: [VarBangType]
vstys) = do
[DVarBangType]
vdtys <- (VarBangType -> q DVarBangType)
-> [VarBangType] -> q [DVarBangType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM VarBangType -> q DVarBangType
forall (q :: * -> *). DsMonad q => VarBangType -> q DVarBangType
dsVarBangType [VarBangType]
vstys
[(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
-> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Name
n, [], [], [DVarBangType] -> DConFields
DRecC [DVarBangType]
vdtys, Maybe DType
forall a. Maybe a
Nothing)]
dsCon' (InfixC sty1 :: BangType
sty1 n :: Name
n sty2 :: BangType
sty2) = do
DBangType
dty1 <- BangType -> q DBangType
forall (q :: * -> *). DsMonad q => BangType -> q DBangType
dsBangType BangType
sty1
DBangType
dty2 <- BangType -> q DBangType
forall (q :: * -> *). DsMonad q => BangType -> q DBangType
dsBangType BangType
sty2
[(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
-> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Name
n, [], [], Bool -> [DBangType] -> DConFields
DNormalC Bool
True [DBangType
dty1, DBangType
dty2], Maybe DType
forall a. Maybe a
Nothing)]
dsCon' (ForallC tvbs :: [TyVarBndr]
tvbs cxt :: Cxt
cxt con :: Con
con) = do
[DTyVarBndr]
dtvbs <- (TyVarBndr -> q DTyVarBndr) -> [TyVarBndr] -> q [DTyVarBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> q DTyVarBndr
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndr
dsTvb [TyVarBndr]
tvbs
DCxt
dcxt <- Cxt -> q DCxt
forall (q :: * -> *). DsMonad q => Cxt -> q DCxt
dsCxt Cxt
cxt
[(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
dcons' <- Con -> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall (q :: * -> *).
DsMonad q =>
Con -> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
dsCon' Con
con
[(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
-> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
-> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)])
-> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
-> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall a b. (a -> b) -> a -> b
$ (((Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)
-> (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType))
-> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
-> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)])
-> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
-> ((Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)
-> (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType))
-> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)
-> (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType))
-> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
-> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall a b. (a -> b) -> [a] -> [b]
map [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
dcons' (((Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)
-> (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType))
-> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)])
-> ((Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)
-> (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType))
-> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall a b. (a -> b) -> a -> b
$ \(n :: Name
n, dtvbs' :: [DTyVarBndr]
dtvbs', dcxt' :: DCxt
dcxt', fields :: DConFields
fields, m_gadt_type :: Maybe DType
m_gadt_type) ->
(Name
n, [DTyVarBndr]
dtvbs [DTyVarBndr] -> [DTyVarBndr] -> [DTyVarBndr]
forall a. [a] -> [a] -> [a]
++ [DTyVarBndr]
dtvbs', DCxt
dcxt DCxt -> DCxt -> DCxt
forall a. [a] -> [a] -> [a]
++ DCxt
dcxt', DConFields
fields, Maybe DType
m_gadt_type)
#if __GLASGOW_HASKELL__ > 710
dsCon' (GadtC nms :: [Name]
nms btys :: [BangType]
btys rty :: Type
rty) = do
[DBangType]
dbtys <- (BangType -> q DBangType) -> [BangType] -> q [DBangType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM BangType -> q DBangType
forall (q :: * -> *). DsMonad q => BangType -> q DBangType
dsBangType [BangType]
btys
DType
drty <- Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
rty
[q (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
-> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([q (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
-> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)])
-> [q (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
-> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall a b. (a -> b) -> a -> b
$ ((Name -> q (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType))
-> [Name]
-> [q (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)])
-> [Name]
-> (Name -> q (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType))
-> [q (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Name -> q (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType))
-> [Name]
-> [q (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall a b. (a -> b) -> [a] -> [b]
map [Name]
nms ((Name -> q (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType))
-> [q (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)])
-> (Name -> q (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType))
-> [q (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall a b. (a -> b) -> a -> b
$ \nm :: Name
nm -> do
Maybe Fixity
mbFi <- Name -> q (Maybe Fixity)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe Fixity)
reifyFixityWithLocals Name
nm
let decInfix :: Bool
decInfix = String -> Bool
isInfixDataCon (Name -> String
nameBase Name
nm)
Bool -> Bool -> Bool
|| [DBangType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DBangType]
dbtys Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 2
Bool -> Bool -> Bool
|| Maybe Fixity -> Bool
forall a. Maybe a -> Bool
isJust Maybe Fixity
mbFi
(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)
-> q (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
nm, [], [], Bool -> [DBangType] -> DConFields
DNormalC Bool
decInfix [DBangType]
dbtys, DType -> Maybe DType
forall a. a -> Maybe a
Just DType
drty)
dsCon' (RecGadtC nms :: [Name]
nms vbtys :: [VarBangType]
vbtys rty :: Type
rty) = do
[DVarBangType]
dvbtys <- (VarBangType -> q DVarBangType)
-> [VarBangType] -> q [DVarBangType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM VarBangType -> q DVarBangType
forall (q :: * -> *). DsMonad q => VarBangType -> q DVarBangType
dsVarBangType [VarBangType]
vbtys
DType
drty <- Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
rty
[(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
-> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
-> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)])
-> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
-> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall a b. (a -> b) -> a -> b
$ ((Name -> (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType))
-> [Name] -> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)])
-> [Name]
-> (Name -> (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType))
-> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Name -> (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType))
-> [Name] -> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall a b. (a -> b) -> [a] -> [b]
map [Name]
nms ((Name -> (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType))
-> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)])
-> (Name -> (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType))
-> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall a b. (a -> b) -> a -> b
$ \nm :: Name
nm ->
(Name
nm, [], [], [DVarBangType] -> DConFields
DRecC [DVarBangType]
dvbtys, DType -> Maybe DType
forall a. a -> Maybe a
Just DType
drty)
#endif
#if __GLASGOW_HASKELL__ > 710
dsBangType :: DsMonad q => BangType -> q DBangType
dsBangType :: BangType -> q DBangType
dsBangType (b :: Bang
b, ty :: Type
ty) = (Bang
b, ) (DType -> DBangType) -> q DType -> q DBangType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty
dsVarBangType :: DsMonad q => VarBangType -> q DVarBangType
dsVarBangType :: VarBangType -> q DVarBangType
dsVarBangType (n :: Name
n, b :: Bang
b, ty :: Type
ty) = (Name
n, Bang
b, ) (DType -> DVarBangType) -> q DType -> q DVarBangType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty
#else
dsBangType :: DsMonad q => StrictType -> q DBangType
dsBangType (b, ty) = (strictToBang b, ) <$> dsType ty
dsVarBangType :: DsMonad q => VarStrictType -> q DVarBangType
dsVarBangType (n, b, ty) = (n, strictToBang b, ) <$> dsType ty
#endif
dsForeign :: DsMonad q => Foreign -> q DForeign
dsForeign :: Foreign -> q DForeign
dsForeign (ImportF cc :: Callconv
cc safety :: Safety
safety str :: String
str n :: Name
n ty :: Type
ty) = Callconv -> Safety -> String -> Name -> DType -> DForeign
DImportF Callconv
cc Safety
safety String
str Name
n (DType -> DForeign) -> q DType -> q DForeign
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty
dsForeign (ExportF cc :: Callconv
cc str :: String
str n :: Name
n ty :: Type
ty) = Callconv -> String -> Name -> DType -> DForeign
DExportF Callconv
cc String
str Name
n (DType -> DForeign) -> q DType -> q DForeign
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty
dsPragma :: DsMonad q => Pragma -> q DPragma
dsPragma :: Pragma -> q DPragma
dsPragma (InlineP n :: Name
n inl :: Inline
inl rm :: RuleMatch
rm phases :: Phases
phases) = DPragma -> q DPragma
forall (m :: * -> *) a. Monad m => a -> m a
return (DPragma -> q DPragma) -> DPragma -> q DPragma
forall a b. (a -> b) -> a -> b
$ Name -> Inline -> RuleMatch -> Phases -> DPragma
DInlineP Name
n Inline
inl RuleMatch
rm Phases
phases
dsPragma (SpecialiseP n :: Name
n ty :: Type
ty m_inl :: Maybe Inline
m_inl phases :: Phases
phases) = Name -> DType -> Maybe Inline -> Phases -> DPragma
DSpecialiseP Name
n (DType -> Maybe Inline -> Phases -> DPragma)
-> q DType -> q (Maybe Inline -> Phases -> DPragma)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty
q (Maybe Inline -> Phases -> DPragma)
-> q (Maybe Inline) -> q (Phases -> DPragma)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Inline -> q (Maybe Inline)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Inline
m_inl
q (Phases -> DPragma) -> q Phases -> q DPragma
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Phases -> q Phases
forall (f :: * -> *) a. Applicative f => a -> f a
pure Phases
phases
dsPragma (SpecialiseInstP ty :: Type
ty) = DType -> DPragma
DSpecialiseInstP (DType -> DPragma) -> q DType -> q DPragma
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty
#if __GLASGOW_HASKELL__ >= 807
dsPragma (RuleP str :: String
str mtvbs :: Maybe [TyVarBndr]
mtvbs rbs :: [RuleBndr]
rbs lhs :: Exp
lhs rhs :: Exp
rhs phases :: Phases
phases)
= String
-> Maybe [DTyVarBndr]
-> [DRuleBndr]
-> DExp
-> DExp
-> Phases
-> DPragma
DRuleP String
str (Maybe [DTyVarBndr]
-> [DRuleBndr] -> DExp -> DExp -> Phases -> DPragma)
-> q (Maybe [DTyVarBndr])
-> q ([DRuleBndr] -> DExp -> DExp -> Phases -> DPragma)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([TyVarBndr] -> q [DTyVarBndr])
-> Maybe [TyVarBndr] -> q (Maybe [DTyVarBndr])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((TyVarBndr -> q DTyVarBndr) -> [TyVarBndr] -> q [DTyVarBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> q DTyVarBndr
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndr
dsTvb) Maybe [TyVarBndr]
mtvbs
q ([DRuleBndr] -> DExp -> DExp -> Phases -> DPragma)
-> q [DRuleBndr] -> q (DExp -> DExp -> Phases -> DPragma)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (RuleBndr -> q DRuleBndr) -> [RuleBndr] -> q [DRuleBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM RuleBndr -> q DRuleBndr
forall (q :: * -> *). DsMonad q => RuleBndr -> q DRuleBndr
dsRuleBndr [RuleBndr]
rbs
q (DExp -> DExp -> Phases -> DPragma)
-> q DExp -> q (DExp -> Phases -> DPragma)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
lhs
q (DExp -> Phases -> DPragma) -> q DExp -> q (Phases -> DPragma)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
rhs
q (Phases -> DPragma) -> q Phases -> q DPragma
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Phases -> q Phases
forall (f :: * -> *) a. Applicative f => a -> f a
pure Phases
phases
#else
dsPragma (RuleP str rbs lhs rhs phases) = DRuleP str Nothing
<$> mapM dsRuleBndr rbs
<*> dsExp lhs
<*> dsExp rhs
<*> pure phases
#endif
dsPragma (AnnP target :: AnnTarget
target exp :: Exp
exp) = AnnTarget -> DExp -> DPragma
DAnnP AnnTarget
target (DExp -> DPragma) -> q DExp -> q DPragma
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
#if __GLASGOW_HASKELL__ >= 709
dsPragma (LineP n :: Int
n str :: String
str) = DPragma -> q DPragma
forall (m :: * -> *) a. Monad m => a -> m a
return (DPragma -> q DPragma) -> DPragma -> q DPragma
forall a b. (a -> b) -> a -> b
$ Int -> String -> DPragma
DLineP Int
n String
str
#endif
#if __GLASGOW_HASKELL__ >= 801
dsPragma (CompleteP cls :: [Name]
cls mty :: Maybe Name
mty) = DPragma -> q DPragma
forall (m :: * -> *) a. Monad m => a -> m a
return (DPragma -> q DPragma) -> DPragma -> q DPragma
forall a b. (a -> b) -> a -> b
$ [Name] -> Maybe Name -> DPragma
DCompleteP [Name]
cls Maybe Name
mty
#endif
dsRuleBndr :: DsMonad q => RuleBndr -> q DRuleBndr
dsRuleBndr :: RuleBndr -> q DRuleBndr
dsRuleBndr (RuleVar n :: Name
n) = DRuleBndr -> q DRuleBndr
forall (m :: * -> *) a. Monad m => a -> m a
return (DRuleBndr -> q DRuleBndr) -> DRuleBndr -> q DRuleBndr
forall a b. (a -> b) -> a -> b
$ Name -> DRuleBndr
DRuleVar Name
n
dsRuleBndr (TypedRuleVar n :: Name
n ty :: Type
ty) = Name -> DType -> DRuleBndr
DTypedRuleVar Name
n (DType -> DRuleBndr) -> q DType -> q DRuleBndr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty
#if __GLASGOW_HASKELL__ >= 807
dsTySynEqn :: DsMonad q => Name -> TySynEqn -> q DTySynEqn
dsTySynEqn :: Name -> TySynEqn -> q DTySynEqn
dsTySynEqn _ (TySynEqn mtvbs :: Maybe [TyVarBndr]
mtvbs lhs :: Type
lhs rhs :: Type
rhs) =
Maybe [DTyVarBndr] -> DType -> DType -> DTySynEqn
DTySynEqn (Maybe [DTyVarBndr] -> DType -> DType -> DTySynEqn)
-> q (Maybe [DTyVarBndr]) -> q (DType -> DType -> DTySynEqn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([TyVarBndr] -> q [DTyVarBndr])
-> Maybe [TyVarBndr] -> q (Maybe [DTyVarBndr])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((TyVarBndr -> q DTyVarBndr) -> [TyVarBndr] -> q [DTyVarBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> q DTyVarBndr
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndr
dsTvb) Maybe [TyVarBndr]
mtvbs q (DType -> DType -> DTySynEqn)
-> q DType -> q (DType -> DTySynEqn)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
lhs q (DType -> DTySynEqn) -> q DType -> q DTySynEqn
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
rhs
#else
dsTySynEqn :: DsMonad q => Name -> TySynEqn -> q DTySynEqn
dsTySynEqn n (TySynEqn lhss rhs) = do
lhss' <- mapM dsType lhss
let lhs' = applyDType (DConT n) $ map DTANormal lhss'
DTySynEqn Nothing lhs' <$> dsType rhs
#endif
dsClauses :: DsMonad q
=> Name
-> [Clause]
-> q [DClause]
dsClauses :: Name -> [Clause] -> q [DClause]
dsClauses _ [] = [DClause] -> q [DClause]
forall (m :: * -> *) a. Monad m => a -> m a
return []
dsClauses n :: Name
n (Clause pats :: [Pat]
pats (NormalB exp :: Exp
exp) where_decs :: [Dec]
where_decs : rest :: [Clause]
rest) = do
[DClause]
rest' <- Name -> [Clause] -> q [DClause]
forall (q :: * -> *). DsMonad q => Name -> [Clause] -> q [DClause]
dsClauses Name
n [Clause]
rest
DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
(where_decs' :: [DLetDec]
where_decs', ip_binder :: DExp -> DExp
ip_binder) <- [Dec] -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
where_decs
let exp_with_wheres :: DExp
exp_with_wheres = [DLetDec] -> DExp -> DExp
maybeDLetE [DLetDec]
where_decs' (DExp -> DExp
ip_binder DExp
exp')
(pats' :: [DPat]
pats', exp'' :: DExp
exp'') <- [Pat] -> DExp -> q ([DPat], DExp)
forall (q :: * -> *).
DsMonad q =>
[Pat] -> DExp -> q ([DPat], DExp)
dsPatsOverExp [Pat]
pats DExp
exp_with_wheres
[DClause] -> q [DClause]
forall (m :: * -> *) a. Monad m => a -> m a
return ([DClause] -> q [DClause]) -> [DClause] -> q [DClause]
forall a b. (a -> b) -> a -> b
$ [DPat] -> DExp -> DClause
DClause [DPat]
pats' DExp
exp'' DClause -> [DClause] -> [DClause]
forall a. a -> [a] -> [a]
: [DClause]
rest'
dsClauses n :: Name
n clauses :: [Clause]
clauses@(Clause outer_pats :: [Pat]
outer_pats _ _ : _) = do
[Name]
arg_names <- Int -> q Name -> q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([Pat] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat]
outer_pats) (String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName "arg")
let scrutinee :: DExp
scrutinee = [DExp] -> DExp
mkTupleDExp ((Name -> DExp) -> [Name] -> [DExp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DExp
DVarE [Name]
arg_names)
DClause
clause <- [DPat] -> DExp -> DClause
DClause ((Name -> DPat) -> [Name] -> [DPat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DPat
DVarP [Name]
arg_names) (DExp -> DClause) -> q DExp -> q DClause
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(DExp -> [DMatch] -> DExp
DCaseE DExp
scrutinee ([DMatch] -> DExp) -> q [DMatch] -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Clause -> [DMatch] -> q [DMatch])
-> [DMatch] -> [Clause] -> q [DMatch]
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM (DExp -> Clause -> [DMatch] -> q [DMatch]
forall (q :: * -> *).
DsMonad q =>
DExp -> Clause -> [DMatch] -> q [DMatch]
clause_to_dmatch DExp
scrutinee) [] [Clause]
clauses)
[DClause] -> q [DClause]
forall (m :: * -> *) a. Monad m => a -> m a
return [DClause
clause]
where
clause_to_dmatch :: DsMonad q => DExp -> Clause -> [DMatch] -> q [DMatch]
clause_to_dmatch :: DExp -> Clause -> [DMatch] -> q [DMatch]
clause_to_dmatch scrutinee :: DExp
scrutinee (Clause pats :: [Pat]
pats body :: Body
body where_decs :: [Dec]
where_decs) failure_matches :: [DMatch]
failure_matches = do
let failure_exp :: DExp
failure_exp = String -> DExp -> [DMatch] -> DExp
maybeDCaseE ("Non-exhaustive patterns in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Name -> String
forall a. Show a => a -> String
show Name
n))
DExp
scrutinee [DMatch]
failure_matches
DExp
exp <- Body -> [Dec] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => Body -> [Dec] -> DExp -> q DExp
dsBody Body
body [Dec]
where_decs DExp
failure_exp
(pats' :: [DPat]
pats', exp' :: DExp
exp') <- [Pat] -> DExp -> q ([DPat], DExp)
forall (q :: * -> *).
DsMonad q =>
[Pat] -> DExp -> q ([DPat], DExp)
dsPatsOverExp [Pat]
pats DExp
exp
Bool
uni_pats <- (All -> Bool) -> q All -> q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap All -> Bool
getAll (q All -> q Bool) -> q All -> q Bool
forall a b. (a -> b) -> a -> b
$ (DPat -> q All) -> [DPat] -> q All
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM ((Bool -> All) -> q Bool -> q All
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> All
All (q Bool -> q All) -> (DPat -> q Bool) -> DPat -> q All
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DPat -> q Bool
forall (q :: * -> *). DsMonad q => DPat -> q Bool
isUniversalPattern) [DPat]
pats'
let match :: DMatch
match = DPat -> DExp -> DMatch
DMatch ([DPat] -> DPat
mkTupleDPat [DPat]
pats') DExp
exp'
if Bool
uni_pats
then [DMatch] -> q [DMatch]
forall (m :: * -> *) a. Monad m => a -> m a
return [DMatch
match]
else [DMatch] -> q [DMatch]
forall (m :: * -> *) a. Monad m => a -> m a
return (DMatch
match DMatch -> [DMatch] -> [DMatch]
forall a. a -> [a] -> [a]
: [DMatch]
failure_matches)
dsType :: DsMonad q => Type -> q DType
dsType :: Type -> q DType
dsType (ForallT tvbs :: [TyVarBndr]
tvbs preds :: Cxt
preds ty :: Type
ty) = [DTyVarBndr] -> DCxt -> DType -> DType
DForallT ([DTyVarBndr] -> DCxt -> DType -> DType)
-> q [DTyVarBndr] -> q (DCxt -> DType -> DType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVarBndr -> q DTyVarBndr) -> [TyVarBndr] -> q [DTyVarBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> q DTyVarBndr
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndr
dsTvb [TyVarBndr]
tvbs q (DCxt -> DType -> DType) -> q DCxt -> q (DType -> DType)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Cxt -> q DCxt
forall (q :: * -> *). DsMonad q => Cxt -> q DCxt
dsCxt Cxt
preds q (DType -> DType) -> q DType -> q DType
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty
dsType (AppT t1 :: Type
t1 t2 :: Type
t2) = DType -> DType -> DType
DAppT (DType -> DType -> DType) -> q DType -> q (DType -> DType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
t1 q (DType -> DType) -> q DType -> q DType
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
t2
dsType (SigT ty :: Type
ty ki :: Type
ki) = DType -> DType -> DType
DSigT (DType -> DType -> DType) -> q DType -> q (DType -> DType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty q (DType -> DType) -> q DType -> q DType
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ki
dsType (VarT name :: Name
name) = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DVarT Name
name
dsType (ConT name :: Name
name) = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT Name
name
dsType (PromotedT name :: Name
name) = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT Name
name
dsType (TupleT n :: Int
n) = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT (Int -> Name
tupleTypeName Int
n)
dsType (UnboxedTupleT n :: Int
n) = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT (Int -> Name
unboxedTupleTypeName Int
n)
dsType ArrowT = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return DType
DArrowT
dsType ListT = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT ''[]
dsType (PromotedTupleT n :: Int
n) = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT (Int -> Name
tupleDataName Int
n)
dsType PromotedNilT = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT '[]
dsType PromotedConsT = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT '(:)
dsType StarT = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT Name
typeKindName
dsType ConstraintT = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT ''Constraint
dsType (LitT lit :: TyLit
lit) = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ TyLit -> DType
DLitT TyLit
lit
#if __GLASGOW_HASKELL__ >= 709
dsType EqualityT = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT ''(~)
#endif
#if __GLASGOW_HASKELL__ > 710
dsType (InfixT t1 :: Type
t1 n :: Name
n t2 :: Type
t2) = DType -> DType -> DType
DAppT (DType -> DType -> DType) -> q DType -> q (DType -> DType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DType -> DType -> DType
DAppT (Name -> DType
DConT Name
n) (DType -> DType) -> q DType -> q DType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
t1) q (DType -> DType) -> q DType -> q DType
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
t2
dsType (UInfixT _ _ _) = String -> q DType
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Cannot desugar unresolved infix operators."
dsType (ParensT t :: Type
t) = Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
t
dsType WildCardT = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return DType
DWildCardT
#endif
#if __GLASGOW_HASKELL__ >= 801
dsType (UnboxedSumT arity :: Int
arity) = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT (Int -> Name
unboxedSumTypeName Int
arity)
#endif
#if __GLASGOW_HASKELL__ >= 807
dsType (AppKindT t :: Type
t k :: Type
k) = DType -> DType -> DType
DAppKindT (DType -> DType -> DType) -> q DType -> q (DType -> DType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
t q (DType -> DType) -> q DType -> q DType
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
k
dsType (ImplicitParamT n :: String
n t :: Type
t) = do
DType
t' <- Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
t
DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT ''IP DType -> DType -> DType
`DAppT` TyLit -> DType
DLitT (String -> TyLit
StrTyLit String
n) DType -> DType -> DType
`DAppT` DType
t'
#endif
dsTvb :: DsMonad q => TyVarBndr -> q DTyVarBndr
dsTvb :: TyVarBndr -> q DTyVarBndr
dsTvb (PlainTV n :: Name
n) = DTyVarBndr -> q DTyVarBndr
forall (m :: * -> *) a. Monad m => a -> m a
return (DTyVarBndr -> q DTyVarBndr) -> DTyVarBndr -> q DTyVarBndr
forall a b. (a -> b) -> a -> b
$ Name -> DTyVarBndr
DPlainTV Name
n
dsTvb (KindedTV n :: Name
n k :: Type
k) = Name -> DType -> DTyVarBndr
DKindedTV Name
n (DType -> DTyVarBndr) -> q DType -> q DTyVarBndr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
k
dsCxt :: DsMonad q => Cxt -> q DCxt
dsCxt :: Cxt -> q DCxt
dsCxt = (Type -> q DCxt) -> Cxt -> q DCxt
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM Type -> q DCxt
forall (q :: * -> *). DsMonad q => Type -> q DCxt
dsPred
#if __GLASGOW_HASKELL__ >= 801
type DerivingClause = DerivClause
dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause
dsDerivClause :: DerivClause -> q DDerivClause
dsDerivClause (DerivClause mds :: Maybe DerivStrategy
mds cxt :: Cxt
cxt) =
Maybe DDerivStrategy -> DCxt -> DDerivClause
DDerivClause (Maybe DDerivStrategy -> DCxt -> DDerivClause)
-> q (Maybe DDerivStrategy) -> q (DCxt -> DDerivClause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DerivStrategy -> q DDerivStrategy)
-> Maybe DerivStrategy -> q (Maybe DDerivStrategy)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DerivStrategy -> q DDerivStrategy
forall (q :: * -> *).
DsMonad q =>
DerivStrategy -> q DDerivStrategy
dsDerivStrategy Maybe DerivStrategy
mds q (DCxt -> DDerivClause) -> q DCxt -> q DDerivClause
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Cxt -> q DCxt
forall (q :: * -> *). DsMonad q => Cxt -> q DCxt
dsCxt Cxt
cxt
#elif __GLASGOW_HASKELL__ >= 711
type DerivingClause = Pred
dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause
dsDerivClause p = DDerivClause Nothing <$> dsPred p
#else
type DerivingClause = Name
dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause
dsDerivClause n = pure $ DDerivClause Nothing [DConT n]
#endif
#if __GLASGOW_HASKELL__ >= 801
dsDerivStrategy :: DsMonad q => DerivStrategy -> q DDerivStrategy
dsDerivStrategy :: DerivStrategy -> q DDerivStrategy
dsDerivStrategy StockStrategy = DDerivStrategy -> q DDerivStrategy
forall (f :: * -> *) a. Applicative f => a -> f a
pure DDerivStrategy
DStockStrategy
dsDerivStrategy AnyclassStrategy = DDerivStrategy -> q DDerivStrategy
forall (f :: * -> *) a. Applicative f => a -> f a
pure DDerivStrategy
DAnyclassStrategy
dsDerivStrategy NewtypeStrategy = DDerivStrategy -> q DDerivStrategy
forall (f :: * -> *) a. Applicative f => a -> f a
pure DDerivStrategy
DNewtypeStrategy
#if __GLASGOW_HASKELL__ >= 805
dsDerivStrategy (ViaStrategy ty :: Type
ty) = DType -> DDerivStrategy
DViaStrategy (DType -> DDerivStrategy) -> q DType -> q DDerivStrategy
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty
#endif
#endif
#if __GLASGOW_HASKELL__ >= 801
dsPatSynDir :: DsMonad q => Name -> PatSynDir -> q DPatSynDir
dsPatSynDir :: Name -> PatSynDir -> q DPatSynDir
dsPatSynDir _ Unidir = DPatSynDir -> q DPatSynDir
forall (f :: * -> *) a. Applicative f => a -> f a
pure DPatSynDir
DUnidir
dsPatSynDir _ ImplBidir = DPatSynDir -> q DPatSynDir
forall (f :: * -> *) a. Applicative f => a -> f a
pure DPatSynDir
DImplBidir
dsPatSynDir n :: Name
n (ExplBidir clauses :: [Clause]
clauses) = [DClause] -> DPatSynDir
DExplBidir ([DClause] -> DPatSynDir) -> q [DClause] -> q DPatSynDir
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> [Clause] -> q [DClause]
forall (q :: * -> *). DsMonad q => Name -> [Clause] -> q [DClause]
dsClauses Name
n [Clause]
clauses
#endif
dsPred :: DsMonad q => Pred -> q DCxt
#if __GLASGOW_HASKELL__ < 709
dsPred (ClassP n tys) = do
ts' <- mapM dsType tys
return [foldl DAppT (DConT n) ts']
dsPred (EqualP t1 t2) = do
ts' <- mapM dsType [t1, t2]
return [foldl DAppT (DConT ''(~)) ts']
#else
dsPred :: Type -> q DCxt
dsPred t :: Type
t
| Just ts :: Cxt
ts <- Type -> Maybe Cxt
splitTuple_maybe Type
t
= (Type -> q DCxt) -> Cxt -> q DCxt
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM Type -> q DCxt
forall (q :: * -> *). DsMonad q => Type -> q DCxt
dsPred Cxt
ts
dsPred (ForallT tvbs :: [TyVarBndr]
tvbs cxt :: Cxt
cxt p :: Type
p) = do
DCxt
ps' <- Type -> q DCxt
forall (q :: * -> *). DsMonad q => Type -> q DCxt
dsPred Type
p
case DCxt
ps' of
[p' :: DType
p'] -> (DType -> DCxt -> DCxt
forall a. a -> [a] -> [a]
:[]) (DType -> DCxt) -> q DType -> q DCxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([DTyVarBndr] -> DCxt -> DType -> DType
DForallT ([DTyVarBndr] -> DCxt -> DType -> DType)
-> q [DTyVarBndr] -> q (DCxt -> DType -> DType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVarBndr -> q DTyVarBndr) -> [TyVarBndr] -> q [DTyVarBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> q DTyVarBndr
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndr
dsTvb [TyVarBndr]
tvbs q (DCxt -> DType -> DType) -> q DCxt -> q (DType -> DType)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Cxt -> q DCxt
forall (q :: * -> *). DsMonad q => Cxt -> q DCxt
dsCxt Cxt
cxt q (DType -> DType) -> q DType -> q DType
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DType -> q DType
forall (f :: * -> *) a. Applicative f => a -> f a
pure DType
p')
_ -> String -> q DCxt
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Cannot desugar constraint tuples in the body of a quantified constraint"
dsPred (AppT t1 :: Type
t1 t2 :: Type
t2) = do
[p1 :: DType
p1] <- Type -> q DCxt
forall (q :: * -> *). DsMonad q => Type -> q DCxt
dsPred Type
t1
(DType -> DCxt -> DCxt
forall a. a -> [a] -> [a]
:[]) (DType -> DCxt) -> (DType -> DType) -> DType -> DCxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DType -> DType -> DType
DAppT DType
p1 (DType -> DCxt) -> q DType -> q DCxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
t2
dsPred (SigT ty :: Type
ty ki :: Type
ki) = do
DCxt
preds <- Type -> q DCxt
forall (q :: * -> *). DsMonad q => Type -> q DCxt
dsPred Type
ty
case DCxt
preds of
[p :: DType
p] -> (DType -> DCxt -> DCxt
forall a. a -> [a] -> [a]
:[]) (DType -> DCxt) -> (DType -> DType) -> DType -> DCxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DType -> DType -> DType
DSigT DType
p (DType -> DCxt) -> q DType -> q DCxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ki
other :: DCxt
other -> DCxt -> q DCxt
forall (m :: * -> *) a. Monad m => a -> m a
return DCxt
other
dsPred (VarT n :: Name
n) = DCxt -> q DCxt
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> DType
DVarT Name
n]
dsPred (ConT n :: Name
n) = DCxt -> q DCxt
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> DType
DConT Name
n]
dsPred t :: Type
t@(PromotedT _) =
String -> q DCxt
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible (String -> q DCxt) -> String -> q DCxt
forall a b. (a -> b) -> a -> b
$ "Promoted type seen as head of constraint: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t
dsPred (TupleT 0) = DCxt -> q DCxt
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> DType
DConT (Int -> Name
tupleTypeName 0)]
dsPred (TupleT _) =
String -> q DCxt
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "Internal error in th-desugar in detecting tuple constraints."
dsPred t :: Type
t@(UnboxedTupleT _) =
String -> q DCxt
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible (String -> q DCxt) -> String -> q DCxt
forall a b. (a -> b) -> a -> b
$ "Unboxed tuple seen as head of constraint: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t
dsPred ArrowT = String -> q DCxt
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "Arrow seen as head of constraint."
dsPred ListT = String -> q DCxt
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "List seen as head of constraint."
dsPred (PromotedTupleT _) =
String -> q DCxt
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "Promoted tuple seen as head of constraint."
dsPred PromotedNilT = String -> q DCxt
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "Promoted nil seen as head of constraint."
dsPred PromotedConsT = String -> q DCxt
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "Promoted cons seen as head of constraint."
dsPred StarT = String -> q DCxt
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "* seen as head of constraint."
dsPred ConstraintT =
String -> q DCxt
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "The kind `Constraint' seen as head of constraint."
dsPred t :: Type
t@(LitT _) =
String -> q DCxt
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible (String -> q DCxt) -> String -> q DCxt
forall a b. (a -> b) -> a -> b
$ "Type literal seen as head of constraint: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t
dsPred EqualityT = DCxt -> q DCxt
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> DType
DConT ''(~)]
#if __GLASGOW_HASKELL__ > 710
dsPred (InfixT t1 :: Type
t1 n :: Name
n t2 :: Type
t2) = (DType -> DCxt -> DCxt
forall a. a -> [a] -> [a]
:[]) (DType -> DCxt) -> q DType -> q DCxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DType -> DType -> DType
DAppT (DType -> DType -> DType) -> q DType -> q (DType -> DType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DType -> DType -> DType
DAppT (Name -> DType
DConT Name
n) (DType -> DType) -> q DType -> q DType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
t1) q (DType -> DType) -> q DType -> q DType
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
t2)
dsPred (UInfixT _ _ _) = String -> q DCxt
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Cannot desugar unresolved infix operators."
dsPred (ParensT t :: Type
t) = Type -> q DCxt
forall (q :: * -> *). DsMonad q => Type -> q DCxt
dsPred Type
t
dsPred WildCardT = DCxt -> q DCxt
forall (m :: * -> *) a. Monad m => a -> m a
return [DType
DWildCardT]
#endif
#if __GLASGOW_HASKELL__ >= 801
dsPred t :: Type
t@(UnboxedSumT {}) =
String -> q DCxt
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible (String -> q DCxt) -> String -> q DCxt
forall a b. (a -> b) -> a -> b
$ "Unboxed sum seen as head of constraint: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t
#endif
#if __GLASGOW_HASKELL__ >= 807
dsPred (AppKindT t :: Type
t k :: Type
k) = do
[p :: DType
p] <- Type -> q DCxt
forall (q :: * -> *). DsMonad q => Type -> q DCxt
dsPred Type
t
(DType -> DCxt -> DCxt
forall a. a -> [a] -> [a]
:[]) (DType -> DCxt) -> q DType -> q DCxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DType -> DType -> DType
DAppKindT DType
p (DType -> DType) -> q DType -> q DType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
k)
dsPred (ImplicitParamT n :: String
n t :: Type
t) = do
DType
t' <- Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
t
DCxt -> q DCxt
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> DType
DConT ''IP DType -> DType -> DType
`DAppT` TyLit -> DType
DLitT (String -> TyLit
StrTyLit String
n) DType -> DType -> DType
`DAppT` DType
t']
#endif
#endif
dsReify :: DsMonad q => Name -> q (Maybe DInfo)
dsReify :: Name -> q (Maybe DInfo)
dsReify = (Info -> q DInfo) -> Maybe Info -> q (Maybe DInfo)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Info -> q DInfo
forall (q :: * -> *). DsMonad q => Info -> q DInfo
dsInfo (Maybe Info -> q (Maybe DInfo))
-> (Name -> q (Maybe Info)) -> Name -> q (Maybe DInfo)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Name -> q (Maybe Info)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe Info)
reifyWithLocals_maybe
reorderFields :: DsMonad q => Name -> [VarStrictType] -> [FieldExp] -> [DExp] -> q [DExp]
reorderFields :: Name -> [VarBangType] -> [FieldExp] -> [DExp] -> q [DExp]
reorderFields = (Exp -> q DExp)
-> Name -> [VarBangType] -> [FieldExp] -> [DExp] -> q [DExp]
forall (m :: * -> *) a da.
(Applicative m, MonadFail m) =>
(a -> m da)
-> Name -> [VarBangType] -> [(Name, a)] -> [da] -> m [da]
reorderFields' Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp
reorderFieldsPat :: DsMonad q => Name -> [VarStrictType] -> [FieldPat] -> PatM q [DPat]
reorderFieldsPat :: Name -> [VarBangType] -> [FieldPat] -> PatM q [DPat]
reorderFieldsPat con_name :: Name
con_name field_decs :: [VarBangType]
field_decs field_pats :: [FieldPat]
field_pats =
(Pat -> WriterT [(Name, DExp)] q DPat)
-> Name -> [VarBangType] -> [FieldPat] -> [DPat] -> PatM q [DPat]
forall (m :: * -> *) a da.
(Applicative m, MonadFail m) =>
(a -> m da)
-> Name -> [VarBangType] -> [(Name, a)] -> [da] -> m [da]
reorderFields' Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Name
con_name [VarBangType]
field_decs [FieldPat]
field_pats (DPat -> [DPat]
forall a. a -> [a]
repeat DPat
DWildP)
reorderFields' :: (Applicative m, Fail.MonadFail m)
=> (a -> m da)
-> Name
-> [VarStrictType] -> [(Name, a)]
-> [da] -> m [da]
reorderFields' :: (a -> m da)
-> Name -> [VarBangType] -> [(Name, a)] -> [da] -> m [da]
reorderFields' ds_thing :: a -> m da
ds_thing con_name :: Name
con_name field_names_types :: [VarBangType]
field_names_types field_things :: [(Name, a)]
field_things deflts :: [da]
deflts =
m ()
check_valid_fields m () -> m [da] -> m [da]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Name] -> [da] -> m [da]
reorder [Name]
field_names [da]
deflts
where
field_names :: [Name]
field_names = (VarBangType -> Name) -> [VarBangType] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\(a :: Name
a, _, _) -> Name
a) [VarBangType]
field_names_types
check_valid_fields :: m ()
check_valid_fields =
[(Name, a)] -> ((Name, a) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Name, a)]
field_things (((Name, a) -> m ()) -> m ()) -> ((Name, a) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(thing_name :: Name
thing_name, _) ->
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Name
thing_name Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
field_names) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
String -> m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ "Constructor ‘" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
con_name String -> String -> String
forall a. [a] -> [a] -> [a]
++ "‘ does not have field ‘"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
thing_name String -> String -> String
forall a. [a] -> [a] -> [a]
++ "‘"
reorder :: [Name] -> [da] -> m [da]
reorder [] _ = [da] -> m [da]
forall (m :: * -> *) a. Monad m => a -> m a
return []
reorder (field_name :: Name
field_name : rest :: [Name]
rest) (deflt :: da
deflt : rest_deflt :: [da]
rest_deflt) = do
[da]
rest' <- [Name] -> [da] -> m [da]
reorder [Name]
rest [da]
rest_deflt
case ((Name, a) -> Bool) -> [(Name, a)] -> Maybe (Name, a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(thing_name :: Name
thing_name, _) -> Name
thing_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
field_name) [(Name, a)]
field_things of
Just (_, thing :: a
thing) -> (da -> [da] -> [da]
forall a. a -> [a] -> [a]
: [da]
rest') (da -> [da]) -> m da -> m [da]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m da
ds_thing a
thing
Nothing -> [da] -> m [da]
forall (m :: * -> *) a. Monad m => a -> m a
return ([da] -> m [da]) -> [da] -> m [da]
forall a b. (a -> b) -> a -> b
$ da
deflt da -> [da] -> [da]
forall a. a -> [a] -> [a]
: [da]
rest'
reorder (_ : _) [] = String -> m [da]
forall a. HasCallStack => String -> a
error "Internal error in th-desugar."
mkTupleDExp :: [DExp] -> DExp
mkTupleDExp :: [DExp] -> DExp
mkTupleDExp [exp :: DExp
exp] = DExp
exp
mkTupleDExp exps :: [DExp]
exps = (DExp -> DExp -> DExp) -> DExp -> [DExp] -> DExp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DExp -> DExp -> DExp
DAppE (Name -> DExp
DConE (Name -> DExp) -> Name -> DExp
forall a b. (a -> b) -> a -> b
$ Int -> Name
tupleDataName ([DExp] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
exps)) [DExp]
exps
mkTupleExp :: [Exp] -> Exp
mkTupleExp :: [Exp] -> Exp
mkTupleExp [exp :: Exp
exp] = Exp
exp
mkTupleExp exps :: [Exp]
exps = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
ConE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Name
tupleDataName ([Exp] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp]
exps)) [Exp]
exps
mkTupleDPat :: [DPat] -> DPat
mkTupleDPat :: [DPat] -> DPat
mkTupleDPat [pat :: DPat
pat] = DPat
pat
mkTupleDPat pats :: [DPat]
pats = Name -> [DPat] -> DPat
DConP (Int -> Name
tupleDataName ([DPat] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DPat]
pats)) [DPat]
pats
mkTuplePat :: [Pat] -> Pat
mkTuplePat :: [Pat] -> Pat
mkTuplePat [pat :: Pat
pat] = Pat
pat
mkTuplePat pats :: [Pat]
pats = Name -> [Pat] -> Pat
ConP (Int -> Name
tupleDataName ([Pat] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat]
pats)) [Pat]
pats
isUniversalPattern :: DsMonad q => DPat -> q Bool
isUniversalPattern :: DPat -> q Bool
isUniversalPattern (DLitP {}) = Bool -> q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
isUniversalPattern (DVarP {}) = Bool -> q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
isUniversalPattern (DConP con_name :: Name
con_name pats :: [DPat]
pats) = do
Name
data_name <- Name -> q Name
forall (q :: * -> *). DsMonad q => Name -> q Name
dataConNameToDataName Name
con_name
(_tvbs :: [TyVarBndr]
_tvbs, cons :: [Con]
cons) <- String -> Name -> q ([TyVarBndr], [Con])
forall (q :: * -> *).
DsMonad q =>
String -> Name -> q ([TyVarBndr], [Con])
getDataD "Internal error." Name
data_name
if [Con] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Con]
cons Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1
then ([Bool] -> Bool) -> q [Bool] -> q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and (q [Bool] -> q Bool) -> q [Bool] -> q Bool
forall a b. (a -> b) -> a -> b
$ (DPat -> q Bool) -> [DPat] -> q [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DPat -> q Bool
forall (q :: * -> *). DsMonad q => DPat -> q Bool
isUniversalPattern [DPat]
pats
else Bool -> q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
isUniversalPattern (DTildeP {}) = Bool -> q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
isUniversalPattern (DBangP pat :: DPat
pat) = DPat -> q Bool
forall (q :: * -> *). DsMonad q => DPat -> q Bool
isUniversalPattern DPat
pat
isUniversalPattern (DSigP pat :: DPat
pat _) = DPat -> q Bool
forall (q :: * -> *). DsMonad q => DPat -> q Bool
isUniversalPattern DPat
pat
isUniversalPattern DWildP = Bool -> q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
applyDExp :: DExp -> [DExp] -> DExp
applyDExp :: DExp -> [DExp] -> DExp
applyDExp = (DExp -> DExp -> DExp) -> DExp -> [DExp] -> DExp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DExp -> DExp -> DExp
DAppE
applyDType :: DType -> [DTypeArg] -> DType
applyDType :: DType -> [DTypeArg] -> DType
applyDType = (DType -> DTypeArg -> DType) -> DType -> [DTypeArg] -> DType
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DType -> DTypeArg -> DType
apply
where
apply :: DType -> DTypeArg -> DType
apply :: DType -> DTypeArg -> DType
apply f :: DType
f (DTANormal x :: DType
x) = DType
f DType -> DType -> DType
`DAppT` DType
x
apply f :: DType
f (DTyArg x :: DType
x) = DType
f DType -> DType -> DType
`DAppKindT` DType
x
data DTypeArg
= DTANormal DType
| DTyArg DKind
deriving (DTypeArg -> DTypeArg -> Bool
(DTypeArg -> DTypeArg -> Bool)
-> (DTypeArg -> DTypeArg -> Bool) -> Eq DTypeArg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DTypeArg -> DTypeArg -> Bool
$c/= :: DTypeArg -> DTypeArg -> Bool
== :: DTypeArg -> DTypeArg -> Bool
$c== :: DTypeArg -> DTypeArg -> Bool
Eq, Int -> DTypeArg -> String -> String
[DTypeArg] -> String -> String
DTypeArg -> String
(Int -> DTypeArg -> String -> String)
-> (DTypeArg -> String)
-> ([DTypeArg] -> String -> String)
-> Show DTypeArg
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [DTypeArg] -> String -> String
$cshowList :: [DTypeArg] -> String -> String
show :: DTypeArg -> String
$cshow :: DTypeArg -> String
showsPrec :: Int -> DTypeArg -> String -> String
$cshowsPrec :: Int -> DTypeArg -> String -> String
Show, Typeable, Typeable DTypeArg
DataType
Constr
Typeable DTypeArg =>
(forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DTypeArg -> c DTypeArg)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DTypeArg)
-> (DTypeArg -> Constr)
-> (DTypeArg -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DTypeArg))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DTypeArg))
-> ((forall b. Data b => b -> b) -> DTypeArg -> DTypeArg)
-> (forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DTypeArg -> r)
-> (forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DTypeArg -> r)
-> (forall u. (forall d. Data d => d -> u) -> DTypeArg -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> DTypeArg -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg)
-> Data DTypeArg
DTypeArg -> DataType
DTypeArg -> Constr
(forall b. Data b => b -> b) -> DTypeArg -> DTypeArg
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DTypeArg -> c DTypeArg
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DTypeArg
forall a.
Typeable a =>
(forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> DTypeArg -> u
forall u. (forall d. Data d => d -> u) -> DTypeArg -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DTypeArg -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DTypeArg -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DTypeArg
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DTypeArg -> c DTypeArg
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DTypeArg)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DTypeArg)
$cDTyArg :: Constr
$cDTANormal :: Constr
$tDTypeArg :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg
gmapMp :: (forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg
gmapM :: (forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg
gmapQi :: Int -> (forall d. Data d => d -> u) -> DTypeArg -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DTypeArg -> u
gmapQ :: (forall d. Data d => d -> u) -> DTypeArg -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DTypeArg -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DTypeArg -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DTypeArg -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DTypeArg -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DTypeArg -> r
gmapT :: (forall b. Data b => b -> b) -> DTypeArg -> DTypeArg
$cgmapT :: (forall b. Data b => b -> b) -> DTypeArg -> DTypeArg
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DTypeArg)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DTypeArg)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c DTypeArg)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DTypeArg)
dataTypeOf :: DTypeArg -> DataType
$cdataTypeOf :: DTypeArg -> DataType
toConstr :: DTypeArg -> Constr
$ctoConstr :: DTypeArg -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DTypeArg
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DTypeArg
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DTypeArg -> c DTypeArg
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DTypeArg -> c DTypeArg
$cp1Data :: Typeable DTypeArg
Data, (forall x. DTypeArg -> Rep DTypeArg x)
-> (forall x. Rep DTypeArg x -> DTypeArg) -> Generic DTypeArg
forall x. Rep DTypeArg x -> DTypeArg
forall x. DTypeArg -> Rep DTypeArg x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DTypeArg x -> DTypeArg
$cfrom :: forall x. DTypeArg -> Rep DTypeArg x
Generic)
dsTypeArg :: DsMonad q => TypeArg -> q DTypeArg
dsTypeArg :: TypeArg -> q DTypeArg
dsTypeArg (TANormal t :: Type
t) = DType -> DTypeArg
DTANormal (DType -> DTypeArg) -> q DType -> q DTypeArg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
t
dsTypeArg (TyArg k :: Type
k) = DType -> DTypeArg
DTyArg (DType -> DTypeArg) -> q DType -> q DTypeArg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
k
filterDTANormals :: [DTypeArg] -> [DType]
filterDTANormals :: [DTypeArg] -> DCxt
filterDTANormals = (DTypeArg -> Maybe DType) -> [DTypeArg] -> DCxt
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DTypeArg -> Maybe DType
getDTANormal
where
getDTANormal :: DTypeArg -> Maybe DType
getDTANormal :: DTypeArg -> Maybe DType
getDTANormal (DTANormal t :: DType
t) = DType -> Maybe DType
forall a. a -> Maybe a
Just DType
t
getDTANormal (DTyArg {}) = Maybe DType
forall a. Maybe a
Nothing
dTyVarBndrToDType :: DTyVarBndr -> DType
dTyVarBndrToDType :: DTyVarBndr -> DType
dTyVarBndrToDType (DPlainTV a :: Name
a) = Name -> DType
DVarT Name
a
dTyVarBndrToDType (DKindedTV a :: Name
a k :: DType
k) = Name -> DType
DVarT Name
a DType -> DType -> DType
`DSigT` DType
k
probablyWrongUnDTypeArg :: DTypeArg -> DType
probablyWrongUnDTypeArg :: DTypeArg -> DType
probablyWrongUnDTypeArg (DTANormal t :: DType
t) = DType
t
probablyWrongUnDTypeArg (DTyArg k :: DType
k) = DType
k
#if __GLASGOW_HASKELL__ <= 710
strictToBang :: Strict -> Bang
strictToBang IsStrict = Bang NoSourceUnpackedness SourceStrict
strictToBang NotStrict = Bang NoSourceUnpackedness NoSourceStrictness
strictToBang Unpacked = Bang SourceUnpack SourceStrict
#else
strictToBang :: Bang -> Bang
strictToBang :: Bang -> Bang
strictToBang = Bang -> Bang
forall a. a -> a
id
#endif
nonFamilyDataReturnType :: Name -> [DTyVarBndr] -> DType
nonFamilyDataReturnType :: Name -> [DTyVarBndr] -> DType
nonFamilyDataReturnType con_name :: Name
con_name =
DType -> [DTypeArg] -> DType
applyDType (Name -> DType
DConT Name
con_name) ([DTypeArg] -> DType)
-> ([DTyVarBndr] -> [DTypeArg]) -> [DTyVarBndr] -> DType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DTyVarBndr -> DTypeArg) -> [DTyVarBndr] -> [DTypeArg]
forall a b. (a -> b) -> [a] -> [b]
map (DType -> DTypeArg
DTANormal (DType -> DTypeArg)
-> (DTyVarBndr -> DType) -> DTyVarBndr -> DTypeArg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DTyVarBndr -> DType
dTyVarBndrToDType)
dataFamInstReturnType :: Name -> [DTypeArg] -> DType
dataFamInstReturnType :: Name -> [DTypeArg] -> DType
dataFamInstReturnType fam_name :: Name
fam_name = DType -> [DTypeArg] -> DType
applyDType (Name -> DType
DConT Name
fam_name)
dataFamInstTvbs :: [DTypeArg] -> [DTyVarBndr]
dataFamInstTvbs :: [DTypeArg] -> [DTyVarBndr]
dataFamInstTvbs = DCxt -> [DTyVarBndr]
toposortTyVarsOf (DCxt -> [DTyVarBndr])
-> ([DTypeArg] -> DCxt) -> [DTypeArg] -> [DTyVarBndr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DTypeArg -> DType) -> [DTypeArg] -> DCxt
forall a b. (a -> b) -> [a] -> [b]
map DTypeArg -> DType
probablyWrongUnDTypeArg
toposortTyVarsOf :: [DType] -> [DTyVarBndr]
toposortTyVarsOf :: DCxt -> [DTyVarBndr]
toposortTyVarsOf tys :: DCxt
tys =
let freeVars :: [Name]
freeVars :: [Name]
freeVars = OSet Name -> [Name]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (OSet Name -> [Name]) -> OSet Name -> [Name]
forall a b. (a -> b) -> a -> b
$ (DType -> OSet Name) -> DCxt -> OSet Name
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap DType -> OSet Name
fvDType DCxt
tys
varKindSigs :: Map Name DKind
varKindSigs :: Map Name DType
varKindSigs = (DType -> Map Name DType) -> DCxt -> Map Name DType
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap DType -> Map Name DType
go_ty DCxt
tys
where
go_ty :: DType -> Map Name DKind
go_ty :: DType -> Map Name DType
go_ty (DForallT tvbs :: [DTyVarBndr]
tvbs ctxt :: DCxt
ctxt t :: DType
t) =
[DTyVarBndr] -> Map Name DType -> Map Name DType
go_tvbs [DTyVarBndr]
tvbs ((DType -> Map Name DType) -> DCxt -> Map Name DType
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap DType -> Map Name DType
go_ty DCxt
ctxt Map Name DType -> Map Name DType -> Map Name DType
forall a. Monoid a => a -> a -> a
`mappend` DType -> Map Name DType
go_ty DType
t)
go_ty (DAppT t1 :: DType
t1 t2 :: DType
t2) = DType -> Map Name DType
go_ty DType
t1 Map Name DType -> Map Name DType -> Map Name DType
forall a. Monoid a => a -> a -> a
`mappend` DType -> Map Name DType
go_ty DType
t2
go_ty (DAppKindT t :: DType
t k :: DType
k) = DType -> Map Name DType
go_ty DType
t Map Name DType -> Map Name DType -> Map Name DType
forall a. Monoid a => a -> a -> a
`mappend` DType -> Map Name DType
go_ty DType
k
go_ty (DSigT t :: DType
t k :: DType
k) =
let kSigs :: Map Name DType
kSigs = DType -> Map Name DType
go_ty DType
k
in case DType
t of
DVarT n :: Name
n -> Name -> DType -> Map Name DType -> Map Name DType
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
n DType
k Map Name DType
kSigs
_ -> DType -> Map Name DType
go_ty DType
t Map Name DType -> Map Name DType -> Map Name DType
forall a. Monoid a => a -> a -> a
`mappend` Map Name DType
kSigs
go_ty (DVarT {}) = Map Name DType
forall a. Monoid a => a
mempty
go_ty (DConT {}) = Map Name DType
forall a. Monoid a => a
mempty
go_ty DArrowT = Map Name DType
forall a. Monoid a => a
mempty
go_ty (DLitT {}) = Map Name DType
forall a. Monoid a => a
mempty
go_ty DWildCardT = Map Name DType
forall a. Monoid a => a
mempty
go_tvbs :: [DTyVarBndr] -> Map Name DKind -> Map Name DKind
go_tvbs :: [DTyVarBndr] -> Map Name DType -> Map Name DType
go_tvbs tvbs :: [DTyVarBndr]
tvbs m :: Map Name DType
m = (DTyVarBndr -> Map Name DType -> Map Name DType)
-> Map Name DType -> [DTyVarBndr] -> Map Name DType
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DTyVarBndr -> Map Name DType -> Map Name DType
go_tvb Map Name DType
m [DTyVarBndr]
tvbs
go_tvb :: DTyVarBndr -> Map Name DKind -> Map Name DKind
go_tvb :: DTyVarBndr -> Map Name DType -> Map Name DType
go_tvb (DPlainTV n :: Name
n) m :: Map Name DType
m = Name -> Map Name DType -> Map Name DType
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Name
n Map Name DType
m
go_tvb (DKindedTV n :: Name
n k :: DType
k) m :: Map Name DType
m = Name -> Map Name DType -> Map Name DType
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Name
n Map Name DType
m Map Name DType -> Map Name DType -> Map Name DType
forall a. Monoid a => a -> a -> a
`mappend` DType -> Map Name DType
go_ty DType
k
scopedSort :: [Name] -> [Name]
scopedSort :: [Name] -> [Name]
scopedSort = [Name] -> [Set Name] -> [Name] -> [Name]
go [] []
go :: [Name]
-> [Set Name]
-> [Name]
-> [Name]
go :: [Name] -> [Set Name] -> [Name] -> [Name]
go acc :: [Name]
acc _fv_list :: [Set Name]
_fv_list [] = [Name] -> [Name]
forall a. [a] -> [a]
reverse [Name]
acc
go acc :: [Name]
acc fv_list :: [Set Name]
fv_list (tv :: Name
tv:tvs :: [Name]
tvs)
= [Name] -> [Set Name] -> [Name] -> [Name]
go [Name]
acc' [Set Name]
fv_list' [Name]
tvs
where
(acc' :: [Name]
acc', fv_list' :: [Set Name]
fv_list') = Name -> [Name] -> [Set Name] -> ([Name], [Set Name])
insert Name
tv [Name]
acc [Set Name]
fv_list
insert :: Name
-> [Name]
-> [Set Name]
-> ([Name], [Set Name])
insert :: Name -> [Name] -> [Set Name] -> ([Name], [Set Name])
insert tv :: Name
tv [] [] = ([Name
tv], [Name -> Set Name
kindFVSet Name
tv])
insert tv :: Name
tv (a :: Name
a:as :: [Name]
as) (fvs :: Set Name
fvs:fvss :: [Set Name]
fvss)
| Name
tv Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Name
fvs
, (as' :: [Name]
as', fvss' :: [Set Name]
fvss') <- Name -> [Name] -> [Set Name] -> ([Name], [Set Name])
insert Name
tv [Name]
as [Set Name]
fvss
= (Name
aName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
as', Set Name
fvs Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Set Name
fv_tv Set Name -> [Set Name] -> [Set Name]
forall a. a -> [a] -> [a]
: [Set Name]
fvss')
| Bool
otherwise
= (Name
tvName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:Name
aName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
as, Set Name
fvs Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Set Name
fv_tv Set Name -> [Set Name] -> [Set Name]
forall a. a -> [a] -> [a]
: Set Name
fvs Set Name -> [Set Name] -> [Set Name]
forall a. a -> [a] -> [a]
: [Set Name]
fvss)
where
fv_tv :: Set Name
fv_tv = Name -> Set Name
kindFVSet Name
tv
insert _ _ _ = String -> ([Name], [Set Name])
forall a. HasCallStack => String -> a
error "scopedSort"
kindFVSet :: Name -> Set Name
kindFVSet n :: Name
n =
Set Name -> (DType -> Set Name) -> Maybe DType -> Set Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set Name
forall a. Set a
S.empty (OSet Name -> Set Name
forall a. OSet a -> Set a
OS.toSet (OSet Name -> Set Name)
-> (DType -> OSet Name) -> DType -> Set Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DType -> OSet Name
fvDType)
(Name -> Map Name DType -> Maybe DType
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
n Map Name DType
varKindSigs)
ascribeWithKind :: Name -> DTyVarBndr
ascribeWithKind n :: Name
n =
DTyVarBndr -> (DType -> DTyVarBndr) -> Maybe DType -> DTyVarBndr
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> DTyVarBndr
DPlainTV Name
n) (Name -> DType -> DTyVarBndr
DKindedTV Name
n) (Name -> Map Name DType -> Maybe DType
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
n Map Name DType
varKindSigs)
isKindBinderOnOldGHCs :: b -> Bool
isKindBinderOnOldGHCs
#if __GLASGOW_HASKELL__ >= 800
= Bool -> b -> Bool
forall a b. a -> b -> a
const Bool
False
#else
= (`elem` kindVars)
where
kindVars = foldMap fvDType $ M.elems varKindSigs
#endif
in (Name -> DTyVarBndr) -> [Name] -> [DTyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DTyVarBndr
ascribeWithKind ([Name] -> [DTyVarBndr]) -> [Name] -> [DTyVarBndr]
forall a b. (a -> b) -> a -> b
$
(Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Name -> Bool) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Bool
forall b. b -> Bool
isKindBinderOnOldGHCs) ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$
[Name] -> [Name]
scopedSort [Name]
freeVars
dtvbName :: DTyVarBndr -> Name
dtvbName :: DTyVarBndr -> Name
dtvbName (DPlainTV n :: Name
n) = Name
n
dtvbName (DKindedTV n :: Name
n _) = Name
n
unravel :: DType -> ([DTyVarBndr], [DPred], [DType], DType)
unravel :: DType -> ([DTyVarBndr], DCxt, DCxt, DType)
unravel (DForallT tvbs :: [DTyVarBndr]
tvbs cxt :: DCxt
cxt ty :: DType
ty) =
let (tvbs' :: [DTyVarBndr]
tvbs', cxt' :: DCxt
cxt', tys :: DCxt
tys, res :: DType
res) = DType -> ([DTyVarBndr], DCxt, DCxt, DType)
unravel DType
ty in
([DTyVarBndr]
tvbs [DTyVarBndr] -> [DTyVarBndr] -> [DTyVarBndr]
forall a. [a] -> [a] -> [a]
++ [DTyVarBndr]
tvbs', DCxt
cxt DCxt -> DCxt -> DCxt
forall a. [a] -> [a] -> [a]
++ DCxt
cxt', DCxt
tys, DType
res)
unravel (DAppT (DAppT DArrowT t1 :: DType
t1) t2 :: DType
t2) =
let (tvbs :: [DTyVarBndr]
tvbs, cxt :: DCxt
cxt, tys :: DCxt
tys, res :: DType
res) = DType -> ([DTyVarBndr], DCxt, DCxt, DType)
unravel DType
t2 in
([DTyVarBndr]
tvbs, DCxt
cxt, DType
t1 DType -> DCxt -> DCxt
forall a. a -> [a] -> [a]
: DCxt
tys, DType
res)
unravel t :: DType
t = ([], [], [], DType
t)
unfoldDType :: DType -> (DType, [DTypeArg])
unfoldDType :: DType -> (DType, [DTypeArg])
unfoldDType = [DTypeArg] -> DType -> (DType, [DTypeArg])
go []
where
go :: [DTypeArg] -> DType -> (DType, [DTypeArg])
go :: [DTypeArg] -> DType -> (DType, [DTypeArg])
go acc :: [DTypeArg]
acc (DForallT _ _ ty :: DType
ty) = [DTypeArg] -> DType -> (DType, [DTypeArg])
go [DTypeArg]
acc DType
ty
go acc :: [DTypeArg]
acc (DAppT ty1 :: DType
ty1 ty2 :: DType
ty2) = [DTypeArg] -> DType -> (DType, [DTypeArg])
go (DType -> DTypeArg
DTANormal DType
ty2DTypeArg -> [DTypeArg] -> [DTypeArg]
forall a. a -> [a] -> [a]
:[DTypeArg]
acc) DType
ty1
go acc :: [DTypeArg]
acc (DAppKindT ty :: DType
ty ki :: DType
ki) = [DTypeArg] -> DType -> (DType, [DTypeArg])
go (DType -> DTypeArg
DTyArg DType
kiDTypeArg -> [DTypeArg] -> [DTypeArg]
forall a. a -> [a] -> [a]
:[DTypeArg]
acc) DType
ty
go acc :: [DTypeArg]
acc (DSigT ty :: DType
ty _) = [DTypeArg] -> DType -> (DType, [DTypeArg])
go [DTypeArg]
acc DType
ty
go acc :: [DTypeArg]
acc ty :: DType
ty = (DType
ty, [DTypeArg]
acc)
extractTvbKind :: DTyVarBndr -> Maybe DKind
(DPlainTV _) = Maybe DType
forall a. Maybe a
Nothing
extractTvbKind (DKindedTV _ k :: DType
k) = DType -> Maybe DType
forall a. a -> Maybe a
Just DType
k
unusedArgument :: a
unusedArgument :: a
unusedArgument = String -> a
forall a. HasCallStack => String -> a
error "Unused"