{-|
Module:      Data.Ix.Deriving.Internal
Copyright:   (C) 2015-2017 Ryan Scott
License:     BSD-style (see the file LICENSE)
Maintainer:  Ryan Scott
Portability: Template Haskell

Exports functions to mechanically derive 'Ix' instances.

Note: this is an internal module, and as such, the API presented here is not
guaranteed to be stable, even between minor releases of this library.
-}
module Data.Ix.Deriving.Internal (
      -- * 'Ix'
      deriveIx
    , makeRange
    , makeUnsafeIndex
    , makeInRange
    ) where

import Data.Deriving.Internal

import Language.Haskell.TH.Datatype
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax

-------------------------------------------------------------------------------
-- Code generation
-------------------------------------------------------------------------------

-- | Generates a 'Ix' instance declaration for the given data type or data
-- family instance.
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)

-- | Generates a lambda expression which behaves like 'range' (without
-- requiring an 'Ix' instance).
makeRange :: Name -> Q Exp
makeRange :: Name -> Q Exp
makeRange = IxFun -> Name -> Q Exp
makeIxFun IxFun
Range

-- | Generates a lambda expression which behaves like 'unsafeIndex' (without
-- requiring an 'Ix' instance).
makeUnsafeIndex :: Name -> Q Exp
makeUnsafeIndex :: Name -> Q Exp
makeUnsafeIndex = IxFun -> Name -> Q Exp
makeIxFun IxFun
UnsafeIndex

-- | Generates a lambda expression which behaves like 'inRange' (without
-- requiring an 'Ix' instance).
makeInRange :: Name -> Q Exp
makeInRange :: Name -> Q Exp
makeInRange = IxFun -> Name -> Q Exp
makeIxFun IxFun
InRange

-- | Generates method declarations for an 'Ix' instance.
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)
                    []
           ]

-- | Generates a lambda expression which behaves like the IxFun argument.
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

-- | Generates a lambda expression for an 'Ix' method for the
-- given constructors. All constructors must be from the same type.
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 -- It's a product type
    = 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

-------------------------------------------------------------------------------
-- Class-specific constants
-------------------------------------------------------------------------------

-- There's only one Ix variant!
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

-- | A representation of which function is being generated.
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