aeson-gadt-th (empty) → 0.1.0.0

raw patch · 4 files changed

+199/−0 lines, 4 filesdep +aesondep +basedep +dependent-sumsetup-changed

Dependencies added: aeson, base, dependent-sum, template-haskell

Files

LICENSE +30/−0
Setup.hs +2/−0
aeson-gadt-th.cabal +25/−0
src/Data/Aeson/GADT/TH.hs +142/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2019, Obsidian Systems LLC++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Obsidian Systems LLC nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ aeson-gadt-th.cabal view

@@ -0,0 +1,25 @@+cabal-version: >=1.10+name: aeson-gadt-th+version: 0.1.0.0+synopsis: Derivation of Aeson instances for GADTs+category: JSON+description: Template Haskell for generating ToJSON and FromJSON instances for GADTs+license: BSD3+license-file: LICENSE+author: Obsidian Systems LLC+maintainer: maintainer@obsidian.systems+copyright: 2019 Obsidian Systems LLC+build-type: Simple++library+  exposed-modules: Data.Aeson.GADT.TH+  build-depends: base >= 4.8 && < 4.13+               , aeson+               , dependent-sum+               , template-haskell+  hs-source-dirs: src+  default-language: Haskell2010++source-repository head+  type:     git+  location: git://github.com/obsidiansystems/aeson-gadt-th.git

+ src/Data/Aeson/GADT/TH.hs view

@@ -0,0 +1,142 @@+{-# 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 where++import Control.Monad+import Data.Aeson+import Data.Dependent.Sum+import Data.Functor.Classes+import Data.Some (Some (..))+import Language.Haskell.TH++-- | Derive 'ToJSON' and 'FromJSON' instances for the name GADT+deriveJSONGADT :: Name -> DecsQ+deriveJSONGADT n = do+  tj <- deriveToJSONGADT n+  fj <- deriveFromJSONGADT n+  return (tj ++ fj)++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++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])+    |]++-- | 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"