{-|
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)
          <- 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)

-- | 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 =
      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)
                    []
           ]

-- | 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) <- 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
_  [] = 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 -- It's a product type

    = 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

-------------------------------------------------------------------------------

-- 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 = forall a. a -> Maybe a
Just Name
ixTypeName
    classConstraint IxClass
_ Int
_ = 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
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