{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP             #-}


-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Comp.Multi.Strategy.Derive
-- Copyright   :  James Koppel, 2013
-- License     :  BSD-style (see the LICENSE file in the distribution)
--
-- This file gives a Template-Haskell generator for `DynCase`
-----------------------------------------------------------------------------


module Data.Comp.Multi.Strategy.Derive (
    makeDynCase
  ) where

import Control.Arrow ( (&&&) )
import Control.Monad

import Data.List ( nub )
import Data.Maybe ( catMaybes )
import Data.Type.Equality ( (:~:)(..) )

import Language.Haskell.TH hiding ( Cxt )

import Data.Comp.Multi.Strategy.Classification ( KDynCase, kdyncase )


-- | @makeDynCase ''T@ takes a datatype @T@ of kind @(* -> *) -> * -> *@ (i.e.: a signature in the
--   @compdata@ or @cubix-compdata@ library) and generates a `DynCase` instance for @T@.
makeDynCase :: Name -> Q [Dec]
makeDynCase :: Name -> Q [Dec]
makeDynCase Name
fname = do
#if __GLASGOW_HASKELL__ < 800
          TyConI (DataD _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname
#else
          TyConI (DataD Cxt
_cxt Name
tname [TyVarBndr BndrVis]
targs Maybe Type
_ [Con]
constrs [DerivClause]
_deriving) <- Q Info -> Q Info
abstractNewtypeQ (Q Info -> Q Info) -> Q Info -> Q Info
forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
fname
#endif
          let iVar :: Name
iVar = TyVarBndr BndrVis -> Name
forall {flag}. TyVarBndr flag -> Name
tyVarBndrName (TyVarBndr BndrVis -> Name) -> TyVarBndr BndrVis -> Name
forall a b. (a -> b) -> a -> b
$ [TyVarBndr BndrVis] -> TyVarBndr BndrVis
forall a. HasCallStack => [a] -> a
last [TyVarBndr BndrVis]
targs
          let labs :: Cxt
labs = Cxt -> Cxt
forall a. Eq a => [a] -> [a]
nub (Cxt -> Cxt) -> Cxt -> Cxt
forall a b. (a -> b) -> a -> b
$ [Maybe Type] -> Cxt
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Type] -> Cxt) -> [Maybe Type] -> Cxt
forall a b. (a -> b) -> a -> b
$ (Con -> Maybe Type) -> [Con] -> [Maybe Type]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Con -> Maybe Type
iTp Name
iVar) [Con]
constrs
          let cons :: [((Name, Int), Maybe Type)]
cons = (Con -> ((Name, Int), Maybe Type))
-> [Con] -> [((Name, Int), Maybe Type)]
forall a b. (a -> b) -> [a] -> [b]
map (Con -> (Name, Int)
abstractConType (Con -> (Name, Int))
-> (Con -> Maybe Type) -> Con -> ((Name, Int), Maybe Type)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Name -> Con -> Maybe Type
iTp Name
iVar) [Con]
constrs
          (Type -> Q Dec) -> Cxt -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Name -> [((Name, Int), Maybe Type)] -> Type -> Q Dec
genDyn Name
tname [((Name, Int), Maybe Type)]
cons) Cxt
labs
     where
       iTp :: Name -> Con -> Maybe Type
       iTp :: Name -> Con -> Maybe Type
iTp Name
iVar (ForallC [TyVarBndr Specificity]
_ Cxt
cxt Con
t) =
                  -- Check if the GADT phantom type is constrained
                  case [Type
y | AppT (AppT (ConT Name
eqN) Type
x) Type
y <- Cxt
cxt, Type
x Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
iVar, Name
eqN Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''(~)] of
                    [] -> Name -> Con -> Maybe Type
iTp Name
iVar Con
t
                    Type
tp:Cxt
_ -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
tp
       iTp Name
_iVar (GadtC [Name]
_ [BangType]
_ (AppT Type
_ Type
tp)) =
                  case Type
tp of
                    VarT Name
_ -> Maybe Type
forall a. Maybe a
Nothing
                    Type
_      -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
tp
       iTp Name
_iVar (RecGadtC [Name]
_ [VarBangType]
_ (AppT Type
_ Type
tp)) =
                  case Type
tp of
                    VarT Name
_ -> Maybe Type
forall a. Maybe a
Nothing
                    Type
_      -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
tp
       iTp Name
_ Con
_ = Maybe Type
forall a. Maybe a
Nothing
  
       genDyn :: Name -> [((Name, Int), Maybe Type)] -> Type -> Q Dec
       genDyn :: Name -> [((Name, Int), Maybe Type)] -> Type -> Q Dec
genDyn Name
tname [((Name, Int), Maybe Type)]
cons Type
tp = do
           [Clause]
clauses <- ([[Clause]] -> [Clause]) -> Q [[Clause]] -> Q [Clause]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Clause]] -> [Clause]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Clause]] -> Q [Clause]) -> Q [[Clause]] -> Q [Clause]
forall a b. (a -> b) -> a -> b
$ (((Name, Int), Maybe Type) -> Q [Clause])
-> [((Name, Int), Maybe Type)] -> Q [[Clause]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Type -> ((Name, Int), Maybe Type) -> Q [Clause]
mkClause Type
tp) [((Name, Int), Maybe Type)]
cons
           let body :: [Dec]
body = [Name -> [Clause] -> Dec
FunD 'kdyncase [Clause]
clauses]
           Type
instTp  <- [TyVarBndr Specificity] -> Q Cxt -> Q Type -> Q Type
forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m Cxt -> m Type -> m Type
forallT []
                              (Cxt -> Q Cxt
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [])
                              ((Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''KDynCase) [Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
tname, Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
tp])
           Dec -> Q Dec
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] Type
instTp [Dec]
body
  
       mkClause :: Type -> ((Name, Int), Maybe Type) -> Q [Clause]
       mkClause :: Type -> ((Name, Int), Maybe Type) -> Q [Clause]
mkClause Type
tp ((Name, Int)
con, Just Type
tp')
                   | Type
tp Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
tp' = [Clause] -> Q [Clause]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [[Pat] -> Body -> [Dec] -> Clause
Clause [(Name, Int) -> Pat
conPat (Name, Int)
con] 
                                                (Exp -> Body
NormalB (Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'Just) (Name -> Exp
ConE 'Refl)))
                                                []]
       mkClause Type
_ ((Name, Int)
con, Maybe Type
_) = [Clause] -> Q [Clause]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [[Pat] -> Body -> [Dec] -> Clause
Clause [(Name, Int) -> Pat
conPat (Name, Int)
con]
                                            (Exp -> Body
NormalB (Name -> Exp
ConE 'Nothing))
                                            []]
  
       conPat :: (Name, Int) -> Pat
       conPat :: (Name, Int) -> Pat
conPat (Name
con, Int
n) = Name -> Cxt -> [Pat] -> Pat
ConP Name
con [] (Int -> Pat -> [Pat]
forall a. Int -> a -> [a]
replicate Int
n Pat
WildP)


{-|
  This is the @Q@-lifted version of 'abstractNewtypeQ.
-}
abstractNewtypeQ :: Q Info -> Q Info
abstractNewtypeQ :: Q Info -> Q Info
abstractNewtypeQ = (Info -> Info) -> Q Info -> Q Info
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Info -> Info
abstractNewtype

{-|
  This function abstracts away @newtype@ declaration, it turns them into
  @data@ declarations.
-}
abstractNewtype :: Info -> Info
#if __GLASGOW_HASKELL__ < 800
abstractNewtype (TyConI (NewtypeD cxt name args constr derive))
    = TyConI (DataD cxt name args [constr] derive)
#else
abstractNewtype :: Info -> Info
abstractNewtype (TyConI (NewtypeD Cxt
cxt Name
name [TyVarBndr BndrVis]
args Maybe Type
mk Con
constr [DerivClause]
derive))
    = Dec -> Info
TyConI (Cxt
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD Cxt
cxt Name
name [TyVarBndr BndrVis]
args Maybe Type
mk [Con
constr] [DerivClause]
derive)
#endif
abstractNewtype Info
owise = Info
owise


{-|
  This function provides the name and the arity of the given data constructor.
-}
abstractConType :: Con -> (Name,Int)
abstractConType :: Con -> (Name, Int)
abstractConType (NormalC Name
constr [BangType]
args) = (Name
constr, [BangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
args)
abstractConType (RecC Name
constr [VarBangType]
args) = (Name
constr, [VarBangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [VarBangType]
args)
abstractConType (InfixC BangType
_ Name
constr BangType
_) = (Name
constr, Int
2)
abstractConType (ForallC [TyVarBndr Specificity]
_ Cxt
_ Con
constr) = Con -> (Name, Int)
abstractConType Con
constr
abstractConType (GadtC [Name
constr] [BangType]
args Type
_) = (Name
constr, [BangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
args)
abstractConType (RecGadtC [Name
constr] [VarBangType]
args Type
_) = (Name
constr, [VarBangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [VarBangType]
args)


{-|
  This function returns the name of a bound type variable
-}
tyVarBndrName :: TyVarBndr flag -> Name
tyVarBndrName (PlainTV Name
n flag
_) = Name
n
tyVarBndrName (KindedTV Name
n flag
_ Type
_) = Name
n



{-|
  This function provides a list (of the given length) of new names based
  on the given string.
-}
newNames :: Int -> String -> Q [Name]
newNames :: Int -> String -> Q [Name]
newNames Int
n String
name = Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
name)