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)
<- forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance IxClass
IxClass Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant
(forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
instanceCxt)
(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 =
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (IxFun -> Name
ixFunName IxFun
ixf)
[ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause []
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB 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) <- 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
_ [] = forall a. Q a
noConstructorsError
makeIxFunForCons IxFun
ixf Name
tyName Type
ty [ConstructorInfo]
cons
| Bool -> Bool
not (Bool
isProduct Bool -> Bool -> Bool
|| Bool
isEnumeration)
= forall a. String -> Q a
enumerationOrProductError forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
tyName
| Bool
isEnumeration
= case IxFun
ixf of
IxFun
Range -> do
Name
a <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
Name
aHash <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"a#"
Name
b <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"b"
Name
bHash <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"b#"
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
a, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
b]] forall a b. (a -> b) -> a -> b
$
[(Name, Name)] -> Q Exp -> Q Exp
untagExpr [(Name
a, Name
aHash)] forall a b. (a -> b) -> a -> b
$
[(Name, Name)] -> Q Exp -> Q Exp
untagExpr [(Name
b, Name
bHash)] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
mapValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
tag2Con) forall a b. (a -> b) -> a -> b
$
Q Exp -> Q Exp -> Q Exp
enumFromToExpr (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
iHashDataName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
aHash)
(forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
iHashDataName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
bHash)
IxFun
UnsafeIndex -> do
Name
a <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
Name
aHash <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"a#"
Name
c <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"c"
Name
cHash <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"c#"
Name
dHash <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"d#"
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
a, forall (m :: * -> *). Quote m => m Pat
wildP], forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
c] forall a b. (a -> b) -> a -> b
$
[(Name, Name)] -> Q Exp -> Q Exp
untagExpr [(Name
a, Name
aHash)] forall a b. (a -> b) -> a -> b
$
[(Name, Name)] -> Q Exp -> Q Exp
untagExpr [(Name
c, Name
cHash)] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
cHash) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
minusIntHashValName) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
aHash))
[ forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
dHash)
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
iHashDataName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
dHash)
[]
]
IxFun
InRange -> do
Name
a <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
Name
aHash <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"a#"
Name
b <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"b"
Name
bHash <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"b#"
Name
c <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"c"
Name
cHash <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"c#"
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
a, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
b], forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
c] forall a b. (a -> b) -> a -> b
$
[(Name, Name)] -> Q Exp -> Q Exp
untagExpr [(Name
a, Name
aHash)] forall a b. (a -> b) -> a -> b
$
[(Name, Name)] -> Q Exp -> Q Exp
untagExpr [(Name
b, Name
bHash)] forall a b. (a -> b) -> a -> b
$
[(Name, Name)] -> Q Exp -> Q Exp
untagExpr [(Name
c, Name
cHash)] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [ forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
andValName
, Q Exp -> Name -> Q Exp -> Q Exp
primOpAppExpr (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
cHash) Name
geIntHashValName (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
aHash)
, Q Exp -> Name -> Q Exp -> Q Exp
primOpAppExpr (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
cHash) Name
leIntHashValName (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
bHash)
]
| Bool
otherwise
= do let con :: ConstructorInfo
con :: ConstructorInfo
con = 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] -> Q Pat
conPat = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP
conExpr :: Q Exp
conExpr :: Q Exp
conExpr = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
cs
case IxFun
ixf of
IxFun
Range -> forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [[Name] -> Q Pat
conPat [Name]
as, [Name] -> Q Pat
conPat [Name]
bs]] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). Quote m => [m Stmt] -> m Exp
compE forall a b. (a -> b) -> a -> b
$ [Q Stmt]
stmts forall a. [a] -> [a] -> [a]
++ [forall (m :: * -> *). Quote m => m Exp -> m Stmt
noBindS Q Exp
conExpr]
where
stmts :: [Q Stmt]
stmts :: [Q Stmt]
stmts = forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Name -> Name -> Name -> Q Stmt
mkQual [Name]
as [Name]
bs [Name]
cs
mkQual :: Name -> Name -> Name -> Q Stmt
mkQual :: Name -> Name -> Name -> Q Stmt
mkQual Name
a Name
b Name
c = forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Stmt
bindS (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
c) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
rangeValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => [m Exp] -> m Exp
tupE [forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
a, forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
b]
IxFun
UnsafeIndex -> forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [[Name] -> Q Pat
conPat [Name]
as, [Name] -> Q Pat
conPat [Name]
bs], [Name] -> Q Pat
conPat [Name]
cs] forall a b. (a -> b) -> a -> b
$
[(Name, Name, Name)] -> Q Exp
mkUnsafeIndex forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ 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) =
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (Name -> Name -> Name -> Q Exp
mkOne Name
l Name
u Name
i)
(forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
plusValName)
(forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
unsafeRangeSizeValName
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => [m Exp] -> m Exp
tupE [forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
l, forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
u])
(forall (m :: * -> *). Quote m => Name -> m 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 = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
unsafeIndexValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => [m Exp] -> m Exp
tupE [forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
l, forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
u]
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
i
IxFun
InRange -> forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [[Name] -> Q Pat
conPat [Name]
as, [Name] -> Q Pat
conPat [Name]
bs], [Name] -> Q Pat
conPat [Name]
cs] forall a b. (a -> b) -> a -> b
$
if Int
conFields forall a. Eq a => a -> a -> Bool
== Int
0
then forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
trueDataName
else forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Q Exp -> Q Exp -> Q Exp
andExpr forall a b. (a -> b) -> a -> b
$ 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 = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp Q Exp
a (forall (m :: * -> *). Quote m => Name -> m 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 = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
inRangeValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => [m Exp] -> m Exp
tupE [forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
a, forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
b]
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m 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 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 = forall a. a -> Maybe a
Just Name
ixTypeName
classConstraint IxClass
_ Int
_ = forall a. Maybe a
Nothing
data IxFun = Range
| UnsafeIndex
| InRange
deriving Int -> IxFun -> ShowS
[IxFun] -> ShowS
IxFun -> String
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