{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Aeson.GADT.TH
( deriveJSONGADT
, deriveToJSONGADT
, deriveFromJSONGADT
, deriveJSONGADTWithOptions
, deriveToJSONGADTWithOptions
, deriveFromJSONGADTWithOptions
, JSONGADTOptions(JSONGADTOptions, gadtConstructorModifier)
, defaultJSONGADTOptions
) where
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Writer
import Data.Aeson
import Data.List
import Data.Maybe
import qualified Data.Set as Set
import Data.Some (Some (..))
import Language.Haskell.TH hiding (cxt)
newtype JSONGADTOptions = JSONGADTOptions
{ gadtConstructorModifier :: String -> String }
defaultJSONGADTOptions :: JSONGADTOptions
defaultJSONGADTOptions = JSONGADTOptions
{ gadtConstructorModifier = id }
deriveJSONGADT :: Name -> DecsQ
deriveJSONGADT = deriveJSONGADTWithOptions defaultJSONGADTOptions
deriveJSONGADTWithOptions :: JSONGADTOptions -> Name -> DecsQ
deriveJSONGADTWithOptions opts n = do
tj <- deriveToJSONGADTWithOptions opts n
fj <- deriveFromJSONGADTWithOptions opts n
return (tj ++ fj)
deriveToJSONGADT :: Name -> DecsQ
deriveToJSONGADT = deriveToJSONGADTWithOptions defaultJSONGADTOptions
deriveToJSONGADTWithOptions :: JSONGADTOptions -> Name -> DecsQ
deriveToJSONGADTWithOptions opts n = do
x <- reify n
let cons = case x of
TyConI d -> decCons d
_ -> error $ "deriveToJSONGADT: Name `" ++ show n ++ "' does not appear to be the name of a type constructor."
topVars <- makeTopVars n
let n' = foldl (\c v -> AppT c (VarT v)) (ConT n) topVars
(matches, constraints') <- runWriterT (mapM (fmap pure . conMatchesToJSON opts (init topVars)) cons)
let constraints = map head . group . sort $ constraints'
impl <- funD (mkName "toJSON")
[ clause [] (normalB $ lamCaseE matches) []
]
return [ InstanceD Nothing constraints (AppT (ConT ''ToJSON) n') [impl] ]
makeTopVars :: Name -> Q [Name]
makeTopVars tyConName = do
(tyVarBndrs, kArity) <- tyConArity' tyConName
extraVars <- replicateM kArity (newName "topvar")
return (map tyVarBndrName tyVarBndrs ++ extraVars)
deriveFromJSONGADT :: Name -> DecsQ
deriveFromJSONGADT = deriveFromJSONGADTWithOptions defaultJSONGADTOptions
deriveFromJSONGADTWithOptions :: JSONGADTOptions -> Name -> DecsQ
deriveFromJSONGADTWithOptions opts n = do
x <- reify n
let decl = case x of
TyConI d -> d
_ -> error $ "deriveFromJSONGADT: Name `" ++ show n ++ "' does not appear to be the name of a type constructor."
cons = decCons decl
allConNames =
intercalate ", " $
map (gadtConstructorModifier opts . nameBase . conName) cons
wildName <- newName "s"
let wild = match (varP wildName) (normalB [e|
fail $
"Expected tag to be one of [" <> allConNames <> "] but got: "
<> $(varE wildName)
|]) []
topVars <- init <$> makeTopVars n
let n' = foldl (\c v -> AppT c (VarT v)) (ConT n) topVars
(matches, constraints') <- runWriterT $ mapM (conMatchesParseJSON opts topVars [|_v'|]) cons
let constraints = map head . group . sort $ constraints'
v <- newName "v"
parser <- funD (mkName "parseJSON")
[ clause [varP v] (normalB [e|
do (tag', _v') <- parseJSON $(varE v)
$(caseE [|tag' :: String|] $ map pure matches ++ [wild])
|]) []
]
return [ InstanceD Nothing constraints (AppT (ConT ''FromJSON) (AppT (ConT ''Some) n')) [parser] ]
conMatchesToJSON :: JSONGADTOptions -> [Name] -> Con -> WriterT [Type] Q Match
conMatchesToJSON opts topVars c = do
let name = conName c
base = gadtConstructorModifier opts $ nameBase name
toJSONExp e = [| toJSON $(e) |]
vars <- lift $ replicateM (conArity c) (newName "x")
let body = toJSONExp $ tupE [ [| base :: String |] , tupE $ map (toJSONExp . varE) vars ]
_ <- conMatches (AppT (ConT ''ToJSON)) topVars c
lift $ match (conP name (map varP vars)) (normalB body) []
conMatchesParseJSON :: JSONGADTOptions -> [Name] -> ExpQ -> Con -> WriterT [Type] Q Match
conMatchesParseJSON opts topVars e c = do
(pat, conApp) <- conMatches (AppT (ConT ''FromJSON)) topVars c
let match' = match (litP (StringL (gadtConstructorModifier opts $ nameBase (conName c))))
body = doE [ bindS (return pat) [| parseJSON $e |]
, noBindS [| return (This $(return conApp)) |]
]
lift $ match' (normalB body) []
conMatches
:: (Type -> Type)
-> [Name]
-> Con
-> WriterT [Type] Q (Pat, Exp)
conMatches mkConstraint topVars c = do
let name = conName c
forTypes types resultType = do
vars <- forM types $ \typ -> do
x <- lift $ newName "x"
case typ of
AppT (ConT tn) (VarT _) -> do
idec <- lift $ reifyInstances ''FromJSON [AppT (ConT ''Some) (ConT tn)]
case idec of
[] -> do
tell [mkConstraint (substVarsWith topVars resultType typ)]
return (VarP x, VarE x)
_ -> return $ (ConP 'This [VarP x], VarE x)
_ -> do
tell [mkConstraint (substVarsWith topVars resultType typ)]
return (VarP x, VarE x)
let pat = TupP (map fst vars)
conApp = foldl AppE (ConE name) (map snd vars)
return (pat, conApp)
case c of
ForallC _ cxt (GadtC _ tys t) -> do
tell (map (substVarsWith topVars t) cxt)
forTypes (map snd tys) t
GadtC _ tys t -> forTypes (map snd tys) t
_ -> error "conMatches: Unmatched constructor type"
substVarsWith
:: [Name]
-> Type
-> Type
-> Type
substVarsWith topVars resultType argType = subst Set.empty argType
where
topVars' = reverse topVars
AppT resultType' _indexType = resultType
subst bs = \case
ForallT bndrs cxt t ->
let bs' = Set.union bs (Set.fromList (map tyVarBndrName bndrs))
in ForallT bndrs (map (subst bs') cxt) (subst bs' t)
AppT f x -> AppT (subst bs f) (subst bs x)
SigT t k -> SigT (subst bs t) k
VarT v -> if Set.member v bs
then VarT v
else VarT (findVar v topVars' resultType')
InfixT t1 x t2 -> InfixT (subst bs t1) x (subst bs t2)
UInfixT t1 x t2 -> UInfixT (subst bs t1) x (subst bs t2)
ParensT t -> ParensT (subst bs t)
PromotedT n -> PromotedT n
ConT n -> ConT n
TupleT k -> TupleT k
UnboxedTupleT k -> UnboxedTupleT k
UnboxedSumT k -> UnboxedSumT k
ArrowT -> ArrowT
EqualityT -> EqualityT
ListT -> ListT
PromotedTupleT k -> PromotedTupleT k
PromotedNilT -> PromotedNilT
PromotedConsT -> PromotedConsT
StarT -> StarT
ConstraintT -> ConstraintT
LitT l -> LitT l
WildCardT -> WildCardT
findVar v (tv:_) (AppT _ (VarT v')) | v == v' = tv
findVar v (_:tvs) (AppT t (VarT _)) = findVar v tvs t
findVar v _ _ = error $ "substVarsWith: couldn't look up variable substitution for " <> show v
<> " with topVars: " <> show topVars <> " resultType: " <> show resultType <> " argType: " <> show argType
tyVarBndrName :: TyVarBndr -> Name
tyVarBndrName = \case
PlainTV n -> n
KindedTV n _ -> n
kindArity :: Kind -> Int
kindArity = \case
ForallT _ _ t -> kindArity t
AppT (AppT ArrowT _) t -> 1 + kindArity t
SigT t _ -> kindArity t
ParensT t -> kindArity t
_ -> 0
tyConArity :: Name -> Q Int
tyConArity n = do
(ts, ka) <- tyConArity' n
return (length ts + ka)
tyConArity' :: Name -> Q ([TyVarBndr], Int)
tyConArity' n = reify n >>= return . \case
TyConI (DataD _ _ ts mk _ _) -> (ts, fromMaybe 0 (fmap kindArity mk))
TyConI (NewtypeD _ _ ts mk _ _) -> (ts, fromMaybe 0 (fmap kindArity mk))
_ -> error $ "tyConArity': Supplied name reified to something other than a data declaration: " <> show n
decCons :: Dec -> [Con]
decCons = \case
DataD _ _ _ _ cs _ -> cs
NewtypeD _ _ _ _ c _ -> [c]
_ -> error "decCons: Declaration found was not a data or newtype declaration."
conName :: Con -> Name
conName c = case c of
NormalC n _ -> n
RecC n _ -> n
InfixC _ n _ -> n
ForallC _ _ c' -> conName c'
GadtC [n] _ _ -> n
RecGadtC [n] _ _ -> n
_ -> error "conName: GADT constructors with multiple names not yet supported"
conArity :: Con -> Int
conArity c = case c of
NormalC _ ts -> length ts
RecC _ ts -> length ts
InfixC _ _ _ -> 2
ForallC _ _ c' -> conArity c'
GadtC _ ts _ -> length ts
RecGadtC _ ts _ -> length ts