From 5a529a03b0ea2a28a762f5735026670242c6c544 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Wed, 23 Jan 2019 13:52:55 -0500 Subject: [PATCH] Provide Data.Aeson.GADT from aeson-gadt-th's Data.Aeson.GADT.TH Fixes #28 --- common/Data/Aeson/GADT.hs | 154 ---------------------------------- common/default.nix | 3 +- common/rhyolite-common.cabal | 5 +- default.nix | 9 ++ dep/aeson-gadt-th/default.nix | 7 ++ dep/aeson-gadt-th/github.json | 7 ++ 6 files changed, 29 insertions(+), 156 deletions(-) delete mode 100644 common/Data/Aeson/GADT.hs create mode 100644 dep/aeson-gadt-th/default.nix create mode 100644 dep/aeson-gadt-th/github.json diff --git a/common/Data/Aeson/GADT.hs b/common/Data/Aeson/GADT.hs deleted file mode 100644 index a441664ce..000000000 --- a/common/Data/Aeson/GADT.hs +++ /dev/null @@ -1,154 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# 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 where - -import Control.Monad -import Data.Aeson -import Data.Dependent.Sum -import Data.Functor.Classes -import Data.Some (Some (..)) -import Language.Haskell.TH - -decCons :: Dec -> [Con] -decCons = \case - DataD _ _ _ _ cs _ -> cs - NewtypeD _ _ _ _ c _ -> [c] - _ -> error "undefined" - -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 - -{-# DEPRECATED deriveGADTInstances "Use deriveJSONGADT instead" #-} -deriveGADTInstances :: Name -> DecsQ -deriveGADTInstances = deriveJSONGADT - -deriveJSONGADT :: Name -> DecsQ -deriveJSONGADT n = do - tj <- deriveToJSONGADT n - fj <- deriveFromJSONGADT n - eqt <- deriveEqTag n - return (tj ++ fj ++ eqt) - -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) - |] - -deriveFromJSONGADT :: Name -> DecsQ -deriveFromJSONGADT n = do - x <- reify n - let cons = case x of - 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]) - |] - -deriveEqTag :: Name -> DecsQ -deriveEqTag n = do - x <- reify n - let cons = case x of - TyConI d -> decCons d - _ -> error "undefined" - [d| - instance Eq1 f => EqTag $(conT n) f where - eqTagged a b = $(caseE [|(a, b)|] $ concatMap conMatchesEqTagged cons) - |] - --- | 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" - 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 |]) - [] - ] - --- | 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) [] - - --- | Implementation of 'parseJSON' -conMatchesParseJSON :: ExpQ -> Con -> MatchQ -conMatchesParseJSON e c = do - let name = conName c - match' = match (litP (StringL (nameBase name))) - vars <- replicateM (conArity c) (newName "x") - let forTypes _ = do - let pat = tupP (map varP vars) - conApp = foldl appE (conE name) (map varE vars) - body = doE [ bindS pat [| parseJSON $e |] - , noBindS [| return (This $conApp) |] - ] - match' (normalB body) [] - 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" diff --git a/common/default.nix b/common/default.nix index 4f2c1bc81..b67697cd1 100644 --- a/common/default.nix +++ b/common/default.nix @@ -4,6 +4,7 @@ , mime-mail, monad-control, monad-logger, monoidal-containers, mtl , network-uri, reflex, resource-pool, stdenv, template-haskell , text, these, time, transformers, transformers-base, vector +, aeson-gadt-th , hostPlatform }: mkDerivation { @@ -16,7 +17,7 @@ mkDerivation { dependent-sum file-embed filepath http-types mime-mail monad-control monoidal-containers mtl network-uri reflex resource-pool template-haskell text these time transformers - transformers-base vector + transformers-base vector aeson-gadt-th ] ++ (if hostPlatform.libc == "bionic" || hostPlatform.isAarch64 then [] else [ monad-logger ]); diff --git a/common/rhyolite-common.cabal b/common/rhyolite-common.cabal index f1fdb378d..fb2309b9e 100644 --- a/common/rhyolite-common.cabal +++ b/common/rhyolite-common.cabal @@ -13,6 +13,7 @@ library build-depends: aeson + , aeson-gadt-th , async , attoparsec , base @@ -41,7 +42,6 @@ library , vector exposed-modules: - Data.Aeson.GADT Data.MonoidMap Rhyolite.Account Rhyolite.Api @@ -58,6 +58,9 @@ library Rhyolite.TH Rhyolite.WebSocket + reexported-modules: + aeson-gadt-th:Data.Aeson.GADT.TH as Data.Aeson.GADT + if !os(ios) && !arch(aarch64) && !arch(arm) && !impl(ghcjs) build-depends: monad-logger other-extensions: TemplateHaskell diff --git a/default.nix b/default.nix index 78e9bae9d..05ea712cc 100644 --- a/default.nix +++ b/default.nix @@ -21,7 +21,16 @@ let }; }; + # TODO use `hackGet`, or even better `thunkSet` for all of them. + # (Both are from reflex-platform.) srcs = { + # TODO bump cabal hashes and use Hackage version. + aeson-gadt-th = let + json = builtins.fromJSON (builtins.readFile ./dep/aeson-gadt-th/github.json); + in pkgs.fetchFromGitHub { + inherit (json) owner repo rev sha256; + private = json.private or false; + }; constraints-extras = pkgs.fetchFromGitHub { owner = "obsidiansystems"; repo = "constraints-extras"; diff --git a/dep/aeson-gadt-th/default.nix b/dep/aeson-gadt-th/default.nix new file mode 100644 index 000000000..7a0477867 --- /dev/null +++ b/dep/aeson-gadt-th/default.nix @@ -0,0 +1,7 @@ +# DO NOT HAND-EDIT THIS FILE +import ((import {}).fetchFromGitHub ( + let json = builtins.fromJSON (builtins.readFile ./github.json); + in { inherit (json) owner repo rev sha256; + private = json.private or false; + } +)) diff --git a/dep/aeson-gadt-th/github.json b/dep/aeson-gadt-th/github.json new file mode 100644 index 000000000..fb7650244 --- /dev/null +++ b/dep/aeson-gadt-th/github.json @@ -0,0 +1,7 @@ +{ + "owner": "obsidiansystems", + "repo": "aeson-gadt-th", + "branch": "master", + "rev": "f4c173747c8b83cb201975b5ce8c9c7e33f9b7fc", + "sha256": "18dva9sgg93s79m973qmc1j52jard6yq3ficxhwmzzy5yri6rry6" +}