json-sop (empty) → 0.1.0.0
raw patch · 6 files changed
+684/−0 lines, 6 filesdep +aesondep +basedep +generics-sopsetup-changed
Dependencies added: aeson, base, generics-sop, lens-sop, tagged, text, time, transformers, unordered-containers, vector
Files
- LICENSE +27/−0
- Setup.hs +2/−0
- json-sop.cabal +63/−0
- src/Generics/SOP/JSON.hs +396/−0
- src/Generics/SOP/JSON/Model.hs +120/−0
- src/Generics/SOP/Util/PartialResult.hs +76/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2014, Well-Typed LLP, Edsko de Vries, Andres Löh+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the copyright holder nor the names of its 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 HOLDER 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
+ json-sop.cabal view
@@ -0,0 +1,63 @@+name: json-sop+version: 0.1.0.0+synopsis: Generics JSON (de)serialization using generics-sop+description:+ This library contains generic serialization and deserialization functions+ implemented using the @<https://hackage.haskell.org/generics-sop generics-sop>@+ package for use with @<http://hackage.haskell.org/aeson aeson>@.+ .+license: BSD3+license-file: LICENSE+author: Edsko de Vries <edsko@well-typed.com>, Andres Löh <andres@well-typed.com>+maintainer: edsko@well-typed.com+category: Generics+build-type: Simple+cabal-version: >=1.10+tested-with: GHC == 7.6.3, GHC == 7.8.2++source-repository head+ type: git+ location: https://github.com/well-typed/json-sop++library+ exposed-modules: Generics.SOP.JSON+ Generics.SOP.JSON.Model+ other-modules: Generics.SOP.Util.PartialResult+ build-depends: base >= 4.6 && < 5,+ generics-sop >= 0.1 && < 0.2,+ lens-sop >= 0.1 && < 0.2,+ tagged >= 0.7 && < 0.8,+ aeson >= 0.7 && < 0.8,+ vector >= 0.10 && < 0.11,+ text >= 1.1 && < 1.2,+ unordered-containers >= 0.2 && < 0.3,+ time >= 1.4 && < 1.5,+ transformers >= 0.3 && < 0.4+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall+ default-extensions: ScopedTypeVariables+ TypeFamilies+ RankNTypes+ TypeOperators+ GADTs+ ConstraintKinds+ MultiParamTypeClasses+ TypeSynonymInstances+ FlexibleInstances+ FlexibleContexts+ DeriveFunctor+ DeriveFoldable+ DeriveTraversable+ DefaultSignatures+ KindSignatures+ DataKinds+ FunctionalDependencies+ if impl (ghc >= 7.8)+ default-extensions: AutoDeriveTypeable+ other-extensions: OverloadedStrings+ OverlappingInstances+ PolyKinds+ UndecidableInstances+ TemplateHaskell+ CPP
+ src/Generics/SOP/JSON.hs view
@@ -0,0 +1,396 @@+{-# LANGUAGE PolyKinds, OverlappingInstances #-}+module Generics.SOP.JSON (+ -- * Configuration+ JsonFieldName+ , JsonTagName+ , JsonOptions(..)+ , defaultJsonOptions+ -- * JSON view of a datatype+ , Tag(..)+ , JsonInfo(..)+ , jsonInfo+ -- * Generic functions+ , gtoJSON+ , gparseJSON+ -- * UpdateFromJSON and co+ , UpdateFromJSON(..)+ , gupdateFromJSON+ , replaceWithJSON+ , parseWith+ -- * Re-exports+ , ToJSON(..)+ , FromJSON(..)+ , Proxy(..)+ ) where++import Control.Arrow (first)+import Control.Monad+import Data.Aeson (ToJSON(..), FromJSON(..), Value(..))+import Data.Aeson.Types (Parser, modifyFailure)+import Data.List (intercalate)+import Data.Text (Text)+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Text as Text+import qualified Data.Vector as Vector++import Generics.SOP+import Generics.SOP.Lens+import Generics.SOP.Util.PartialResult++{-------------------------------------------------------------------------------+ Configuration+-------------------------------------------------------------------------------}++type JsonFieldName = String+type JsonTagName = String++-- | JSON encoder/decoder configuration+data JsonOptions = JsonOptions {+ -- | Construct the name for JSON object fields (not for the tags that are+ -- used for sum-types, however)+ --+ -- The default just uses the name of the corresponding Haskell constructor+ jsonFieldName :: DatatypeName -> FieldName -> JsonFieldName++ -- | Construct the name for a tag for sum-types.+ --+ -- The default just uses the name of the Haskell constructor.+ , jsonTagName :: ConstructorName -> JsonTagName+ }++defaultJsonOptions :: JsonOptions+defaultJsonOptions = JsonOptions {+ jsonFieldName = const id+ , jsonTagName = id+ }++{-------------------------------------------------------------------------------+ The JSON view of the world++ We translate the metadata independent of the encoding/decoding. This has two+ advantages: it makes the encoder and decoder clearer, as they (and their+ types!) are driven by this metadata; and two, we can give a readable+ description of this metadata to give the user a static description of what+ the JSON encoding of their datatype will look like.+-------------------------------------------------------------------------------}++-- | Constructor tag+--+-- For a datatype with a single constructor we do not need to tag values with+-- their constructor; but for a datatype with multiple constructors we do.+data Tag = NoTag | Tag JsonTagName++data JsonInfo :: [*] -> * where+ -- Constructor without arguments+ --+ -- In this we _just_ output the name of the constructor (as a string);+ -- we do this even if the datatype has only a single argument.+ JsonZero :: ConstructorName -> JsonInfo '[]++ -- Single argument constructor+ -- This includes newtypes (record or not), but not other record constructors+ --+ -- We just output the argument, discarding the wrapping datatype+ JsonOne :: Tag -> JsonInfo '[a]++ -- Multiple argument constructor, but not a record+ --+ -- We output the arguments as a JSON array+ JsonMultiple :: SingI xs => Tag -> JsonInfo xs++ -- Record constructor+ --+ -- We output the arguments as a JSON object (even if there is only one field)+ JsonRecord :: SingI xs => Tag -> NP (K String) xs -> JsonInfo xs++jsonInfoFor :: forall xs. JsonOptions -> DatatypeName -> (ConstructorName -> Tag) -> ConstructorInfo xs -> JsonInfo xs+jsonInfoFor _ _ tag (Infix n _ _) = JsonMultiple (tag n)+jsonInfoFor _ _ tag (Constructor n) =+ case shape :: Shape xs of+ ShapeNil -> JsonZero n+ ShapeCons ShapeNil -> JsonOne (tag n)+ _ -> JsonMultiple (tag n)+jsonInfoFor opts d tag (Record n fields) =+ JsonRecord (tag n) (hliftA fieldName fields)+ where+ fieldName :: FieldInfo a -> K String a+ fieldName (FieldInfo name) = K (jsonFieldName opts d name)++jsonInfo :: forall a. (HasDatatypeInfo a, SingI (Code a))+ => Proxy a -> JsonOptions -> NP JsonInfo (Code a)+jsonInfo pa opts =+ case datatypeInfo pa of+ Newtype _ _ _ -> JsonOne NoTag :* Nil+ ADT _ n cs -> hliftA (jsonInfoFor opts n (tag cs)) cs+ where+ tag :: NP ConstructorInfo (Code a) -> ConstructorName -> Tag+ tag cs | _ :* Nil <- cs = const NoTag+ | otherwise = Tag . jsonTagName opts++{-------------------------------------------------------------------------------+ Encoder+-------------------------------------------------------------------------------}++gtoJSON :: forall a. (Generic a, HasDatatypeInfo a, All2 ToJSON (Code a))+ => JsonOptions -> a -> Value+gtoJSON opts a =+ unI . hcollapse $ hcliftA2' pt gtoJSON' (jsonInfo (Proxy :: Proxy a) opts)+ (unSOP $ from a)++gtoJSON' :: (All ToJSON xs, SingI xs) => JsonInfo xs -> NP I xs -> K Value xs+gtoJSON' (JsonZero n) Nil =+ K $ String (Text.pack n)+gtoJSON' (JsonOne tag) (I a :* Nil) =+ tagValue tag (toJSON a)+gtoJSON' (JsonMultiple tag) cs =+ tagValue tag+ . Array+ . Vector.fromList+ . hcollapse+ . hcliftA pt (K . toJSON . unI)+ $ cs+gtoJSON' (JsonRecord tag fields) cs =+ tagValue tag+ . Object+ . HashMap.fromList+ . hcollapse+ $ hcliftA2 pt (\(K field) (I a) -> K (Text.pack field, toJSON a)) fields cs+gtoJSON' _ _ = error "unreachable"++{-------------------------------------------------------------------------------+ Decoder++ NOTE: We use 'mzero' in various places, rather than failing with a more+ informative error message. The reason for this is that we constructor parsers+ for each of the constructors of a datatype, and then msum them together.+ If they all fail, we will get the error message from the last parser; if that+ says something like "missing field X" that might be very confusing if in fact+ we were trying to parse a different constructor altogether which may not+ even have a field X. If we want to fix this we have to restructure this+ so that we first find the right constructor, and then attempt to parse it.++ TODO: Maybe return a Parser of a Parser in parseValues?+-------------------------------------------------------------------------------}++gparseJSON :: forall a. (Generic a, HasDatatypeInfo a, All2 FromJSON (Code a))+ => JsonOptions -> Value -> Parser a+gparseJSON opts v = to `liftM` gparseJSON' v (jsonInfo (Proxy :: Proxy a) opts)++gparseJSON' :: forall (xss :: [[*]]). (All2 FromJSON xss, SingI xss)+ => Value -> NP JsonInfo xss -> Parser (SOP I xss)+gparseJSON' v info = runPartial failWith+ . msum+ . hcollapse+ $ hcliftA2' pf (parseConstructor v) info injs+ where+ failWith :: [String] -> Parser (SOP I xss)+ failWith [] = fail $ "Unknown error"+ failWith errs = fail $ intercalate " or " errs++ -- Necessary type annotation. Don't know why.+ injs :: NP (Injection (NP I) xss) xss+ injs = injections++parseConstructor :: forall (xss :: [[*]]) (xs :: [*]). (All FromJSON xs, SingI xs)+ => Value -> JsonInfo xs -> Injection (NP I) xss xs -> K (Partial Parser (SOP I xss)) xs+parseConstructor v info (Fn inj) = K $ do+ vals <- parseValues info v+ prod <- lift . hsequence $ hcliftA pf aux vals+ return $ SOP $ unK (inj prod)+ where+ aux :: FromJSON a => K (Maybe String, Value) a -> Parser a+ aux (K (Just fieldName, val)) = modifyFailure (\str -> fieldName ++ ": " ++ str) $ parseJSON val+ aux (K (Nothing, val)) = parseJSON val++-- | Given information about a constructor, check if the given value has the+-- right shape, and if so, return a product of (still encoded) values for+-- each of the arguments of the constructor+parseValues :: forall (xs :: [*]). SingI xs+ => JsonInfo xs -> Value -> Partial Parser (NP (K (Maybe String, Value)) xs)+parseValues (JsonZero n) =+ withText ("Expected literal " ++ show n) $ \txt -> do+ guard $ Text.unpack txt == n+ return Nil+parseValues (JsonOne tag) =+ untag tag $ \v ->+ return (K (Nothing, v) :* Nil)+parseValues (JsonMultiple tag) =+ untag tag $ withArray "Array" $ \arr -> do+ case fromList (map (\v -> (Nothing, v)) arr) of+ Just values -> return values+ Nothing -> fail $ "Got " ++ show (length arr) ++ "values, "+ ++ "expected " ++ show (lengthSing (Proxy :: Proxy xs))+parseValues (JsonRecord tag fields) =+ untag tag $ withObject "Object" $ \obj -> do+ values <- hsequenceK =<< lineup fields obj+ return $ hliftA2 pairFieldName fields values+ where+ pairFieldName (K x) (K y) = K (Just x, y)++untag :: (Monad m, Functor m) => Tag -> (Value -> Partial m a) -> Value -> Partial m a+untag NoTag f = f+untag (Tag n) f = withObject "Object" $ \obj ->+ case obj of+ [(n', v)] | n' == n -> partialResult $ f v+ _ -> fail $ "Expected tag " ++ show n++{-------------------------------------------------------------------------------+ Updating values+-------------------------------------------------------------------------------}++-- | For some values we can support "updating" the value with a "partial"+-- JSON value; record types are the prime example (and the only one supported+-- by the generic function). For non-record types we typically can only+-- replace the value with a "complete" JSON value; in this case, we simply+-- ignore the old value (see 'replaceWithJSON'). Typical class instances will+-- look like+--+-- > instance UpdateFromJSON SomeRecordType where+-- > updateFromJSON = gupdateFromJSON <jsonOptions>+--+-- or+--+-- > instance UpdateFromJSON SomeNonRecordType where+-- > updateFromJSON = replaceWithJSON+--+-- NOTE: The generic function uses one-level lenses for the object fields.+-- We could generalize this to arbitrary paths, but then the type would change+-- to+--+-- > updateFromJSON :: Value -> Parser (a -> UpdateM a)+--+-- I.e., updating a value from JSON would, in general, involve a database+-- write.+class UpdateFromJSON a where+ updateFromJSON :: Value -> Parser (a -> a)++-- | For types that we can only replace "whole", rather than update field by field+replaceWithJSON :: FromJSON a => Value -> Parser (a -> a)+replaceWithJSON v = parseJSON v >>= \new -> return $ \_old -> new++-- | Conversely, for types that we can only parse if we have a starting point+parseWith :: UpdateFromJSON a => a -> Value -> Parser a+parseWith a = liftM ($ a) . updateFromJSON++instance FromJSON a => UpdateFromJSON [a] where updateFromJSON = replaceWithJSON+instance FromJSON a => UpdateFromJSON (Maybe a) where updateFromJSON = replaceWithJSON++-- Primitive types we can only replace whole+instance UpdateFromJSON Int where updateFromJSON = replaceWithJSON+instance UpdateFromJSON Double where updateFromJSON = replaceWithJSON+instance UpdateFromJSON Rational where updateFromJSON = replaceWithJSON+instance UpdateFromJSON Bool where updateFromJSON = replaceWithJSON+instance UpdateFromJSON Text where updateFromJSON = replaceWithJSON+instance UpdateFromJSON String where updateFromJSON = replaceWithJSON++{-------------------------------------------------------------------------------+ Generic instance for UpdateFromJSON+-------------------------------------------------------------------------------}++-- | Construct a function that updates a value of some record type, given+-- a JSON object with new values for some (or none, or all) of the fields+gupdateFromJSON :: forall a xs. (Generic a, HasDatatypeInfo a, All UpdateFromJSON xs, Code a ~ '[xs])+ => JsonOptions -> Value -> Parser (a -> a)+gupdateFromJSON opts v = do+ case jsonInfo (Proxy :: Proxy a) opts of+ JsonRecord _ fields :* Nil -> gupdateRecord fields glenses v+ _ :* Nil -> error "cannot update non-record type"+ _ -> error "inaccessible"++gupdateRecord :: forall (xs :: [*]) (a :: *). (All UpdateFromJSON xs, SingI xs)+ => NP (K String) xs -> NP (GLens (->) (->) a) xs -> Value -> Parser (a -> a)+gupdateRecord fields lenses = withObject "Object" $ \obj -> do+ values :: NP (K (Maybe Value)) xs <- lineup fields obj+ updates <- hcollapse `liftM` hsequenceK (hcliftA2 pu update values lenses)+ return $ foldr (.) id updates+ where+ update :: forall b. UpdateFromJSON b+ => K (Maybe Value) b -> GLens (->) (->) a b -> K (Parser (a -> a)) b+ update (K Nothing) _ = K $ return id+ update (K (Just v)) l = K $ do f <- updateFromJSON v+ return $ \a -> modify l (f, a)++{-------------------------------------------------------------------------------+ Auxiliary+-------------------------------------------------------------------------------}++-- | Given a product of keys in a particular order, and a list of values indexed+-- by keys, reorder the second list in the order specified by the first list.+-- Unexpected keys make the whole thing fail (outer monad @m@); missing keys+-- make the inner monad fail @m'@.+--+-- The following are instances of this type+--+-- > NP (K String) xs -> [(String, Value)] -> Parser (NP (K (Parser Value)) xs)+-- > NP (K String) xs -> [(String, Value)] -> Parser (NP (K (Maybe Value)) xs)+--+-- The first form is useful when all fields of a record need to be present;+-- the second when they are optional.+lineup :: (Monad m, MonadPlus m', Eq a, Show a)+ => NP (K a) xs -> [(a, b)] -> m (NP (K (m' b)) xs)+lineup Nil [] = return Nil+lineup Nil vals = fail $ "Unexpected key(s): " ++ show (map fst vals)+lineup (K k :* ks) [] = do bs <- lineup ks [] ; return $ K (missingKey k) :* bs+lineup (K k :* ks) vs =+ case remove ((== k) . fst) vs of+ Nothing -> do bs <- lineup ks vs ; return $ K (missingKey k) :* bs+ Just ((_, b), vs') -> do bs <- lineup ks vs' ; return $ K (return b) :* bs++-- | Error message for a missing key (used in lineup)+missingKey :: (Monad m, Show a) => a -> m b+missingKey k = fail $ "missing key " ++ show k++-- | Remove the first element that satisfies the predicate+remove :: (a -> Bool) -> [a] -> Maybe (a, [a])+remove _ [] = Nothing+remove f (x:xs) | f x = Just (x, xs)+ | otherwise = do (y, ys) <- remove f xs ; return (y, x:ys)++tagValue :: Tag -> Value -> K Value a+tagValue NoTag v = K v+tagValue (Tag t) v = K $ Object $ HashMap.fromList [(Text.pack t, v)]++{-------------------------------------------------------------------------------+ Constraint proxies+-------------------------------------------------------------------------------}++pt :: Proxy ToJSON+pt = Proxy++pf :: Proxy FromJSON+pf = Proxy++pu :: Proxy UpdateFromJSON+pu = Proxy++{-------------------------------------------------------------------------------+ Adaptation of some of Aeson's combinators+-------------------------------------------------------------------------------}++withObject :: Monad m => String -> ([(String, Value)] -> m a) -> Value -> m a+withObject _ f (Object obj) = f $ map (first Text.unpack) (HashMap.toList obj)+withObject expected _ v = typeMismatch expected v++withText :: Monad m => String -> (Text -> m a) -> Value -> m a+withText _ f (String txt) = f txt+withText expected _ v = typeMismatch expected v++withArray :: Monad m => String -> ([Value] -> m a) -> Value -> m a+withArray _ f (Array arr) = f $ Vector.toList arr+withArray expected _ v = typeMismatch expected v++typeMismatch :: Monad m+ => String -- ^ The name of the type you are trying to parse.+ -> Value -- ^ The actual value encountered.+ -> m a+typeMismatch expected actual =+ fail $ "when expecting a " ++ expected ++ ", encountered " ++ name +++ " instead"+ where+ name = case actual of+ Object _ -> "Object"+ Array _ -> "Array"+ String _ -> "String"+ Number _ -> "Number"+ Bool _ -> "Boolean"+ Null -> "Null"
+ src/Generics/SOP/JSON/Model.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE OverloadedStrings, OverlappingInstances #-}+module Generics.SOP.JSON.Model (+ JsonModel(..)+ , gjsonModel+ -- * Re-exports+ , Tagged(..)+ , untag+ ) where++import Data.Aeson+import Data.Tagged+import qualified Data.Text as Text+import qualified Data.Text.Lazy as Text.Lazy+import qualified Data.Vector as Vector++import Generics.SOP+import Generics.SOP.JSON++-- For instances only+import Data.Time (UTCTime)+import Data.Text (Text)++class JsonModel (a :: *) where+ jsonModel :: Tagged a Value++{-------------------------------------------------------------------------------+ Some standard instances+-------------------------------------------------------------------------------}++instance JsonModel UTCTime where+ jsonModel = Tagged $ String "UTCTime"++instance JsonModel Text where+ jsonModel = Tagged $ String "String"++instance JsonModel Text.Lazy.Text where+ jsonModel = Tagged $ String "String"++instance JsonModel String where+ jsonModel = Tagged $ String "String"++instance JsonModel Int where+ jsonModel = Tagged $ String "Int"++instance JsonModel Double where+ jsonModel = Tagged $ String "Double"++instance JsonModel Rational where+ jsonModel = Tagged $ String "Rational"++instance JsonModel Bool where+ jsonModel = Tagged $ String "Bool"++instance JsonModel a => JsonModel [a] where+ jsonModel = let model :: Tagged a Value+ model = jsonModel+ in Tagged $ object [ "List" .= untag model ]++instance JsonModel a => JsonModel (Maybe a) where+ jsonModel = let model :: Tagged a Value+ model = jsonModel+ in Tagged $ Array $ Vector.fromList [ untag model, Null ]++{-------------------------------------------------------------------------------+ Generic instance+-------------------------------------------------------------------------------}++-- | Generic computation of the JSON model+--+-- Do NOT use for recursive types, you will get an infinite model.+gjsonModel :: forall a. (HasDatatypeInfo a, All2 JsonModel (Code a), SingI (Code a))+ => JsonOptions -> Tagged a Value+gjsonModel opts = unproxy $ \pa -> gjsonModel' (jsonInfo pa opts)++gjsonModel' :: (All2 JsonModel xss, SingI xss) => NP JsonInfo xss -> Value+gjsonModel' = mkValue . hcollapse . hcliftA' p (K . constructorModel)+ where+ -- In the case of a single-argument datatype, just return the type of+ -- the constructor, rather than a singleton list of types+ mkValue :: [Value] -> Value+ mkValue [v] = v+ mkValue vs = Array $ Vector.fromList vs++constructorModel :: forall xs. All JsonModel xs => JsonInfo xs -> Value+constructorModel (JsonZero n) =+ object [ "Literal" .= toJSON n ]+constructorModel info@(JsonOne t) = tagModel t $+ constructorModelOne info+constructorModel (JsonMultiple t) = tagModel t $+ object [ "Tuple" .= (tupleModel . hcollapse $ aux) ]+ where+ aux :: (SingI xs, All JsonModel xs) => NP (K Value) xs+ aux = hcpure p jsonModelK+constructorModel (JsonRecord t fs) = tagModel t $+ object [ "Object" .= (objectModel . hcollapse . hcliftA p aux $ fs) ]+ where+ aux :: forall a. JsonModel a => K String a -> K (Text, Value) a+ aux (K f) = K (Text.pack f, untag (jsonModel :: Tagged a Value))++tupleModel :: [Value] -> Value+tupleModel = Array . Vector.fromList++objectModel :: [(Text, Value)] -> Value+objectModel = Array . Vector.fromList . map aux+ where+ aux :: (Text, Value) -> Value+ aux (name, typ) = object [ "name" .= name, "type" .= typ ]++constructorModelOne :: forall a. JsonModel a => JsonInfo '[a] -> Value+constructorModelOne _ = untag (jsonModel :: Tagged a Value)++jsonModelK :: forall a. JsonModel a => K Value a+jsonModelK = K $ untag (jsonModel :: Tagged a Value)++tagModel :: Tag -> Value -> Value+tagModel NoTag v = v+tagModel (Tag n) v = object [ "Object" .= object [ Text.pack n .= v ] ]++p :: Proxy JsonModel+p = Proxy
+ src/Generics/SOP/Util/PartialResult.hs view
@@ -0,0 +1,76 @@+-- | Monad for partial results+module Generics.SOP.Util.PartialResult (+ Partial(..)+ , runPartial+ , partialResult+ -- * Re-exports+ , lift+ ) where++import Control.Applicative+import Control.Monad+import Control.Monad.Trans.Class++-- | Repeat f zero or more times+--+-- Note that this is a free monad construction, but the difference is in the+-- MonadPlus instead. We regard successive PSucc applications to indicate+-- "more success". This is very useful in parser construction: if all parsers+-- for all constructors fail immediately, we want to show an error message+-- for all the top-level parsers ("expected T1 or T2 .."). But if the parser+-- for T1, say, success in parsing the tag for T1, then we don't want to+-- try any more parsers for other constructors even if the parser for T1+-- now fails in parsing the arguments of T1. Instead, we want to give the+-- error message about attempting to parse T1.+data Partial (f :: * -> *) (a :: *) =+ Fail [String]+ | PZero a+ | PSucc (f (Partial f a))++partialResult :: Monad f => Partial f a -> Partial f a+partialResult = PSucc . return++instance Functor f => Functor (Partial f) where+ fmap _ (Fail e) = Fail e+ fmap f (PZero a) = PZero (f a)+ fmap f (PSucc pa) = PSucc (fmap (fmap f) pa)++instance Functor f => Monad (Partial f) where+ return = PZero+ fail = Fail . return++ Fail e >>= _ = Fail e+ PZero a >>= f = f a+ PSucc fa >>= f = PSucc (fmap (>>= f) fa)++instance (MonadPlus f, Functor f) => MonadPlus (Partial f) where+ mzero = Fail []++ Fail a `mplus` Fail b = Fail (a ++ b)+ Fail _ `mplus` b = b+ a `mplus` Fail _ = a++ PZero a `mplus` PZero _ = PZero a+ PZero _ `mplus` PSucc b = PSucc b+ PSucc a `mplus` PZero _ = PSucc a+ PSucc a `mplus` PSucc b = PSucc (a `mplus` b)++instance MonadTrans Partial where+ lift ma = PSucc (PZero `liftM` ma)++instance Functor f => Applicative (Partial f) where+ pure = return+ f <*> a = do f' <- f ; a' <- a ; return (f' a')++instance (MonadPlus f, Functor f) => Alternative (Partial f) where+ empty = mzero+ (<|>) = mplus++runPartial :: Monad m => ([String] -> m a) -> Partial m a -> m a+runPartial failWith = go+ where+ go (PZero a) = return a+ go (PSucc fa) = fa >>= go+ go (Fail es) = failWith es++