diff --git a/README.lhs b/README.lhs new file mode 100644 --- /dev/null +++ b/README.lhs @@ -0,0 +1,48 @@ +# aeson-gadt-th + +Provides Template Haskell expressions for deriving `ToJSON` and `FromJSON` instances for GADTs. + +## Example Usage: + +```haskell +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +import Data.Aeson +import Data.Aeson.GADT.TH + +data A :: * -> * where + A_a :: A a + A_b :: Int -> A () + +data B c :: * -> * where + B_a :: c -> A a -> B c a + B_x :: B c x + +deriveJSONGADT ''A +deriveJSONGADT ''B + +main :: IO () +main = return () +``` + +## Encoding: +``` +encode A_a +> "[\"A_a\",[]]" +``` + +## Decoding: + +When decoding a JSON-encoded GADT, the result will be wrapped using [Data.Some.This](http://hackage.haskell.org/package/dependent-sum-0.4/docs/Data-Some.html). +``` +case (decode $ encode A_a) :: Maybe (Some A) of + Nothing -> error "Couldn't decode + Just (This A_a) -> putStrLn "it worked" + Just (This A_b) -> putStrLn "wat" +> it worked +``` diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,48 @@ +# aeson-gadt-th + +Provides Template Haskell expressions for deriving `ToJSON` and `FromJSON` instances for GADTs. + +## Example Usage: + +```haskell +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +import Data.Aeson +import Data.Aeson.GADT.TH + +data A :: * -> * where + A_a :: A a + A_b :: Int -> A () + +data B c :: * -> * where + B_a :: c -> A a -> B c a + B_x :: B c x + +deriveJSONGADT ''A +deriveJSONGADT ''B + +main :: IO () +main = return () +``` + +## Encoding: +``` +encode A_a +> "[\"A_a\",[]]" +``` + +## Decoding: + +When decoding a JSON-encoded GADT, the result will be wrapped using [Data.Some.This](http://hackage.haskell.org/package/dependent-sum-0.4/docs/Data-Some.html). +``` +case (decode $ encode A_a) :: Maybe (Some A) of + Nothing -> error "Couldn't decode + Just (This A_a) -> putStrLn "it worked" + Just (This A_b) -> putStrLn "wat" +> it worked +``` diff --git a/aeson-gadt-th.cabal b/aeson-gadt-th.cabal --- a/aeson-gadt-th.cabal +++ b/aeson-gadt-th.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: aeson-gadt-th -version: 0.1.1.0 +version: 0.1.2.0 synopsis: Derivation of Aeson instances for GADTs category: JSON description: Template Haskell for generating ToJSON and FromJSON instances for GADTs. See for examples. @@ -10,15 +10,27 @@ maintainer: maintainer@obsidian.systems copyright: 2019 Obsidian Systems LLC build-type: Simple +extra-source-files: README.md library exposed-modules: Data.Aeson.GADT.TH build-depends: base >= 4.8 && < 4.13 , aeson , dependent-sum + , transformers , template-haskell hs-source-dirs: src default-language: Haskell2010 + +executable readme + build-depends: base + , aeson + , dependent-sum + , aeson-gadt-th + , markdown-unlit + default-language: Haskell2010 + main-is: README.lhs + ghc-options: -pgmL markdown-unlit -Wall source-repository head type: git diff --git a/src/Data/Aeson/GADT/TH.hs b/src/Data/Aeson/GADT/TH.hs --- a/src/Data/Aeson/GADT/TH.hs +++ b/src/Data/Aeson/GADT/TH.hs @@ -15,16 +15,18 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -module Data.Aeson.GADT.TH where +module Data.Aeson.GADT.TH (deriveJSONGADT, deriveToJSONGADT, deriveFromJSONGADT) where import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Writer import Data.Aeson -import Data.Dependent.Sum -import Data.Functor.Classes +import Data.List +import Data.Maybe import Data.Some (Some (..)) import Language.Haskell.TH --- | Derive 'ToJSON' and 'FromJSON' instances for the name GADT +-- | Derive 'ToJSON' and 'FromJSON' instances for the named GADT deriveJSONGADT :: Name -> DecsQ deriveJSONGADT n = do tj <- deriveToJSONGADT n @@ -56,20 +58,33 @@ GadtC _ ts _ -> length ts RecGadtC _ ts _ -> length ts -{-# DEPRECATED deriveGADTInstances "Use deriveJSONGADT instead" #-} -deriveGADTInstances :: Name -> DecsQ -deriveGADTInstances = deriveJSONGADT - deriveToJSONGADT :: Name -> DecsQ deriveToJSONGADT n = do x <- reify n let cons = case x of TyConI d -> decCons d _ -> error "undefined" - [d| - instance ToJSON ($(conT n) a) where - toJSON r = $(caseE [|r|] $ map conMatchesToJSON cons) - |] + arity <- tyConArity n + tyVars <- replicateM arity (newName "topvar") + let n' = foldr (\v c -> AppT c (VarT v)) (ConT n) tyVars + (matches, typs) <- runWriterT (mapM (fmap pure . conMatchesToJSON tyVars) cons) + let nubbedTypes = map head . group . sort $ typs -- This 'head' is safe because 'group' returns a list of non-empty lists + constraints = map (AppT (ConT ''ToJSON)) nubbedTypes + impl <- funD (mkName "toJSON") + [ clause [] (normalB $ lamCaseE matches) [] + ] + return [ InstanceD Nothing constraints (AppT (ConT ''ToJSON) n') [impl] ] + +-- | Implementation of 'toJSON' +conMatchesToJSON :: [Name] -> Con -> WriterT [Type] Q Match +conMatchesToJSON topVars c = do + let name = conName c + base = 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 topVars c + lift $ match (conP name (map varP vars)) (normalB body) [] deriveFromJSONGADT :: Name -> DecsQ deriveFromJSONGADT n = do @@ -78,74 +93,93 @@ TyConI d -> decCons d _ -> error "undefined" let wild = match wildP (normalB [|fail "deriveFromJSONGADT: Supposedly-complete GADT pattern match fell through in generated code. This shouldn't happen."|]) [] - [d| - instance FromJSON (Some $(conT n)) where - parseJSON v = do - (tag', v') <- parseJSON v - $(caseE [|tag' :: String|] $ map (conMatchesParseJSON [|v'|]) cons ++ [wild]) - |] + arity <- tyConArity n + tyVars <- replicateM (arity - 1) (newName "topvar") + let n' = foldr (\v c -> AppT c (VarT v)) (ConT n) tyVars + (matches, typs) <- runWriterT $ mapM (conMatchesParseJSON tyVars [|_v'|]) cons + let nubbedTypes = map head . group . sort $ typs -- This 'head' is safe because 'group' returns a list of non-empty lists + constraints = map (AppT (ConT ''FromJSON)) nubbedTypes + 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] ] --- | Generate all required matches (and some redundant ones...) for `eqTagged` --- for some constructor -conMatchesEqTagged :: Con -> [MatchQ] -conMatchesEqTagged c = case c of - ForallC _ _ c' -> conMatchesEqTagged c' - GadtC _ tys _ -> forTypes (map snd tys) - _ -> error "conMatchesEqTagged: Unmatched constructor type" +substVarsWith + :: [Name] -- Names of variables used in the instance head in argument order + -> Type -- Result type of constructor + -> Type -- Type of argument to the constructor + -> Type -- Type of argument with variables substituted for instance head variables. +substVarsWith topVars (AppT resType _) = subst where - name = conName c - forTypes ts = - [ do - as <- mapM (\_ -> newName "a") ts - bs <- mapM (\_ -> newName "b") ts - x <- newName "x" - y <- newName "y" - let compareTagFields = foldr (\(a, b) e -> [| $(varE a) == $(varE b) && $(e) |]) [| True |] (zip as bs) - match - (tupP [conP name (map varP as), conP name (map varP bs)]) - (normalB (lamE [varP x, varP y] [| $(compareTagFields) && eq1 $(varE x) $(varE y) |] )) - [] - , match - (tupP [conP name (map (const wildP) ts), wildP]) - (normalB [| \ _ _ -> False |]) - [] - ] + topVars' = reverse topVars + subst = \case + AppT f x -> AppT (subst f) (subst x) + SigT t k -> SigT (subst t) k + VarT v -> VarT (findVar v topVars' resType) + InfixT t1 x t2 -> InfixT (subst t1) x (subst t2) + UInfixT t1 x t2 -> UInfixT (subst t1) x (subst t2) + ParensT t -> ParensT (subst t) + ConT n -> ConT n + x -> error $ "substVarsWith: Unhandled substitution case: " <> show x --- | Implementation of 'toJSON' -conMatchesToJSON :: Con -> MatchQ -conMatchesToJSON c = do - let name = conName c - base = nameBase name - toJSONExp e = [| toJSON $(e) |] - vars <- replicateM (conArity c) (newName "x") - let body = toJSONExp $ tupE [ [| base :: String |] , tupE $ map (toJSONExp . varE) vars ] - match (conP name (map varP vars)) (normalB body) [] + 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 +substVarsWith _ typ = error $ "substVarsWith: Unhandled result type: " <> show typ --- | Implementation of 'parseJSON' -conMatchesParseJSON :: ExpQ -> Con -> MatchQ -conMatchesParseJSON e c = do +conMatches + :: [Name] -- Names of variables used in the instance head in argument order + -> Con + -> WriterT [Type] Q (Pat, Exp) +conMatches topVars c = do let name = conName c - match' = match (litP (StringL (nameBase name))) - let forTypes types = do + forTypes types resultType = do vars <- forM types $ \typ -> do - x <- newName "x" + x <- lift $ newName "x" case typ of - AppT (ConT tn) (VarT vn) -> do + AppT (ConT tn) (VarT _) -> do -- This may be a nested GADT, so check for special FromJSON instance - idec <- reifyInstances ''FromJSON [AppT (ConT ''Some) (ConT tn)] - return $ case idec of - [] -> (VarP x, VarE x) - _ -> (ConP 'This [VarP x], VarE x) -- If a FromJSON instance is found for Some f, then we use it. - _ -> return (VarP x, VarE x) - let pat = return $ TupP (map fst vars) - conApp = return $ foldl AppE (ConE name) (map snd vars) - body = doE [ bindS pat [| parseJSON $e |] - , noBindS [| return (This $conApp) |] - ] - match' (normalB body) [] + idec <- lift $ reifyInstances ''FromJSON [AppT (ConT ''Some) (ConT tn)] + case idec of + [] -> do + tell [substVarsWith topVars resultType typ] + return (VarP x, VarE x) + _ -> return $ (ConP 'This [VarP x], VarE x) -- If a FromJSON instance is found for Some f, then we use it. + _ -> do + tell [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 _ _ c' -> conMatchesParseJSON e c' - GadtC _ tys _ -> forTypes (map snd tys) - NormalC _ tys -> forTypes (map snd tys) - _ -> error "conMatchesParseJSON: Unmatched constructor type" + ForallC _ _ c' -> conMatches topVars c' + GadtC _ tys t -> forTypes (map snd tys) t + --NormalC _ tys -> forTypes (map snd tys) -- nb: If this comes up in a GADT-style declaration, please open an issue on the github repo with an example. + _ -> error "conMatches: Unmatched constructor type" + +conMatchesParseJSON :: [Name] -> ExpQ -> Con -> WriterT [Type] Q Match +conMatchesParseJSON topVars e c = do + (pat, conApp) <- conMatches topVars c + let match' = match (litP (StringL (nameBase (conName c)))) + body = doE [ bindS (return pat) [| parseJSON $e |] + , noBindS [| return (This $(return conApp)) |] + ] + lift $ match' (normalB body) [] + +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 = reify n >>= return . \case + TyConI (DataD _ _ ts mk _ _) -> fromMaybe 0 (fmap kindArity mk) + length ts + _ -> error $ "tyConArity: Supplied name reified to something other than a data declaration: " <> show n