{-# 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 fname :: Name
fname = do
#if __GLASGOW_HASKELL__ < 800
          TyConI (DataD _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname
#else
          TyConI (DataD _cxt :: Cxt
_cxt tname :: Name
tname targs :: [TyVarBndr]
targs _ constrs :: [Con]
constrs _deriving :: [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 -> Name
tyVarBndrName (TyVarBndr -> Name) -> TyVarBndr -> Name
forall a b. (a -> b) -> a -> b
$ [TyVarBndr] -> TyVarBndr
forall a. [a] -> a
last [TyVarBndr]
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 (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)
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 iVar :: Name
iVar (ForallC _ cxt :: Cxt
cxt t :: Con
t) =
                  -- Check if the GADT phantom type is constrained
                  case [Type
y | AppT (AppT (ConT eqN :: Name
eqN) x :: Type
x) y :: 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
                    tp :: Type
tp:_ -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
tp
       iTp _iVar :: Name
_iVar (GadtC _ _ (AppT _ tp :: Type
tp)) =
                  case Type
tp of
                    VarT _ -> Maybe Type
forall a. Maybe a
Nothing
                    _      -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
tp
       iTp _iVar :: Name
_iVar (RecGadtC _ _ (AppT _ tp :: Type
tp)) =
                  case Type
tp of
                    VarT _ -> Maybe Type
forall a. Maybe a
Nothing
                    _      -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
tp
       iTp _ _ = 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 tname :: Name
tname cons :: [((Name, Int), Maybe Type)]
cons tp :: 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)
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] -> CxtQ -> TypeQ -> TypeQ
forallT []
                              (Cxt -> CxtQ
forall (m :: * -> *) a. Monad m => a -> m a
return [])
                              ((TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT ''KDynCase) [Name -> TypeQ
conT Name
tname, Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
tp])
           Dec -> Q Dec
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 tp :: Type
tp (con :: (Name, Int)
con, Just tp' :: Type
tp')
                   | Type
tp Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
tp' = [Clause] -> Q [Clause]
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 _ (con :: (Name, Int)
con, _) = [Clause] -> Q [Clause]
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 (con :: Name
con, n :: Int
n) = Name -> [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
cxt name :: Name
name args :: [TyVarBndr]
args mk :: Maybe Type
mk constr :: Con
constr derive :: [DerivClause]
derive))
    = Dec -> Info
TyConI (Cxt
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD Cxt
cxt Name
name [TyVarBndr]
args Maybe Type
mk [Con
constr] [DerivClause]
derive)
#endif
abstractNewtype owise :: 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 constr :: Name
constr args :: [BangType]
args) = (Name
constr, [BangType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
args)
abstractConType (RecC constr :: Name
constr args :: [VarBangType]
args) = (Name
constr, [VarBangType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [VarBangType]
args)
abstractConType (InfixC _ constr :: Name
constr _) = (Name
constr, 2)
abstractConType (ForallC _ _ constr :: Con
constr) = Con -> (Name, Int)
abstractConType Con
constr
abstractConType (GadtC [constr :: Name
constr] args :: [BangType]
args _) = (Name
constr, [BangType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
args)
abstractConType (RecGadtC [constr :: Name
constr] args :: [VarBangType]
args _) = (Name
constr, [VarBangType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [VarBangType]
args)


{-|
  This function returns the name of a bound type variable
-}
tyVarBndrName :: TyVarBndr -> Name
tyVarBndrName (PlainTV n :: Name
n) = Name
n
tyVarBndrName (KindedTV n :: Name
n _) = 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 n :: Int
n name :: String
name = Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (String -> Q Name
newName String
name)