packages feed

JsonGrammar (empty) → 0.1

raw patch · 8 files changed

+549/−0 lines, 8 filesdep +aesondep +basedep +containerssetup-changed

Dependencies added: aeson, base, containers, semigroups, template-haskell, text, vector

Files

+ Data/Iso.hs view
@@ -0,0 +1,14 @@+-- | Convenience module that re-exports the available submodules.+module Data.Iso (++  module Data.Iso.Core,+  module Data.Iso.Common,+  module Data.Iso.TH,+  module Data.Semigroup++  ) where++import Data.Iso.Core+import Data.Iso.Common+import Data.Iso.TH+import Data.Semigroup
+ Data/Iso/Common.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoMonoPatBinds #-}++-- | Constructor-destructor isomorphisms for some common datatypes.+module Data.Iso.Common (++  -- * @()@+  unit,++  -- * @Maybe a@+  nothing, just, maybe,+  +  -- * @[a]@+  nil, cons,+  +  -- * @Either a b@+  left, right, either,+  +  -- * @Bool@+  false, true, bool++  ) where++import Prelude hiding (id, (.), maybe, either)+import Control.Category++import Data.Iso.Core+import Data.Iso.TH++import Data.Semigroup+++unit :: Iso t (() :- t)+unit = Iso f g+  where+    f       t  = Just (() :- t)+    g (_ :- t) = Just t+++nothing :: Iso t (Maybe a :- t)+just    :: Iso (a :- t) (Maybe a :- t)+(nothing, just) = $(deriveIsos ''Maybe)++maybe :: Iso t (a :- t) -> Iso t (Maybe a :- t)+maybe el = just . el <> nothing+++nil :: Iso t ([a] :- t)+nil = Iso f g+  where+    f        t  = Just ([] :- t)+    g ([] :- t) = Just t+    g _         = Nothing++cons :: Iso (a :- [a] :- t) ([a] :- t)+cons = Iso f g+  where+    f (x :- xs  :- t) = Just ((x : xs) :- t)+    g ((x : xs) :- t) = Just (x :- xs :- t)+    g _               = Nothing+++left  :: Iso (a :- t) (Either a b :- t)+right :: Iso (b :- t) (Either a b :- t)+(left, right) = $(deriveIsos ''Either)++either :: Iso t1 (a :- t2) -> Iso t1 (b :- t2) -> Iso t1 (Either a b :- t2)+either f g = left . f <> right . g+++false :: Iso t (Bool :- t)+true  :: Iso t (Bool :- t)+(false, true) = $(deriveIsos ''Bool)++bool  :: Iso t (Bool :- t)+bool = false <> true
+ Data/Iso/Core.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE TypeOperators #-}++module Data.Iso.Core (++  -- * Partial isomorphisms+  Iso(..), convert, inverse,+  +  -- * Stack-based isomorphisms+  (:-)(..), stack, unstack, swap, duck,+  lit, inverseLit, matchWithDefault, ignoreWithDefault+  +  ) where+++import Prelude hiding (id, (.), head)++import Data.Monoid+import Data.Semigroup++import Control.Applicative+import Control.Monad+import Control.Category+++-- Partial isomorphisms++-- | Bidirectional partial isomorphism.+data Iso a b = Iso (a -> Maybe b) (b -> Maybe a)++instance Category Iso where+  id                          = Iso Just Just+  ~(Iso f1 g1) . ~(Iso f2 g2) = Iso (f1 <=< f2) (g1 >=> g2)++instance Monoid (Iso a b) where+  mempty = Iso (const Nothing) (const Nothing)+  ~(Iso f1 g1) `mappend` ~(Iso f2 g2) =+    Iso+      ((<|>) <$> f1 <*> f2)+      ((<|>) <$> g1 <*> g2)++instance Semigroup (Iso a b) where+  (<>) = mappend++-- | Apply an isomorphism in one direction.+convert :: Iso a b -> a -> Maybe b+convert (Iso f _) = f++-- | Inverse of an isomorphism.+inverse :: Iso a b -> Iso b a+inverse (Iso f g) = Iso g f+++-- Stack-based isomorphisms++-- | Heterogenous stack with a head and a tail.+data h :- t = h :- t+  deriving (Eq, Show)+infixr 5 :-++head :: (h :- t) -> h+head (h :- _) = h++-- | Convert to a stack isomorphism.+stack :: Iso a b -> Iso (a :- t) (b :- t)+stack (Iso f g) = Iso (lift f) (lift g)+  where+    lift k (x :- t) = (:- t) <$> k x++-- | Convert from a stack isomorphism.+unstack :: Iso (a :- ()) (b :- ()) -> Iso a b+unstack (Iso f g) = Iso (lift f) (lift g)+  where+    lift k = fmap head . k . (:- ())++-- | Swap the top two arguments.+swap :: Iso (a :- b :- t) (b :- a :- t)+swap = Iso f f+  where+    f (x :- y :- t) = Just (y :- x :- t)++-- | Introduce a head value that is passed unmodified.+duck :: Iso t1 t2 -> Iso (h :- t1) (h :- t2)+duck (Iso f g) = Iso (lift f) (lift g)+  where+    lift k (h :- t) = (h :-) <$> k t++-- | Push or pop a specific value.+lit :: Eq a => a -> Iso t (a :- t)+lit x = Iso f g+  where+    f t = Just (x :- t)+    g (x' :- t) = do+      guard (x' == x)+      Just t++-- | Inverse of 'lit'.+inverseLit :: Eq a => a -> Iso (a :- t) t+inverseLit = inverse . lit++-- | When converting from left to right, push the default value on top of the+-- stack. When converting from right to left, pop the value, make sure it+-- matches the predicate and then discard it.+matchWithDefault :: (a -> Bool) -> a -> Iso t (a :- t)+matchWithDefault p x = Iso f g+  where+    f t = Just (x :- t)+    g (x' :- t) = do+      guard (p x')+      return t++-- | When converting from left to right, push the default value on top of the stack. When converting from right to left, pop the value and discard it.+ignoreWithDefault :: a -> Iso t (a :- t)+ignoreWithDefault = matchWithDefault (const True)
+ Data/Iso/TH.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Iso.TH (deriveIsos) where++import Data.Iso.Core+import Language.Haskell.TH+import Control.Applicative+import Control.Monad+++-- | Derive partial isomorphisms for a given datatype. The resulting+-- expression is a tuple with one isomorphism element for each constructor in+-- the datatype.+-- +-- For example:+-- +-- > nothing :: Iso t (Maybe a :- t)+-- > just    :: Iso (a :- t) (Maybe a :- t)+-- > (nothing, just) = $(deriveIsos ''Maybe)+-- +-- Deriving isomorphisms this way requires @-XNoMonoPatBinds@.+deriveIsos :: Name -> Q Exp+deriveIsos name = do+  info <- reify name+  routers <-+    case info of+      TyConI (DataD _ _ _ cons _)   ->+        mapM (deriveIso (length cons /= 1)) cons+      TyConI (NewtypeD _ _ _ con _) ->+        (:[]) <$> deriveIso False con+      _ ->+        fail $ show name ++ " is not a datatype."+  return (TupE routers)+++deriveIso :: Bool -> Con -> Q Exp+deriveIso matchWildcard con =+  case con of+    NormalC name tys -> go name (map snd tys)+    RecC name tys -> go name (map (\(_,_,ty) -> ty) tys)+    _ -> fail $ "Unsupported constructor " ++ show (conName con)+  where+    go name tys = do+      iso <- [| Iso |]+      isoCon <- deriveConstructor name tys+      isoDes <- deriveDestructor matchWildcard name tys+      return $ iso `AppE` isoCon `AppE` isoDes+++deriveConstructor :: Name -> [Type] -> Q Exp+deriveConstructor name tys = do+  -- Introduce some names+  t          <- newName "t"+  fieldNames <- replicateM (length tys) (newName "a")++  -- Figure out the names of some constructors+  ConE just  <- [| Just |]+  ConE cons  <- [| (:-) |]++  let pat = foldr (\f fs -> ConP cons [VarP f, fs]) (VarP t) fieldNames+  let applyCon = foldl (\f x -> f `AppE` VarE x) (ConE name) fieldNames+  -- applyCon <- [| undefined |]+  let body = ConE just `AppE` (ConE cons `AppE` applyCon `AppE` VarE t)++  return $ LamE [pat] body+++deriveDestructor :: Bool -> Name -> [Type] -> Q Exp+deriveDestructor matchWildcard name tys = do+  -- Introduce some names+  x          <- newName "x"+  r          <- newName "r"+  fieldNames <- replicateM (length tys) (newName "a")++  -- Figure out the names of some constructors+  ConE just  <- [| Just |]+  ConE cons  <- [| (:-) |]+  nothing    <- [| Nothing |]++  let conPat   = ConP name (map VarP fieldNames)+  let okBody   = ConE just `AppE`+                  foldr+                    (\h t -> ConE cons `AppE` VarE h `AppE` t)+                    (VarE r)+                    fieldNames+  let okCase   = Match (ConP cons [conPat, VarP r]) (NormalB okBody) []+  let failCase = Match WildP (NormalB nothing) []+  let allCases =+        if matchWildcard+              then [okCase, failCase]+              else [okCase]++  return $ LamE [VarP x] (CaseE (VarE x) allCases)+++-- Retrieve the name of a constructor.+conName :: Con -> Name+conName con =+  case con of+    NormalC name _  -> name+    RecC name _     -> name+    InfixC _ name _ -> name+    ForallC _ _ con' -> conName con'
+ JsonGrammar.cabal view
@@ -0,0 +1,39 @@+Name:           JsonGrammar+Version:        0.1+Synopsis:       Combinators for bidirectional JSON parsing+Description:   	Combinators for bidirectional JSON parsing+++Author:         Martijn van Steenbergen+Maintainer:     martijn@van.steenbergen.nl+Stability:      Experimental+Copyright:      Some Rights Reserved (CC) 2010 Martijn van Steenbergen+Homepage:       https://github.com/MedeaMelana/JsonGrammar+Bug-reports:    https://github.com/MedeaMelana/JsonGramamr/issues+++Cabal-Version:  >= 1.6+License:        BSD3+License-file:   LICENSE+Category:       JSON, Language+Build-type:     Simple+++Library+  Exposed-Modules:  Data.Iso,+                    Data.Iso.Core,+                    Data.Iso.TH,+                    Data.Iso.Common,+                    Language.JsonGrammar+  Build-Depends:    base >= 3.0 && < 4.4,+                    containers >= 0.3 && < 0.5,+                    aeson >= 0.3 && < 0.4,+                    semigroups >= 0.5 && < 0.6,+                    template-haskell >= 2.4 && < 2.6,+                    -- constraints copied from aeson-0.3.2.5:+                    text >= 0.11.0.2,+                    vector >= 0.7++Source-Repository head+  Type:         git+  Location:     https://github.com/MedeaMelana/JsonGrammar
+ LICENSE view
@@ -0,0 +1,24 @@+Copyright (c) 2011, Martijn van Steenbergen+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 the author nor the+      names of his contributors may be used to endorse or promote products+      derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 <copyright holder> 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.
+ Language/JsonGrammar.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoMonoPatBinds #-}++module Language.JsonGrammar (+  -- * Constructing JSON grammars+  liftAeson, option, greedyOption, array,+  propBy, rawFixedProp, rest, ignoreRest, object,+  +  -- * Type-directed conversion+  Json(..), fromJson, toJson, litJson, prop, fixedProp+  +  ) where++import Data.Iso hiding (option)++import Prelude hiding (id, (.), head, maybe, either)++import Control.Category+import Control.Monad++import Data.Aeson hiding (object)+import Data.Aeson.Types (parseMaybe)+import qualified Data.Map as M+import Data.Maybe (fromMaybe)+import Data.String+import Data.Text (Text)+import qualified Data.Vector as V+++aeObject :: Iso (Object :- t) (Value :- t)+aeArray  :: Iso (Array  :- t) (Value :- t)+aeNull   :: Iso            t  (Value :- t)+(aeObject, aeArray, _, _, _, aeNull) = $(deriveIsos ''Value)++-- | Convert any Aeson-enabled type to a grammar.+liftAeson :: (FromJSON a, ToJSON a) => Iso (Value :- t) (a :- t)+liftAeson = stack (Iso from to)+  where+    from = parseMaybe parseJSON+    to   = Just . toJSON++-- | Introduce 'Null' as possible value. First gives the argument grammar a+-- chance, only yielding 'Null' or 'Nothing' if the argument grammar fails to+-- handle the input.+option :: Iso (Value :- t) (a :- t) -> Iso (Value :- t) (Maybe a :- t)+option g = just . g <> nothing . inverse aeNull++-- | Introduce 'Null' as possible (greedy) value. Always converts 'Nothing' to+-- 'Null' and vice versa, even if the argument grammar knows how to handle+-- these values.+greedyOption :: Iso (Value :- t) (a :- t) -> Iso (Value :- t) (Maybe a :- t)+greedyOption g = nothing . inverse aeNull <> just . g++-- | Describe an array whose elements match the given grammar.+array :: Iso (Value :- t) (a :- t) -> Iso (Value :- t) ([a] :- t)+array g = inverse aeArray >>> vectorList >>> elements+  where+    elements = (inverse cons >>> swap >>> duck g >>> swap >>>+                  duck elements >>> cons)+            <> (inverse nil >>> nil)++vectorList :: Iso (V.Vector a :- t) ([a] :- t)+vectorList = stack (Iso f g)+  where+    f = Just . V.toList+    g = Just . V.fromList+++-- | Describe a property with the given name and value grammar.+propBy :: Iso (Value :- t) (a :- t) -> String -> Iso (Object :- t) (Object :- a :- t)+propBy g name = duck g . rawProp name++rawProp :: String -> Iso (Object :- t) (Object :- Value :- t)+rawProp name = Iso from to+  where+    textName = fromString name+    from (o :- r) = do+      value <- M.lookup textName o+      return (M.delete textName o :- value :- r)+    to (o :- value :- r) = do+      guard (M.notMember textName o)+      return (M.insert textName value o :- r)++-- | Expect a specific key/value pair.+rawFixedProp :: String -> Value -> Iso (Object :- t) (Object :- t)+rawFixedProp name value = stack (Iso from to)+  where+    textName = fromString name+    from o = do+      value' <- M.lookup textName o+      guard (value' == value)+      return (M.delete textName o)+    to o = do+      guard (M.notMember textName o)+      return (M.insert textName value o)++-- | Collect all properties left in an object.+rest :: Iso (Object :- t) (Object :- M.Map Text Value :- t)+rest = lit M.empty++-- | Match and discard all properties left in the object. When converting back to JSON, produces no properties.+ignoreRest :: Iso (Object :- t) (Object :- t)+ignoreRest = lit M.empty . inverse (ignoreWithDefault M.empty)++-- | Wrap an exhaustive bunch of properties in an object. Typical usage:+-- +-- > object (prop "key1" . prop "key2")+object :: Iso (Object :- t1) (Object :- t2) -> Iso (Value :- t1) t2+object props = inverse aeObject >>> props >>> inverseLit M.empty+++-- Type-directed conversion++-- | Convert values of a type to and from JSON.+class Json a where+  grammar :: Iso (Value :- t) (a :- t)++instance Json a => Json [a] where+  grammar = array grammar++instance Json Bool where+  grammar = liftAeson++instance Json Int where+  grammar = liftAeson++instance Json Integer where+  grammar = liftAeson++instance Json Float where+  grammar = liftAeson++instance Json Double where+  grammar = liftAeson++instance Json [Char] where+  grammar = liftAeson++instance Json a => Json (Maybe a) where+  grammar = option grammar++instance (Json a, Json b) => Json (Either a b) where+  grammar = either grammar grammar++instance Json Value where+  grammar = id++unsafeToJson :: Json a => String -> a -> Value+unsafeToJson context value =+    fromMaybe err (convert (inverse (unstack grammar)) value)+  where+    err = error (context +++            ": could not convert Haskell value to JSON value")++-- | Convert from JSON.+fromJson :: Json a => Value -> Maybe a+fromJson = convert (unstack grammar)++-- | Convert to JSON.+toJson :: Json a => a -> Maybe Value+toJson = convert (inverse (unstack grammar))++-- | Expect/produce a specific JSON 'Value'.+litJson :: Json a => a -> Iso (Value :- t) t+litJson = inverseLit . unsafeToJson "litJson"++-- | Describe a property whose value grammar is described by a 'Json' instance.+prop :: Json a => String -> Iso (Object :- t) (Object :- a :- t)+prop = propBy grammar++-- | Expect a specific key/value pair.+fixedProp :: Json a => String -> a -> Iso (Object :- t) (Object :- t)+fixedProp name value = rawFixedProp name (unsafeToJson "fixedProp" value)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain