{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE PolyKinds #-}
module Data.Aeson.GADT.TH
( deriveJSONGADT
, deriveToJSONGADT
, deriveFromJSONGADT
, deriveJSONGADTWithOptions
, deriveToJSONGADTWithOptions
, deriveFromJSONGADTWithOptions
, JSONGADTOptions(JSONGADTOptions, gadtConstructorModifier)
, defaultJSONGADTOptions
) where
import Control.Monad (forM, replicateM)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Writer (WriterT, runWriterT, tell)
import Data.Aeson (FromJSON(..), ToJSON(..))
import Data.List (group, intercalate, partition, sort)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Some (Some(..))
import Language.Haskell.TH hiding (cxt)
import Language.Haskell.TH.Datatype (ConstructorInfo(..), applySubstitution, datatypeCons, reifyDatatype, unifyTypes)
import Language.Haskell.TH.Datatype.TyVarBndr (TyVarBndr_, tvName)
#if MIN_VERSION_dependent_sum(0,5,0)
#else
pattern Some :: tag a -> Some tag
pattern Some x = This x
#endif
type family Skolem :: k -> k
skolemize :: Set Name -> Type -> Type
skolemize rigids t = case t of
ForallT bndrs cxt t' -> ForallT bndrs cxt (skolemize (Set.difference rigids (Set.fromList (map tvName bndrs))) t')
AppT t1 t2 -> AppT (skolemize rigids t1) (skolemize rigids t2)
SigT t1 k -> SigT (skolemize rigids t1) k
VarT v -> if Set.member v rigids
then AppT (ConT ''Skolem) (VarT v)
else t
InfixT t1 n t2 -> InfixT (skolemize rigids t1) n (skolemize rigids t2)
UInfixT t1 n t2 -> UInfixT (skolemize rigids t1) n (skolemize rigids t2)
ParensT t1 -> ParensT (skolemize rigids t1)
_ -> t
reifyInstancesWithRigids :: Set Name -> Name -> [Type] -> Q [InstanceDec]
reifyInstancesWithRigids rigids cls tys = reifyInstances cls (map (skolemize rigids) tys)
freeTypeVariables :: Type -> Set Name
freeTypeVariables t = case t of
ForallT bndrs _ t' -> Set.difference (freeTypeVariables t') (Set.fromList (map tvName bndrs))
AppT t1 t2 -> Set.union (freeTypeVariables t1) (freeTypeVariables t2)
SigT t1 _ -> freeTypeVariables t1
VarT n -> Set.singleton n
_ -> Set.empty
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
info <- reifyDatatype n
let cons = datatypeCons info
topVars <- makeTopVars n
let n' = foldl (\c v -> AppT c (VarT v)) (ConT n) topVars
(matches, constraints') <- runWriterT (mapM (fmap pure . conMatchesToJSON opts topVars) cons)
let constraints = map head . group . sort $ constraints'
impl <- funD '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 tvName tyVarBndrs ++ extraVars)
deriveFromJSONGADT :: Name -> DecsQ
deriveFromJSONGADT = deriveFromJSONGADTWithOptions defaultJSONGADTOptions
deriveFromJSONGADTWithOptions :: JSONGADTOptions -> Name -> DecsQ
deriveFromJSONGADTWithOptions opts n = do
info <- reifyDatatype n
let cons = datatypeCons info
allConNames =
intercalate ", " $
map (gadtConstructorModifier opts . nameBase . constructorName) cons
wildName <- newName "s"
let wild = match (varP wildName) (normalB [e|
fail $
"Expected tag to be one of [" ++ allConNames ++ "] but got: "
++ $(varE wildName)
|]) []
topVars <- makeTopVars n
let n' = foldl (\c v -> AppT c (VarT v)) (ConT n) $ init topVars
(matches, constraints') <- runWriterT $ mapM (conMatchesParseJSON opts topVars [|_v'|]) cons
let constraints = map head . group . sort $ constraints'
v <- newName "v"
parser <- funD '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] ]
splitTopVars :: [Name] -> (Set Name, Name)
splitTopVars allTopVars = case reverse allTopVars of
(x:xs) -> (Set.fromList xs, x)
_ -> error "splitTopVars: Empty set of variables"
conMatchesToJSON :: JSONGADTOptions -> [Name] -> ConstructorInfo -> WriterT [Type] Q Match
conMatchesToJSON opts allTopVars c = do
let (topVars, lastVar) = splitTopVars allTopVars
name = constructorName c
base = gadtConstructorModifier opts $ nameBase name
toJSONExp e = [| toJSON $(e) |]
vars <- lift . forM (constructorFields c) $ \_ -> newName "x"
let body = toJSONExp $ tupE
[ [| base :: String |]
, case vars of
[v] -> toJSONExp $ varE v
vs -> tupE $ map (toJSONExp . varE) vs
]
_ <- conMatches ''ToJSON topVars lastVar c
lift $ match (conP name (map varP vars)) (normalB body) []
conMatchesParseJSON :: JSONGADTOptions -> [Name] -> ExpQ -> ConstructorInfo -> WriterT [Type] Q Match
conMatchesParseJSON opts allTopVars e c = do
let (topVars, lastVar) = splitTopVars allTopVars
(pat, conApp) <- conMatches ''FromJSON topVars lastVar c
let match' = match (litP (StringL (gadtConstructorModifier opts $ nameBase (constructorName c))))
body = doE [ bindS (return pat) [| parseJSON $e |]
, noBindS [| return (Some $(return conApp)) |]
]
lift $ match' (normalB body) []
conMatches
:: Name
-> Set Name
-> Name
-> ConstructorInfo
-> WriterT [Type] Q (Pat, Exp)
conMatches clsName topVars ixVar c = do
let name = constructorName c
types = constructorFields c
(constraints, equalities') = flip partition (constructorContext c) $ \case
AppT (AppT EqualityT _) _ -> False
_ -> True
equalities = concat [ [(a, b), (b, a)] | AppT (AppT EqualityT a) b <- equalities' ]
unifiedEqualities :: [Map Name Type] <- lift $ forM equalities $ \(a, b) -> unifyTypes [a, b]
let rigidImplications :: Map Name (Set Name)
rigidImplications = Map.unionsWith Set.union $ fmap freeTypeVariables <$> unifiedEqualities
let expandRigids :: Set Name -> Set Name
expandRigids rigids = Set.union rigids $ Set.unions $ Map.elems $
restrictKeys rigidImplications rigids
expandRigidsFully rigids =
let rigids' = expandRigids rigids
in if rigids' == rigids then rigids else expandRigidsFully rigids'
rigidVars = expandRigidsFully topVars
ixSpecialization :: Map Name Type
ixSpecialization = restrictKeys (Map.unions unifiedEqualities) $ Set.singleton ixVar
tellCxt cs = do
tell $ applySubstitution ixSpecialization cs
tellCxt constraints
vars <- forM types $ \typ -> do
x <- lift $ newName "x"
let demandInstanceIfNecessary = do
insts <- lift $ reifyInstancesWithRigids rigidVars clsName [typ]
case insts of
[] -> tellCxt [AppT (ConT clsName) typ]
[InstanceD _ cxt (AppT _className ityp) _] -> do
sub <- lift $ unifyTypes [ityp, typ]
tellCxt $ applySubstitution sub cxt
_ -> error $ "The following instances of " ++ show clsName ++ " for " ++ show typ ++ " exist (rigids: " ++ unwords (map show $ Set.toList rigidVars) ++ "), and I don't know which to pick:\n" ++ unlines (map (show . ppr) insts)
case typ of
AppT tn (VarT _) -> do
insts <- lift $ reifyInstancesWithRigids rigidVars clsName [AppT (ConT ''Some) tn]
case insts of
[] -> do
demandInstanceIfNecessary
return (VarP x, VarE x)
[InstanceD _ cxt (AppT _className (AppT (ConT _some) ityp)) _] -> do
sub <- lift $ unifyTypes [ityp, tn]
tellCxt $ applySubstitution sub cxt
return (ConP 'Some [VarP x], VarE x)
_ -> error $ "The following instances of " ++ show clsName ++ " for " ++ show (ppr [AppT (ConT ''Some) tn]) ++ " exist (rigids: " ++ unwords (map show $ Set.toList rigidVars) ++ "), and I don't know which to pick:\n" ++ unlines (map (show . ppr) insts)
_ -> do
demandInstanceIfNecessary
return (VarP x, VarE x)
let pat = case vars of
[v] -> fst v
vs -> TupP (map fst vs)
conApp = foldl AppE (ConE name) (map snd vars)
return (pat, conApp)
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 ([TyVarBndr_ ()], Int)
tyConArity' n = reify n >>= return . \case
TyConI (DataD _ _ ts mk _ _) -> (ts, maybe 0 kindArity mk)
TyConI (NewtypeD _ _ ts mk _ _) -> (ts, maybe 0 kindArity mk)
_ -> error $ "tyConArity': Supplied name reified to something other than a data declaration: " ++ show n
restrictKeys :: Ord k => Map k v -> Set k -> Map k v
restrictKeys m s =
#if MIN_VERSION_containers(0,5,8)
Map.restrictKeys m s
#else
Map.intersection m $ Map.fromSet (const ()) s
#endif