aeson-gadt-th 0.1.1.0 → 0.1.2.0

raw patch · 4 files changed

+216/−74 lines, 4 filesdep +aeson-gadt-thdep +markdown-unlitdep +transformersdep ~basedep ~dependent-sumnew-component:exe:readmePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: aeson-gadt-th, markdown-unlit, transformers

Dependency ranges changed: base, dependent-sum

API changes (from Hackage documentation)

Files

• README.lhs +48/−0
• README.md +48/−0
• aeson-gadt-th.cabal +13/−1
• src/Data/Aeson/GADT/TH.hs +107/−73

@@ -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+```

@@ -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+```

@@ -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 <https://github.com/obsidiansystems/aeson-gadt-th/blob/master/README.md README.md> 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

@@ -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