module Data.Ix.Deriving.Internal (
deriveIx
, makeRange
, makeUnsafeIndex
, makeInRange
) where
import Data.Deriving.Internal
import Language.Haskell.TH.Datatype
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax
deriveIx :: Name -> Q [Dec]
deriveIx :: Name -> Q [Dec]
deriveIx Name
name = do
DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
case DatatypeInfo
info of
DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
datatypeContext = Cxt
ctxt
, datatypeName :: DatatypeInfo -> Name
datatypeName = Name
parentName
, datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
instTypes
, datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant = DatatypeVariant
variant
, datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons
} -> do
(Cxt
instanceCxt, Type
instanceType)
<- IxClass -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance IxClass
IxClass Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant
(Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD (Cxt -> CxtQ
forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
instanceCxt)
(Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
instanceType)
(Name -> Type -> [ConstructorInfo] -> [Q Dec]
ixFunDecs Name
parentName Type
instanceType [ConstructorInfo]
cons)
makeRange :: Name -> Q Exp
makeRange :: Name -> Q Exp
makeRange = IxFun -> Name -> Q Exp
makeIxFun IxFun
Range
makeUnsafeIndex :: Name -> Q Exp
makeUnsafeIndex :: Name -> Q Exp
makeUnsafeIndex = IxFun -> Name -> Q Exp
makeIxFun IxFun
UnsafeIndex
makeInRange :: Name -> Q Exp
makeInRange :: Name -> Q Exp
makeInRange = IxFun -> Name -> Q Exp
makeIxFun IxFun
InRange
ixFunDecs :: Name -> Type -> [ConstructorInfo] -> [Q Dec]
ixFunDecs :: Name -> Type -> [ConstructorInfo] -> [Q Dec]
ixFunDecs Name
tyName Type
ty [ConstructorInfo]
cons =
[ IxFun -> Q Dec
makeFunD IxFun
Range
, IxFun -> Q Dec
makeFunD IxFun
UnsafeIndex
, IxFun -> Q Dec
makeFunD IxFun
InRange
]
where
makeFunD :: IxFun -> Q Dec
makeFunD :: IxFun -> Q Dec
makeFunD IxFun
ixf =
Name -> [ClauseQ] -> Q Dec
funD (IxFun -> Name
ixFunName IxFun
ixf)
[ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
(Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ IxFun -> Name -> Type -> [ConstructorInfo] -> Q Exp
makeIxFunForCons IxFun
ixf Name
tyName Type
ty [ConstructorInfo]
cons)
[]
]
makeIxFun :: IxFun -> Name -> Q Exp
makeIxFun :: IxFun -> Name -> Q Exp
makeIxFun IxFun
ixf Name
name = do
DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
case DatatypeInfo
info of
DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
datatypeContext = Cxt
ctxt
, datatypeName :: DatatypeInfo -> Name
datatypeName = Name
parentName
, datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
instTypes
, datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant = DatatypeVariant
variant
, datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons
} -> do
(Cxt
_, Type
instanceType) <- IxClass -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance IxClass
IxClass Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant
IxFun -> Name -> Type -> [ConstructorInfo] -> Q Exp
makeIxFunForCons IxFun
ixf Name
parentName Type
instanceType [ConstructorInfo]
cons
makeIxFunForCons :: IxFun -> Name -> Type -> [ConstructorInfo] -> Q Exp
makeIxFunForCons :: IxFun -> Name -> Type -> [ConstructorInfo] -> Q Exp
makeIxFunForCons IxFun
_ Name
_ Type
_ [] = Q Exp
forall a. Q a
noConstructorsError
makeIxFunForCons IxFun
ixf Name
tyName Type
ty [ConstructorInfo]
cons
| Bool -> Bool
not (Bool
isProduct Bool -> Bool -> Bool
|| Bool
isEnumeration)
= String -> Q Exp
forall a. String -> Q a
enumerationOrProductError (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
tyName
| Bool
isEnumeration
= case IxFun
ixf of
IxFun
Range -> do
Name
a <- String -> Q Name
newName String
"a"
Name
aHash <- String -> Q Name
newName String
"a#"
Name
b <- String -> Q Name
newName String
"b"
Name
bHash <- String -> Q Name
newName String
"b#"
[PatQ] -> Q Exp -> Q Exp
lamE [[PatQ] -> PatQ
tupP [Name -> PatQ
varP Name
a, Name -> PatQ
varP Name
b]] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
[(Name, Name)] -> Q Exp -> Q Exp
untagExpr [(Name
a, Name
aHash)] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
[(Name, Name)] -> Q Exp -> Q Exp
untagExpr [(Name
b, Name
bHash)] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE Name
mapValName Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
tag2Con) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
Q Exp -> Q Exp -> Q Exp
enumFromToExpr (Name -> Q Exp
conE Name
iHashDataName Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
aHash)
(Name -> Q Exp
conE Name
iHashDataName Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
bHash)
IxFun
UnsafeIndex -> do
Name
a <- String -> Q Name
newName String
"a"
Name
aHash <- String -> Q Name
newName String
"a#"
Name
c <- String -> Q Name
newName String
"c"
Name
cHash <- String -> Q Name
newName String
"c#"
Name
dHash <- String -> Q Name
newName String
"d#"
[PatQ] -> Q Exp -> Q Exp
lamE [[PatQ] -> PatQ
tupP [Name -> PatQ
varP Name
a, PatQ
wildP], Name -> PatQ
varP Name
c] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
[(Name, Name)] -> Q Exp -> Q Exp
untagExpr [(Name
a, Name
aHash)] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
[(Name, Name)] -> Q Exp -> Q Exp
untagExpr [(Name
c, Name
cHash)] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
Q Exp -> [MatchQ] -> Q Exp
caseE (Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
varE Name
cHash) (Name -> Q Exp
varE Name
minusIntHashValName) (Name -> Q Exp
varE Name
aHash))
[ PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (Name -> PatQ
varP Name
dHash)
(Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
conE Name
iHashDataName Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
dHash)
[]
]
IxFun
InRange -> do
Name
a <- String -> Q Name
newName String
"a"
Name
aHash <- String -> Q Name
newName String
"a#"
Name
b <- String -> Q Name
newName String
"b"
Name
bHash <- String -> Q Name
newName String
"b#"
Name
c <- String -> Q Name
newName String
"c"
Name
cHash <- String -> Q Name
newName String
"c#"
[PatQ] -> Q Exp -> Q Exp
lamE [[PatQ] -> PatQ
tupP [Name -> PatQ
varP Name
a, Name -> PatQ
varP Name
b], Name -> PatQ
varP Name
c] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
[(Name, Name)] -> Q Exp -> Q Exp
untagExpr [(Name
a, Name
aHash)] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
[(Name, Name)] -> Q Exp -> Q Exp
untagExpr [(Name
b, Name
bHash)] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
[(Name, Name)] -> Q Exp -> Q Exp
untagExpr [(Name
c, Name
cHash)] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
[Q Exp] -> Q Exp
appsE [ Name -> Q Exp
varE Name
andValName
, Q Exp -> Name -> Q Exp -> Q Exp
primOpAppExpr (Name -> Q Exp
varE Name
cHash) Name
geIntHashValName (Name -> Q Exp
varE Name
aHash)
, Q Exp -> Name -> Q Exp -> Q Exp
primOpAppExpr (Name -> Q Exp
varE Name
cHash) Name
leIntHashValName (Name -> Q Exp
varE Name
bHash)
]
| Bool
otherwise
= do let con :: ConstructorInfo
con :: ConstructorInfo
con = [ConstructorInfo] -> ConstructorInfo
forall a. [a] -> a
head [ConstructorInfo]
cons
conName :: Name
conName :: Name
conName = ConstructorInfo -> Name
constructorName ConstructorInfo
con
conFields :: Int
conFields :: Int
conFields = ConstructorInfo -> Int
conArity ConstructorInfo
con
[Name]
as <- String -> Int -> Q [Name]
newNameList String
"a" Int
conFields
[Name]
bs <- String -> Int -> Q [Name]
newNameList String
"b" Int
conFields
[Name]
cs <- String -> Int -> Q [Name]
newNameList String
"c" Int
conFields
let conPat :: [Name] -> Q Pat
conPat :: [Name] -> PatQ
conPat = Name -> [PatQ] -> PatQ
conP Name
conName ([PatQ] -> PatQ) -> ([Name] -> [PatQ]) -> [Name] -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP
conExpr :: Q Exp
conExpr :: Q Exp
conExpr = [Q Exp] -> Q Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
conE Name
conName Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
varE [Name]
cs
case IxFun
ixf of
IxFun
Range -> [PatQ] -> Q Exp -> Q Exp
lamE [[PatQ] -> PatQ
tupP [[Name] -> PatQ
conPat [Name]
as, [Name] -> PatQ
conPat [Name]
bs]] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
[StmtQ] -> Q Exp
compE ([StmtQ] -> Q Exp) -> [StmtQ] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [StmtQ]
stmts [StmtQ] -> [StmtQ] -> [StmtQ]
forall a. [a] -> [a] -> [a]
++ [Q Exp -> StmtQ
noBindS Q Exp
conExpr]
where
stmts :: [Q Stmt]
stmts :: [StmtQ]
stmts = (Name -> Name -> Name -> StmtQ)
-> [Name] -> [Name] -> [Name] -> [StmtQ]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Name -> Name -> Name -> StmtQ
mkQual [Name]
as [Name]
bs [Name]
cs
mkQual :: Name -> Name -> Name -> Q Stmt
mkQual :: Name -> Name -> Name -> StmtQ
mkQual Name
a Name
b Name
c = PatQ -> Q Exp -> StmtQ
bindS (Name -> PatQ
varP Name
c) (Q Exp -> StmtQ) -> Q Exp -> StmtQ
forall a b. (a -> b) -> a -> b
$
Name -> Q Exp
varE Name
rangeValName Q Exp -> Q Exp -> Q Exp
`appE` [Q Exp] -> Q Exp
tupE [Name -> Q Exp
varE Name
a, Name -> Q Exp
varE Name
b]
IxFun
UnsafeIndex -> [PatQ] -> Q Exp -> Q Exp
lamE [[PatQ] -> PatQ
tupP [[Name] -> PatQ
conPat [Name]
as, [Name] -> PatQ
conPat [Name]
bs], [Name] -> PatQ
conPat [Name]
cs] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
[(Name, Name, Name)] -> Q Exp
mkUnsafeIndex ([(Name, Name, Name)] -> Q Exp) -> [(Name, Name, Name)] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [(Name, Name, Name)] -> [(Name, Name, Name)]
forall a. [a] -> [a]
reverse ([(Name, Name, Name)] -> [(Name, Name, Name)])
-> [(Name, Name, Name)] -> [(Name, Name, Name)]
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name] -> [Name] -> [(Name, Name, Name)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Name]
as [Name]
bs [Name]
cs
where
mkUnsafeIndex :: [(Name, Name, Name)] -> Q Exp
mkUnsafeIndex :: [(Name, Name, Name)] -> Q Exp
mkUnsafeIndex [] = Int -> Q Exp
integerE Int
0
mkUnsafeIndex [(Name
l, Name
u, Name
i)] = Name -> Name -> Name -> Q Exp
mkOne Name
l Name
u Name
i
mkUnsafeIndex ((Name
l, Name
u, Name
i):[(Name, Name, Name)]
rest) =
Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Name -> Name -> Q Exp
mkOne Name
l Name
u Name
i)
(Name -> Q Exp
varE Name
plusValName)
(Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp (Name -> Q Exp
varE Name
unsafeRangeSizeValName
Q Exp -> Q Exp -> Q Exp
`appE` [Q Exp] -> Q Exp
tupE [Name -> Q Exp
varE Name
l, Name -> Q Exp
varE Name
u])
(Name -> Q Exp
varE Name
timesValName)
([(Name, Name, Name)] -> Q Exp
mkUnsafeIndex [(Name, Name, Name)]
rest))
mkOne :: Name -> Name -> Name -> Q Exp
mkOne :: Name -> Name -> Name -> Q Exp
mkOne Name
l Name
u Name
i = Name -> Q Exp
varE Name
unsafeIndexValName Q Exp -> Q Exp -> Q Exp
`appE` [Q Exp] -> Q Exp
tupE [Name -> Q Exp
varE Name
l, Name -> Q Exp
varE Name
u]
Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
i
IxFun
InRange -> [PatQ] -> Q Exp -> Q Exp
lamE [[PatQ] -> PatQ
tupP [[Name] -> PatQ
conPat [Name]
as, [Name] -> PatQ
conPat [Name]
bs], [Name] -> PatQ
conPat [Name]
cs] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
if Int
conFields Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
then Name -> Q Exp
conE Name
trueDataName
else (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Q Exp -> Q Exp -> Q Exp
andExpr ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Name -> Name -> Name -> Q Exp)
-> [Name] -> [Name] -> [Name] -> [Q Exp]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Name -> Name -> Name -> Q Exp
mkInRange [Name]
as [Name]
bs [Name]
cs
where
andExpr :: Q Exp -> Q Exp -> Q Exp
andExpr :: Q Exp -> Q Exp -> Q Exp
andExpr Q Exp
a Q Exp
b = Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp Q Exp
a (Name -> Q Exp
varE Name
andValName) Q Exp
b
mkInRange :: Name -> Name -> Name -> Q Exp
mkInRange :: Name -> Name -> Name -> Q Exp
mkInRange Name
a Name
b Name
c = Name -> Q Exp
varE Name
inRangeValName Q Exp -> Q Exp -> Q Exp
`appE` [Q Exp] -> Q Exp
tupE [Name -> Q Exp
varE Name
a, Name -> Q Exp
varE Name
b]
Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
c
where
isProduct, isEnumeration :: Bool
isProduct :: Bool
isProduct = [ConstructorInfo] -> Bool
isProductType [ConstructorInfo]
cons
isEnumeration :: Bool
isEnumeration = [ConstructorInfo] -> Bool
isEnumerationType [ConstructorInfo]
cons
tag2Con :: Q Exp
tag2Con :: Q Exp
tag2Con = Type -> Q Exp
tag2ConExpr (Type -> Q Exp) -> Type -> Q Exp
forall a b. (a -> b) -> a -> b
$ Type -> Type
removeClassApp Type
ty
data IxClass = IxClass
instance ClassRep IxClass where
arity :: IxClass -> Int
arity IxClass
_ = Int
0
allowExQuant :: IxClass -> Bool
allowExQuant IxClass
_ = Bool
True
fullClassName :: IxClass -> Name
fullClassName IxClass
_ = Name
ixTypeName
classConstraint :: IxClass -> Int -> Maybe Name
classConstraint IxClass
_ Int
0 = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
ixTypeName
classConstraint IxClass
_ Int
_ = Maybe Name
forall a. Maybe a
Nothing
data IxFun = Range
| UnsafeIndex
| InRange
deriving Int -> IxFun -> ShowS
[IxFun] -> ShowS
IxFun -> String
(Int -> IxFun -> ShowS)
-> (IxFun -> String) -> ([IxFun] -> ShowS) -> Show IxFun
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IxFun] -> ShowS
$cshowList :: [IxFun] -> ShowS
show :: IxFun -> String
$cshow :: IxFun -> String
showsPrec :: Int -> IxFun -> ShowS
$cshowsPrec :: Int -> IxFun -> ShowS
Show
ixFunName :: IxFun -> Name
ixFunName :: IxFun -> Name
ixFunName IxFun
Range = Name
rangeValName
ixFunName IxFun
UnsafeIndex = Name
unsafeIndexValName
ixFunName IxFun
InRange = Name
inRangeValName