diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Silk + +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 Silk 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/generic-aeson.cabal b/generic-aeson.cabal new file mode 100644 --- /dev/null +++ b/generic-aeson.cabal @@ -0,0 +1,31 @@ +name: generic-aeson +version: 0.1 +synopsis: Derivation of Aeson instances using GHC generics. +description: Derivation of Aeson instances using GHC generics. +author: Silk +maintainer: code@silk.co +license: BSD3 +license-file: LICENSE +category: Data +build-type: Simple +cabal-version: >=1.8 + +library + hs-source-dirs: src + ghc-options: -Wall + exposed-modules: + Generics.Generic.IsEnum + Generics.Generic.Aeson + build-depends: + base >= 4 && < 4.7 + , aeson >= 0.6 && < 0.8 + , generic-deriving == 1.6.* + , mtl >= 2.0 && < 2.2 + , tagged >= 0.2 && < 0.8 + , text >= 0.11 && < 1.2 + , vector == 0.10.* + , attoparsec + +source-repository head + type: Git + location: https://github.com/silkapp/generic-aeson.git diff --git a/src/Generics/Generic/Aeson.hs b/src/Generics/Generic/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Generic/Aeson.hs @@ -0,0 +1,239 @@ +{-# LANGUAGE + CPP + , DeriveGeneric + , FlexibleContexts + , FlexibleInstances + , MultiParamTypeClasses + , OverlappingInstances + , OverloadedStrings + , ScopedTypeVariables + , TupleSections + , TypeOperators + , TypeSynonymInstances + , InstanceSigs + #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | This module offers generic conversions to an from JSON 'Value's +-- for data types with a 'Generic' instance. +-- +-- The structure of the generated JSON is meant to be close to +-- idiomatic JSON. This means: +-- +-- * Enumerations are converted to JSON strings. +-- +-- * Record fields become JSON keys. +-- +-- * Data types with one unlabeled field convert to just that field. +-- +-- * Data types with multiple unlabeled fields become arrays. +-- +-- * Multiple constructors are represented by keys. +-- +-- * 'Maybe' values are either an absent key, or the value. +-- +-- See 'examples/Examples.hs' for more examples. +module Generics.Generic.Aeson + ( gtoJson + , gparseJson + , GtoJson (..) + , GfromJson (..) + ) where + +import Control.Applicative +import Control.Monad.Error +import Control.Monad.State +import Data.Aeson +import Data.Aeson.Types hiding (GFromJSON, GToJSON) +import Data.Char +import Data.Maybe +import Data.Proxy +import Data.Text (Text, cons, pack, stripPrefix, stripSuffix, uncons, unpack) +import GHC.Generics +import Generics.Deriving.ConNames +import qualified Data.Vector as V + +import Generics.Generic.IsEnum + +-- | Class for converting the functors from "GHC.Generics" to JSON. +-- You generally don't need to give any custom instances. Just add +-- 'deriving Generic' and call 'gToJson'. +class GtoJson f where + -- | Generically show a functor as a JSON value. The first argument + -- tells us if there are multiple constructors in the data type. The + -- second indicates if this data type is an enumeration (only empty + -- constructors). A functor is then converted to either a list + -- of values (for non-labeled fields) or a list of String/value + -- pairs (for labeled fields). + gtoJSONf :: Bool -> Bool -> f a -> Either [Value] [(Text, Value)] + +-- | Class for parsing the functors from "GHC.Generics" from JSON. +-- You generally don't need to give any custom instances. Just add +-- 'deriving Generic' and call 'gFromJson'. +class GfromJson f where + -- | Generically read a functor from a JSON value. The first + -- argument tells us if there are multiple constructors in the data + -- type. The second indicates if we've already detected that this + -- data type has multiple constructors. When this is False, the + -- (:*:) puts the fields in the state. The third indicates if this + -- data type is an enumeration (only empty constructors). The third + -- is a function for parsing the recursive positions. A JSON value + -- is then parsed to either a functor, or a failure. + gparseJSONf :: Bool -> Bool -> Bool -> StateT [Value] Parser (f a) + +-- Void: Used for data types without constructors +-- instance GJSON V1 + +-- Unit: Used for constructors without arguments +instance GtoJson U1 where + gtoJSONf _ _ U1 = Right [] +instance GfromJson U1 where + gparseJSONf _ _ _ = return U1 + +-- | Convert any datatype with a 'Generic' instance to a JSON 'Value'. +gtoJson :: forall a. (Generic a, GtoJson (Rep a), ConNames (Rep a), GIsEnum (Rep a)) + + => a -> Value +gtoJson x = + case gtoJSONf (multipleConstructors x) (isEnum (Proxy :: Proxy a)) (from x) of + Left [v] -> v + Left _ -> error "The impossible happened: multiple returned values in gtoJSON." + Right _ -> error "The impossible happened: labeled values returned in gtoJSON." + +-- | Parse any datatype with a 'Generic' instance from a JSON 'Value'. +gparseJson :: forall a. (Generic a, GfromJson (Rep a), ConNames (Rep a), GIsEnum (Rep a)) + => Value -> Parser a +gparseJson + = fmap to + . evalStateT (gparseJSONf (multipleConstructors (undefined :: a)) False (isEnum (Proxy :: Proxy a))) + . return + +-- Structure type for constant values. +instance (ToJSON c) => GtoJson (K1 a c) where + gtoJSONf _ _ (K1 a) = Left [toJSON a] +instance (FromJSON c) => GfromJson (K1 a c) where + gparseJSONf _ _ _ = lift . fmap K1 . parseJSON =<< pop + +instance (GtoJson f, GtoJson g) => GtoJson (f :+: g) where + gtoJSONf mc enm (L1 x) = gtoJSONf mc enm x + gtoJSONf mc enm (R1 x) = gtoJSONf mc enm x +instance (GfromJson f, GfromJson g) => GfromJson (f :+: g) where + gparseJSONf mc smf enm = L1 <$> gparseJSONf mc smf enm + <|> R1 <$> gparseJSONf mc smf enm + +instance (GtoJson f, GtoJson g) => GtoJson (f :*: g) where + gtoJSONf mc enm (x :*: y) = + case (gtoJSONf mc enm x, gtoJSONf mc enm y) of + (Left xvs, Left yvs) -> Left (xvs ++ yvs) + (Right xvs, Right yvs) -> Right (xvs ++ yvs) + _ -> error "The impossible happened: product of mixed label and non-label fields in GJSON instance for (:*:)." +instance (GfromJson f, GfromJson g) => GfromJson (f :*: g) where + gparseJSONf mc smf enm = + do unless smf selFields + (:*:) <$> gparseJSONf mc True enm <*> gparseJSONf mc True enm + where + selFields = + do v <- pop + case v of + o@Object{} -> put (repeat o) + Array vs -> put (V.toList vs) + _ -> fail "Expected object or array in gparseJSONf for (:*:)." + +instance (Selector c, ToJSON a) => GtoJson (M1 S c (K1 i (Maybe a))) where + gtoJSONf _ _ (M1 (K1 Nothing )) = Right [] + gtoJSONf _ _ (M1 (K1 (Just x))) = Right [(formatLabel . pack $ selName (undefined :: M1 S c f p), toJSON x)] +instance (Selector c, FromJSON a) => GfromJson (M1 S c (K1 i (Maybe a))) where + gparseJSONf mc smf enm = + do (M1 (K1 x)) <- gparseJSONf mc smf enm :: StateT [Value] Parser (M1 S c (K1 i a) p) + return (M1 (K1 (Just x))) + <|> + return (M1 (K1 Nothing)) + +instance GtoJson f => GtoJson (M1 D c f) where + gtoJSONf a b (M1 x) = gtoJSONf a b x +instance GfromJson f => GfromJson (M1 D c f) where + gparseJSONf a b x = M1 <$> gparseJSONf a b x + +instance (Constructor c, GtoJson f) => GtoJson (M1 C c f) where + gtoJSONf _ True (M1 _) = Left [toJSON . formatLabel . pack $ conName (undefined :: M1 C c f p)] + gtoJSONf mc False (M1 x) = + case gtoJSONf mc False x of + -- Single field constructors are not wrapped in an array. + Left [v] -> Left [wrap v] + Left vs -> Left [wrap . Array $ V.fromList vs] + Right vs -> Left [wrap $ toObject vs] + where + wrap = if mc + then toObject + . return + . (formatLabel . pack $ conName (undefined :: M1 C c f p), ) + else id +instance (Constructor c, GfromJson f) => GfromJson (M1 C c f) where + gparseJSONf mc smf True = + do str <- pop + conStr <- lift (parseJSON str) + let expectedConStr = formatLabel . pack $ conName (undefined :: M1 C c f p) + unless (conStr == expectedConStr) $ + fail $ "Error parsing enumeration: expected " ++ unpack expectedConStr ++ ", found " ++ unpack conStr ++ "." + M1 <$> gparseJSONf mc smf True + gparseJSONf mc smf False = + do when mc (selProp "C" propName) + M1 <$> gparseJSONf mc smf False + where + propName = formatLabel . pack $ conName (undefined :: M1 C c f p) + +instance (Selector c, GtoJson f) => GtoJson (M1 S c f) where + gtoJSONf mc enm (M1 x) = + case gtoJSONf mc enm x of + Left [v] -> case formatLabel . pack $ selName (undefined :: M1 S c f p) of + "" -> Left [v] + n -> Right [(n, v)] + Left _ -> error "The impossible happened: multiple returned values inside label in GJSON instance for S." + Right _ -> error "The impossible happened: label inside a label in GJSON instance for S." +instance (Selector c, GfromJson f) => GfromJson (M1 S c f) where + gparseJSONf mc smf enm = + do selProp "S" propName + M1 <$> gparseJSONf mc smf enm + where + propName = formatLabel . pack $ selName (undefined :: M1 S c f p) + +multipleConstructors :: (Generic a, ConNames (Rep a)) => a -> Bool +multipleConstructors = (> 1) . length . conNames + +selProp :: Text -> Text -> StateT [Value] Parser () +selProp cname propName = + case propName of + "" -> do o <- pop + modify (o:) + _ -> do o <- pop + v <- lift (withObject ("Expected property " ++ show propName ++ " in object in gparseJSONf for " ++ show cname ++ ".") + (.: propName) o) + modify (v:) + +pop :: MonadState [Value] m => m Value +pop = + do (v:vs) <- get + put vs + return v + +formatLabel :: Text -> Text +formatLabel = id firstLetterToLower + . stripLeadingAndTrailingUnderscore + +stripLeadingAndTrailingUnderscore :: Text -> Text +stripLeadingAndTrailingUnderscore = stripLeadingUnderscore + . stripTrailingUnderscore + +stripLeadingUnderscore :: Text -> Text +stripLeadingUnderscore x = maybe x stripLeadingUnderscore $ stripPrefix "_" x + +stripTrailingUnderscore :: Text -> Text +stripTrailingUnderscore x = fromMaybe x $ stripSuffix "_" x + +firstLetterToLower :: Text -> Text +firstLetterToLower tx = + case uncons tx of + Nothing -> "" + Just (c, t) -> cons (toLower c) t + +toObject :: ToJSON v => [(Text, v)] -> Value +toObject = object . map (uncurry (.=)) diff --git a/src/Generics/Generic/IsEnum.hs b/src/Generics/Generic/IsEnum.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Generic/IsEnum.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE + FlexibleContexts + , FlexibleInstances + , ScopedTypeVariables + , TypeOperators + #-} +-- | Test if a data type is an enumeration (only zero-argument +-- constructors) generically using "GHC.Generics". +module Generics.Generic.IsEnum + ( isEnum + , GIsEnum (..) + ) where + +import Data.Proxy + +import GHC.Generics + +-- | Class for testing if the functors from "GHC.Generics" are +-- enumerations. You generally don't need to give any custom +-- instances. Just call 'isEnum'. +class GIsEnum f where + gIsEnum :: Proxy (f a) -> Bool + + +instance GIsEnum V1 where + gIsEnum _ = False + +instance GIsEnum (K1 i a) where + gIsEnum _ = False + +instance GIsEnum U1 where + gIsEnum _ = True + +instance GIsEnum Par1 where + gIsEnum _ = False + +-- should be K1 R +instance GIsEnum (Rec1 f) where + gIsEnum _ = False + + +instance (GIsEnum f, GIsEnum g) => GIsEnum (f :+: g) where + gIsEnum _ = gIsEnum (Proxy :: Proxy (f a)) && gIsEnum (Proxy :: Proxy (g a)) + +instance (GIsEnum f, GIsEnum g) => GIsEnum (f :*: g) where + gIsEnum _ = False + +instance GIsEnum f => GIsEnum (M1 C c f) where + gIsEnum _ = gIsEnum (Proxy :: Proxy (f a)) + +instance GIsEnum (M1 S c a) where + gIsEnum _ = False + +instance GIsEnum f => GIsEnum (M1 D c f) where + gIsEnum _ = gIsEnum (Proxy :: Proxy (f a)) + +-- instance GIsEnum (f :.: g) where + +-- | Generically test if a data type is an enumeration. +isEnum :: forall a. (Generic a, GIsEnum (Rep a)) => Proxy a -> Bool +isEnum _ = gIsEnum (Proxy :: Proxy ((Rep a) a))