module Generics.SOP.TH
( deriveGeneric
, deriveGenericOnly
, deriveGenericFunctions
, deriveMetadataValue
) where
import Control.Monad (replicateM)
import Data.Maybe (fromMaybe)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax hiding (Infix)
import Generics.SOP.BasicFunctors
import Generics.SOP.Metadata
import Generics.SOP.NP
import Generics.SOP.NS
import Generics.SOP.Universe
deriveGeneric :: Name -> Q [Dec]
deriveGeneric n = do
dec <- reifyDec n
ds1 <- withDataDec dec deriveGenericForDataDec
ds2 <- withDataDec dec deriveMetadataForDataDec
return (ds1 ++ ds2)
deriveGenericOnly :: Name -> Q [Dec]
deriveGenericOnly n = do
dec <- reifyDec n
withDataDec dec deriveGenericForDataDec
deriveGenericFunctions :: Name -> String -> String -> String -> Q [Dec]
deriveGenericFunctions n codeName fromName toName = do
let codeName' = mkName codeName
let fromName' = mkName fromName
let toName' = mkName toName
dec <- reifyDec n
withDataDec dec $ \_isNewtype _cxt name _bndrs cons _derivs -> do
let codeType = codeFor cons
let repType = [t| SOP I $(conT codeName') |]
sequence
[ tySynD codeName' [] codeType
, sigD fromName' [t| $(conT name) -> $repType |]
, embedding fromName' cons
, sigD toName' [t| $repType -> $(conT name) |]
, projection toName' cons
]
deriveMetadataValue :: Name -> String -> String -> Q [Dec]
deriveMetadataValue n codeName datatypeInfoName = do
let codeName' = mkName codeName
let datatypeInfoName' = mkName datatypeInfoName
dec <- reifyDec n
withDataDec dec $ \isNewtype _cxt name _bndrs cons _derivs -> do
sequence [ sigD datatypeInfoName' [t| DatatypeInfo $(conT codeName') |]
, funD datatypeInfoName' [clause [] (normalB $ metadata' isNewtype name cons) []]
]
#if MIN_VERSION_template_haskell(2,11,0)
deriveGenericForDataDec :: Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Cxt -> Q [Dec]
#else
deriveGenericForDataDec :: Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> [Name] -> Q [Dec]
#endif
deriveGenericForDataDec _isNewtype _cxt name bndrs cons _derivs = do
let typ = appTyVars name bndrs
#if MIN_VERSION_template_haskell(2,9,0)
let codeSyn = tySynInstD ''Code $ tySynEqn [typ] (codeFor cons)
#else
let codeSyn = tySynInstD ''Code [typ] (codeFor cons)
#endif
inst <- instanceD
(cxt [])
[t| Generic $typ |]
[codeSyn, embedding 'from cons, projection 'to cons]
return [inst]
#if MIN_VERSION_template_haskell(2,11,0)
deriveMetadataForDataDec :: Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Cxt -> Q [Dec]
#else
deriveMetadataForDataDec :: Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> [Name] -> Q [Dec]
#endif
deriveMetadataForDataDec isNewtype _cxt name bndrs cons _derivs = do
let typ = appTyVars name bndrs
md <- instanceD (cxt [])
[t| HasDatatypeInfo $typ |]
[metadata isNewtype name cons]
return [md]
codeFor :: [Con] -> Q Type
codeFor = promotedTypeList . map go
where
go :: Con -> Q Type
go c = do (_, ts) <- conInfo c
promotedTypeList ts
embedding :: Name -> [Con] -> Q Dec
embedding fromName = funD fromName . go (\e -> [| Z $e |])
where
go :: (Q Exp -> Q Exp) -> [Con] -> [Q Clause]
go _ [] = []
go br (c:cs) = mkClause br c : go (\e -> [| S $(br e) |]) cs
mkClause :: (Q Exp -> Q Exp) -> Con -> Q Clause
mkClause br c = do
(n, ts) <- conInfo c
vars <- replicateM (length ts) (newName "x")
clause [conP n (map varP vars)]
(normalB [| SOP $(br . npE . map (appE (conE 'I) . varE) $ vars) |])
[]
projection :: Name -> [Con] -> Q Dec
projection toName = funD toName . go (\p -> conP 'Z [p])
where
go :: (Q Pat -> Q Pat) -> [Con] -> [Q Clause]
go _ [] = [unreachable]
go br (c:cs) = mkClause br c : go (\p -> conP 'S [br p]) cs
mkClause :: (Q Pat -> Q Pat) -> Con -> Q Clause
mkClause br c = do
(n, ts) <- conInfo c
vars <- replicateM (length ts) (newName "x")
clause [conP 'SOP [br . npP . map (\v -> conP 'I [varP v]) $ vars]]
(normalB . appsE $ conE n : map varE vars)
[]
unreachable :: Q Clause
unreachable = clause [wildP]
(normalB [| error "unreachable" |])
[]
metadata :: Bool -> Name -> [Con] -> Q Dec
metadata isNewtype typeName cs =
funD 'datatypeInfo [clause [wildP] (normalB $ metadata' isNewtype typeName cs) []]
metadata' :: Bool -> Name -> [Con] -> Q Exp
metadata' isNewtype typeName cs = md
where
md :: Q Exp
md | isNewtype = [| Newtype $(stringE (nameModule' typeName))
$(stringE (nameBase typeName))
$(mdCon (head cs))
|]
| otherwise = [| ADT $(stringE (nameModule' typeName))
$(stringE (nameBase typeName))
$(npE $ map mdCon cs)
|]
mdCon :: Con -> Q Exp
mdCon (NormalC n _) = [| Constructor $(stringE (nameBase n)) |]
mdCon (RecC n ts) = [| Record $(stringE (nameBase n))
$(npE (map mdField ts))
|]
mdCon (InfixC _ n _) = do
#if MIN_VERSION_template_haskell(2,11,0)
fixity <- reifyFixity n
case fromMaybe defaultFixity fixity of
Fixity f a ->
#else
i <- reify n
case i of
DataConI _ _ _ (Fixity f a) ->
#endif
[| Infix $(stringE (nameBase n)) $(mdAssociativity a) f |]
#if !MIN_VERSION_template_haskell(2,11,0)
_ -> fail "Strange infix operator"
#endif
mdCon (ForallC _ _ _) = fail "Existentials not supported"
#if MIN_VERSION_template_haskell(2,11,0)
mdCon (GadtC _ _ _) = fail "GADTs not supported"
mdCon (RecGadtC _ _ _) = fail "GADTs not supported"
#endif
mdField :: VarStrictType -> Q Exp
mdField (n, _, _) = [| FieldInfo $(stringE (nameBase n)) |]
mdAssociativity :: FixityDirection -> Q Exp
mdAssociativity InfixL = [| LeftAssociative |]
mdAssociativity InfixR = [| RightAssociative |]
mdAssociativity InfixN = [| NotAssociative |]
nameModule' :: Name -> String
nameModule' = fromMaybe "" . nameModule
npE :: [Q Exp] -> Q Exp
npE [] = [| Nil |]
npE (e:es) = [| $e :* $(npE es) |]
npP :: [Q Pat] -> Q Pat
npP [] = conP 'Nil []
npP (p:ps) = conP '(:*) [p, npP ps]
conInfo :: Con -> Q (Name, [Q Type])
conInfo (NormalC n ts) = return (n, map (return . (\(_, t) -> t)) ts)
conInfo (RecC n ts) = return (n, map (return . (\(_, _, t) -> t)) ts)
conInfo (InfixC (_, t) n (_, t')) = return (n, map return [t, t'])
conInfo (ForallC _ _ _) = fail "Existentials not supported"
#if MIN_VERSION_template_haskell(2,11,0)
conInfo (GadtC _ _ _) = fail "GADTs not supported"
conInfo (RecGadtC _ _ _) = fail "GADTs not supported"
#endif
promotedTypeList :: [Q Type] -> Q Type
promotedTypeList [] = promotedNilT
promotedTypeList (t:ts) = [t| $promotedConsT $t $(promotedTypeList ts) |]
appTyVars :: Name -> [TyVarBndr] -> Q Type
appTyVars n = go (conT n)
where
go :: Q Type -> [TyVarBndr] -> Q Type
go t [] = t
go t (PlainTV v : vs) = go [t| $t $(varT v) |] vs
go t (KindedTV v _ : vs) = go [t| $t $(varT v) |] vs
reifyDec :: Name -> Q Dec
reifyDec name =
do info <- reify name
case info of TyConI dec -> return dec
_ -> fail "Info must be type declaration type."
#if MIN_VERSION_template_haskell(2,11,0)
withDataDec :: Dec -> (Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Cxt -> Q a) -> Q a
withDataDec (DataD ctxt name bndrs _ cons derivs) f = f False ctxt name bndrs cons derivs
withDataDec (NewtypeD ctxt name bndrs _ con derivs) f = f True ctxt name bndrs [con] derivs
#else
withDataDec :: Dec -> (Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> [Name] -> Q a) -> Q a
withDataDec (DataD ctxt name bndrs cons derivs) f = f False ctxt name bndrs cons derivs
withDataDec (NewtypeD ctxt name bndrs con derivs) f = f True ctxt name bndrs [con] derivs
#endif
withDataDec _ _ = fail "Can only derive labels for datatypes and newtypes."