{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE TemplateHaskellQuotes #-}
#else
{-# LANGUAGE TemplateHaskell #-}
#endif
#if __GLASGOW_HASKELL__ >=704 && MIN_VERSION_template_haskell(2,12,0)
{-# LANGUAGE Safe #-}
#elif __GLASGOW_HASKELL__ >=702
{-# LANGUAGE Trustworthy #-}
#endif
module Data.Universe.Some.TH (
  DeriveUniverseSome (..),
  universeSomeQ,
  ) where

import Control.Monad (forM, mapM, unless)
import Data.Some (Some, mkSome)
import Data.Universe.Class (Universe (..))
import Data.Universe.Some (UniverseSome (..))
import Data.Universe.Helpers (interleave, (<+*+>))
import Language.Haskell.TH
import Language.Haskell.TH.Datatype

-- $setup
-- >>> :m + Data.Some Data.Universe.Class Data.Universe.Some

-- | Derive the @'UniverseSome' n@ instance.
--
-- >>> :set -XGADTs -XTemplateHaskell -XStandaloneDeriving
-- >>> import Data.Universe.Class (universe)
-- >>> import Data.GADT.Show
--
-- >>> data Tag b a where IntTag :: Tag b Int; BoolTag :: b -> Tag b Bool
-- >>> deriving instance Show b => Show (Tag b a)
-- >>> instance Show b => GShow (Tag b) where gshowsPrec = showsPrec
--
-- (@data Unused@ is to workaround bug in older GHCi)
-- >>> data Unused; $(deriveUniverseSome ''Tag)
--
-- >>> universe :: [Some (Tag (Maybe Bool))]
-- [Some IntTag,Some (BoolTag Nothing),Some (BoolTag (Just False)),Some (BoolTag (Just True))]
--
-- 'deriveUniverseSome' variant taking a 'Name' guesses simple class constraints.
-- If you need more specific, you can specify them:
-- (Note: on older GHCs this will warn, as the instance definition doesn't have all methods defined).
--
-- >>> data Tag b a where IntTag :: Tag b Int; BoolTag :: b -> Tag b Bool
-- >>> deriving instance Show b => Show (Tag b a)
-- >>> instance Show b => GShow (Tag b) where gshowsPrec = showsPrec
-- >>> data Unused; $(deriveUniverseSome [d| instance Universe b => UniverseSome (Tag b) |])
-- ...
-- >>> universe :: [Some (Tag (Maybe Bool))]
-- [Some IntTag,Some (BoolTag Nothing),Some (BoolTag (Just False)),Some (BoolTag (Just True))]
--
class DeriveUniverseSome a where
  deriveUniverseSome :: a -> DecsQ

instance DeriveUniverseSome a => DeriveUniverseSome [a] where
  deriveUniverseSome :: [a] -> DecsQ
deriveUniverseSome [a]
a = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((a -> DecsQ) -> [a] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> DecsQ
forall a. DeriveUniverseSome a => a -> DecsQ
deriveUniverseSome [a]
a)

instance DeriveUniverseSome a => DeriveUniverseSome (Q a) where
  deriveUniverseSome :: Q a -> DecsQ
deriveUniverseSome Q a
a = a -> DecsQ
forall a. DeriveUniverseSome a => a -> DecsQ
deriveUniverseSome (a -> DecsQ) -> Q a -> DecsQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q a
a

instance DeriveUniverseSome Name where
  deriveUniverseSome :: Name -> DecsQ
deriveUniverseSome Name
name = do
    DatatypeInfo
di <- Name -> Q DatatypeInfo
reifyDatatype Name
name
    let DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
datatypeContext = Cxt
ctxt
                     , datatypeName :: DatatypeInfo -> Name
datatypeName    = Name
parentName
#if MIN_VERSION_th_abstraction(0,3,0)
                     , datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
vars0
#else
                     , datatypeVars    = vars0
#endif
                     , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons    = [ConstructorInfo]
cons
                     } = DatatypeInfo
di

    case Cxt -> Maybe (Cxt, Type)
forall a. [a] -> Maybe ([a], a)
safeUnsnoc Cxt
vars0 of
      Maybe (Cxt, Type)
Nothing -> String -> DecsQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Datatype should have at least one type variable"
      Just (Cxt
vars, Type
var) -> do
        [Name]
varNames <- Cxt -> (Type -> Q Name) -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Cxt
vars ((Type -> Q Name) -> Q [Name]) -> (Type -> Q Name) -> Q [Name]
forall a b. (a -> b) -> a -> b
$ \Type
v -> case Type
v of
#if MIN_VERSION_template_haskell(2,8,0)
          SigT (VarT Name
n) Type
StarT -> String -> Q Name
newName String
"x"
#else
          SigT (VarT n) StarK -> newName "x"
#endif
          Type
_                   -> String -> Q Name
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Only arguments of kind Type are supported"

#if MIN_VERSION_template_haskell(2,10,0)
        let constrs :: [TypeQ]
            constrs :: [TypeQ]
constrs = (Name -> TypeQ) -> [Name] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
n -> Name -> TypeQ
conT ''Universe TypeQ -> TypeQ -> TypeQ
`appT` Name -> TypeQ
varT Name
n) [Name]
varNames
#else
        let constrs :: [PredQ]
            constrs = map (\n -> classP ''Universe [varT n]) varNames
#endif
        let typ :: TypeQ
typ     = (TypeQ -> Name -> TypeQ) -> TypeQ -> [Name] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\TypeQ
c Name
n -> TypeQ
c TypeQ -> TypeQ -> TypeQ
`appT` Name -> TypeQ
varT Name
n) (Name -> TypeQ
conT Name
parentName) [Name]
varNames

        Dec
i <- CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD ([TypeQ] -> CxtQ
cxt [TypeQ]
constrs) (Name -> TypeQ
conT ''UniverseSome TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
typ)
            [ DatatypeInfo -> DecQ
instanceDecFor DatatypeInfo
di
            ]

        [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
i]

instanceDecFor :: DatatypeInfo -> Q Dec
instanceDecFor :: DatatypeInfo -> DecQ
instanceDecFor DatatypeInfo
di = PatQ -> BodyQ -> [DecQ] -> DecQ
valD (Name -> PatQ
varP 'universeSome) (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ DatatypeInfo -> ExpQ
universeSomeQ' DatatypeInfo
di) []

instance DeriveUniverseSome Dec where
#if MIN_VERSION_template_haskell(2,11,0)
  deriveUniverseSome :: Dec -> DecsQ
deriveUniverseSome (InstanceD Maybe Overlap
overlaps Cxt
c Type
classHead []) = do
    let instanceFor :: [Dec] -> Dec
instanceFor = Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
overlaps Cxt
c Type
classHead
#else
  deriveUniverseSome (InstanceD c classHead []) = do
    let instanceFor = InstanceD c classHead
#endif
    case Type
classHead of
      ConT Name
u `AppT` Type
t | Name
u Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''UniverseSome -> do
        Name
name <- Type -> Q Name
headOfType Type
t
        DatatypeInfo
di <- Name -> Q DatatypeInfo
reifyDatatype Name
name
        Dec
i <- ([Dec] -> Dec) -> DecsQ -> DecQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Dec] -> Dec
instanceFor (DecsQ -> DecQ) -> DecsQ -> DecQ
forall a b. (a -> b) -> a -> b
$ (DecQ -> DecQ) -> [DecQ] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DecQ -> DecQ
forall a. a -> a
id
            [ DatatypeInfo -> DecQ
instanceDecFor DatatypeInfo
di
            ]
        [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
i]
      Type
_ -> String -> DecsQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> DecsQ) -> String -> DecsQ
forall a b. (a -> b) -> a -> b
$ String
"deriveUniverseSome: expected an instance head like `UniverseSome (C a b ...)`, got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
classHead
  deriveUniverseSome Dec
_ = String -> DecsQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"deriveUniverseSome: expected an empty instance declaration"

-- | Derive the method for @:: ['Some' tag]@
--
-- >>> :set -XGADTs -XTemplateHaskell -XStandaloneDeriving
-- >>> import Data.GADT.Show
--
-- >>> data Tag b a where IntTag :: Tag b Int; BoolTag :: b -> Tag b Bool
-- >>> deriving instance Show b => Show (Tag b a)
-- >>> instance Show b => GShow (Tag b) where gshowsPrec = showsPrec
--
-- >>> $(universeSomeQ ''Tag) :: [Some (Tag Bool)]
-- [Some IntTag,Some (BoolTag False),Some (BoolTag True)]
--
universeSomeQ :: Name -> ExpQ
universeSomeQ :: Name -> ExpQ
universeSomeQ Name
name = Name -> Q DatatypeInfo
reifyDatatype Name
name Q DatatypeInfo -> (DatatypeInfo -> ExpQ) -> ExpQ
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DatatypeInfo -> ExpQ
universeSomeQ'

universeSomeQ' :: DatatypeInfo -> Q Exp
universeSomeQ' :: DatatypeInfo -> ExpQ
universeSomeQ' DatatypeInfo
di = do
  let DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
datatypeContext = Cxt
ctxt
                   , datatypeName :: DatatypeInfo -> Name
datatypeName    = Name
parentName
#if MIN_VERSION_th_abstraction(0,3,0)
                   , datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
vars0
#else
                   , datatypeVars    = vars0
#endif
                   , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons    = [ConstructorInfo]
cons
                   } = DatatypeInfo
di

  -- check
  Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Cxt -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Cxt
ctxt) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Datatype context is not empty"

  case Cxt -> Maybe (Cxt, Type)
forall a. [a] -> Maybe ([a], a)
safeUnsnoc Cxt
vars0 of
    Maybe (Cxt, Type)
Nothing -> String -> ExpQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Datatype should have at least one type variable"
    Just (Cxt
vars, Type
var) -> do
      let universe' :: ExpQ
universe'   = [| universe |]
      let uap :: ExpQ
uap         = [| (<+*+>) |]
      let interleave' :: ExpQ
interleave' = [| interleave |]
      let mapSome' :: ExpQ
mapSome'    = [| map mkSome |]

      let sums :: [ExpQ]
sums = (ConstructorInfo -> ExpQ) -> [ConstructorInfo] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map (ExpQ -> ExpQ -> ExpQ -> ConstructorInfo -> ExpQ
universeForCon ExpQ
mapSome' ExpQ
universe' ExpQ
uap) [ConstructorInfo]
cons
      ExpQ
interleave' ExpQ -> ExpQ -> ExpQ
`appE` [ExpQ] -> ExpQ
listE [ExpQ]
sums
  where
    universeForCon :: ExpQ -> ExpQ -> ExpQ -> ConstructorInfo -> ExpQ
universeForCon ExpQ
mapSome' ExpQ
universe' ExpQ
uap ConstructorInfo
ci =
      let con :: ExpQ
con     = [ExpQ] -> ExpQ
listE [ Name -> ExpQ
conE (ConstructorInfo -> Name
constructorName ConstructorInfo
ci) ]
          nargs :: Int
nargs   = Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ConstructorInfo -> Cxt
constructorFields ConstructorInfo
ci)
          conArgs :: ExpQ
conArgs = (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ExpQ
f ExpQ
x -> Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
infixE (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just ExpQ
f) ExpQ
uap (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just ExpQ
universe')) ExpQ
con (Int -> ExpQ -> [ExpQ]
forall a. Int -> a -> [a]
replicate Int
nargs ExpQ
universe')

      in ExpQ
mapSome' ExpQ -> ExpQ -> ExpQ
`appE` ExpQ
conArgs

-------------------------------------------------------------------------------
-- helpers
-------------------------------------------------------------------------------

headOfType :: Type -> Q Name
headOfType :: Type -> Q Name
headOfType (AppT Type
t Type
_) = Type -> Q Name
headOfType Type
t
headOfType (VarT Name
n)   = Name -> Q Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
headOfType (ConT Name
n)   = Name -> Q Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
headOfType Type
t          = String -> Q Name
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ String
"headOfType: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t

safeUnsnoc :: [a] -> Maybe ([a], a)
safeUnsnoc :: [a] -> Maybe ([a], a)
safeUnsnoc [a]
xs = case [a] -> [a]
forall a. [a] -> [a]
reverse [a]
xs of
  []     -> Maybe ([a], a)
forall a. Maybe a
Nothing
  (a
y:[a]
ys) -> ([a], a) -> Maybe ([a], a)
forall a. a -> Maybe a
Just ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
ys, a
y)