tyro 0.2.0.0 → 0.3.0.0
raw patch · 5 files changed
+99/−40 lines, 5 filesdep +vector
Dependencies added: vector
Files
- README.md +4/−2
- src/Data/Tyro.hs +52/−30
- src/Data/Tyro/Internal.hs +16/−0
- test/Spec.hs +16/−6
- tyro.cabal +11/−2
README.md view
@@ -1,6 +1,6 @@ # tyro -`tyro` is a dependently type JSON parsing library, that provides a quick way to create JSON parsers by deriving them from a type level description of the position of the value to be obtained.+`tyro` is a dependently typed JSON parsing library, that provides a quick way to create JSON parsers by deriving them from a type level description of the position of the value to be obtained. It provides some of the same functionality as Aeson lenses, but derives the parsers from types rather than doing a generic parse and applying prisms. This was mostly an experiment in dependent typing. ## Examples @@ -25,7 +25,9 @@ values = fmap unwrap parsed ``` -### Value driven interface+### Value driven interface (experimental)++The value driven interface is still experimental, and in the process of being refined. ```Haskell {-# LANGUAGE OverloadedStrings #-}
src/Data/Tyro.hs view
@@ -16,20 +16,21 @@ -- * Building types -- $typed_example- Extract-, type( >%> )-, List-, unwrap+ Extract+ , type( >%> )+ , List+ , unwrap --- * Value level API--- $value_example-, Tyro-, extract-, (>%>)-, (%%>)+ -- * Value level API+ -- $value_example+ , Tyro+ , extract+ , (>%>)+ , (%%>) -- * Internal types-, JSBranch ) where+ , JSBranch+ , Unwrap ) where import Data.Aeson ((.:))@@ -38,12 +39,15 @@ import qualified Data.ByteString.Lazy as B import Data.Reflection (reifySymbol) import Data.Singletons (Sing, SingI(..))-import Data.Singletons.Prelude.List (Sing(SNil, SCons)) import Data.Singletons.TypeLits ( Symbol, SSymbol, KnownSymbol , withKnownSymbol, symbolVal ) import Data.String (String) import Data.Text (pack)+import Data.Vector (Vector)+import qualified Data.Vector as V +import Data.Tyro.Internal+ import Lib.Prelude @@ -53,17 +57,17 @@ -------------------------------------------------------------------------------- -- | @Extract a@ represents trying to parse JSON to an @a@.-type Extract a = JSBranch '[] a+type Extract a = JSBranch 'JSExtract a -- | The type operator '>%> provides a way of describing how to walk -- down a JSON tree. type family (x :: Symbol) >%> (b :: *) :: *-type instance (x :: Symbol) >%> JSBranch xs a = JSBranch (x ': xs) a+type instance (x :: Symbol) >%> JSBranch xs a = JSBranch ('JSKey x xs) a -- | The 'List' type operator constructs a parsing type for parsing -- a list of JSON objects. type family List (x :: *) :: *-type instance List (JSBranch xs a) = Extract [JSBranch xs a]+type instance List (JSBranch xs a) = JSBranch ('JSArray xs) a @@ -89,9 +93,9 @@ -- | Internal proxying datatype for accumulating reified values as a list-data TyroProxy :: [Symbol] -> * where- Take :: TyroProxy '[]- Key :: TyroProxy s -> TyroProxy (t ': s)+data TyroProxy :: JSLens Symbol -> * where+ Take :: TyroProxy 'JSExtract+ Key :: TyroProxy s -> TyroProxy ('JSKey t s) -- | '%%>' tries to parse a ByteString along a 'Tyro' to obtain a value@@ -100,15 +104,21 @@ where go :: (A.FromJSON a, SingI xs) => B.ByteString -> [String] -> TyroProxy xs -> Maybe a- go b [] t = fmap unwrap $ parse b t+ go b [] t = fmap dumbUnwrap $ parse b t go b (k:ks) t = reifySymbol k $ \p -> go b ks (extend t p) parse :: (A.FromJSON a, SingI xs) => B.ByteString -> TyroProxy xs -> Maybe (JSBranch xs a) parse b _ = A.decode b - extend :: (KnownSymbol s) => TyroProxy xs -> Proxy s -> TyroProxy (s ': xs)+ extend :: (KnownSymbol s) => TyroProxy xs -> Proxy s -> TyroProxy ('JSKey s xs) extend t _ = Key t++ dumbUnwrap :: JSBranch xs a -> a+ dumbUnwrap (JSNil x) = x+ dumbUnwrap (JSCons x') = dumbUnwrap x'+ dumbUnwrap _ = error "dumbUnwrap received unexpected input"+ infixl 8 %%> @@ -120,29 +130,40 @@ -- | 'JSBranch' is a dependent datatype which represents a walk down a JSON -- tree. @JSBranch ["key1", "key2"] a@ represents the walk "take the value at -- @key1@ and then the value at @key2@, and (try to) interpret that as an @a@".-data JSBranch :: [Symbol] -> * -> * where- JSNil :: a -> JSBranch '[] a- JSCons :: JSBranch xs a -> JSBranch (t ': xs) a+data JSBranch :: JSLens Symbol -> * -> * where+ JSNil :: a -> JSBranch 'JSExtract a+ JSCons :: JSBranch xs a -> JSBranch ('JSKey t xs) a+ JSArr :: Vector (JSBranch xs a) -> JSBranch ('JSArray xs) a --- | 'unwrap' unwraps a value from it's parsing type.-unwrap :: JSBranch xs a -> a-unwrap b = case b of- JSNil x -> x- JSCons b' -> unwrap b'+-- | 'Unwrap' captures the unstructured type encapsulated by a JSBranch+type family Unwrap (x :: *) :: *+type instance Unwrap (JSBranch 'JSExtract a) = a+type instance Unwrap (JSBranch ('JSKey k js) a) = Unwrap (JSBranch js a)+type instance Unwrap (JSBranch ('JSArray js) a) = [Unwrap (JSBranch js a)] +-- | 'unwrap' allows parsing types to be removed from a JSBranch+unwrap :: JSBranch xs a -> Unwrap (JSBranch xs a)+unwrap (JSNil x) = x+unwrap (JSCons x') = unwrap x'+unwrap (JSArr xs) = V.toList $ fmap unwrap xs++ instance (A.FromJSON a, SingI xs) => A.FromJSON (JSBranch xs a) where parseJSON :: (A.FromJSON a, SingI xs) => A.Value -> Parser (JSBranch xs a) parseJSON = parse sing where parse :: (A.FromJSON a) => Sing xs -> A.Value -> Parser (JSBranch xs a) parse s o = case s of- SNil -> JSNil <$> A.parseJSON o- x `SCons` xs -> case o of+ SJSExtract -> JSNil <$> A.parseJSON o+ SJSKey x xs -> case o of A.Object v -> let key = pack (reflectSymbol x) in JSCons <$> (v .: key >>= parse xs) _ -> empty+ SJSArray xs -> case o of+ A.Array vs -> JSArr <$> ( sequence $ fmap (parse xs) vs )+ _ -> empty -- | 'reflectSym' reflects a type level symbol into a value level string@@ -184,6 +205,7 @@ -- $value_example+-- (Experimental!) -- The value level interface allows a piece of the JSON object to be extracted -- in a similar way to most dynamically typed languages. --
+ src/Data/Tyro/Internal.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Data.Tyro.Internal where++import Data.Singletons.TH+import Lib.Prelude++$( singletons [d|+ data JSLens a = JSExtract | JSKey a (JSLens a) | JSArray (JSLens a)+ deriving (Show)+ |])
test/Spec.hs view
@@ -8,6 +8,7 @@ import Protolude import Data.Tyro+import Data.Tyro.Internal import qualified Data.Aeson as A import Data.Text (Text)@@ -24,6 +25,7 @@ typeLevelJSONParserTests = testGroup "\nType level JSON Parser tests" . hUnitTestToTests $ HU.TestList [ canExtractTextInJSBranch , canExtractIntegerInJSBranch+ , canExtractPreludeListInJSBranch , canExtractListInJSBranch , canExtractListInJSBranchWithTypeFamily ] @@ -41,7 +43,7 @@ canExtractTextInJSBranch = "Can extract JSBranch on Text" ~: let json = "{\"key1\":{\"key2\":{\"key3\":\"Some text\"}}}" expected = Just "Some text"- decoded = A.decode json :: Maybe (JSBranch '["key1", "key2", "key3"] Text)+ decoded = A.decode json :: Maybe (JSBranch ('JSKey "key1" ('JSKey "key2" ('JSKey "key3" 'JSExtract))) Text) in expected @=? fmap unwrap decoded @@ -49,26 +51,34 @@ canExtractIntegerInJSBranch = "Can extract JSBranch on Integer" ~: let json = "{\"key1\":{\"key2\":{\"key3\":42}}}" expected = Just 42- decoded = A.decode json :: Maybe (JSBranch '["key1", "key2", "key3"] Integer)+ decoded = A.decode json :: Maybe (JSBranch ('JSKey "key1" ('JSKey "key2" ('JSKey "key3" 'JSExtract))) Integer) in expected @=? fmap unwrap decoded -canExtractListInJSBranch :: HU.Test-canExtractListInJSBranch = "Can extract JSBranch on List" ~:+canExtractPreludeListInJSBranch :: HU.Test+canExtractPreludeListInJSBranch = "Can extract JSBranch on List (Prelude)" ~: let json = "{\"key1\":[{\"key2\":41},{\"key2\":42}]}" expected = Just [41,42]- decoded = A.decode json :: Maybe (JSBranch '["key1"] [JSBranch '["key2"] Integer])+ decoded = A.decode json :: Maybe (JSBranch ('JSKey "key1" 'JSExtract) [JSBranch ('JSKey "key2" 'JSExtract) Integer]) in expected @=? (fmap (fmap unwrap) . (fmap unwrap) $ decoded) +canExtractListInJSBranch :: HU.Test+canExtractListInJSBranch = "Can extract JSBranch on List (Tyro)" ~:+ let json = "{\"key1\":[{\"key2\":41},{\"key2\":42}]}"+ expected = Just [41,42]+ decoded = A.decode json :: Maybe (JSBranch ('JSKey "key1" ('JSArray ('JSKey "key2" 'JSExtract))) Integer)+ in+ expected @=? fmap unwrap decoded + canExtractListInJSBranchWithTypeFamily :: HU.Test canExtractListInJSBranchWithTypeFamily = "Can extract JSBranch on List with type family" ~: let json = "{\"key1\":[{\"key2\":41},{\"key2\":42}]}" expected = Just [41,42] decoded = A.decode json :: Maybe ("key1" >%> List ("key2" >%> Extract Integer)) in- expected @=? (fmap (fmap unwrap) . (fmap unwrap) $ decoded)+ expected @=? fmap unwrap decoded --------------------------------------------------------------------------------
tyro.cabal view
@@ -1,5 +1,5 @@ name: tyro-version: 0.2.0.0+version: 0.3.0.0 synopsis: Type derived JSON parsing using Aeson description: A library for deriving JSON parsers (using Aeson) by indicating@@ -20,9 +20,11 @@ ghc-options: -Wall exposed-modules: Data.Tyro other-modules: Lib.Prelude+ , Data.Tyro.Internal build-depends: base >= 4.9 && < 5 , protolude >= 0.1.6 && < 0.2 , aeson+ , vector , text , bytestring , singletons@@ -32,8 +34,11 @@ test-suite tyro-test type: exitcode-stdio-1.0- hs-source-dirs: test+ hs-source-dirs: test, src main-is: Spec.hs+ other-modules: Data.Tyro+ , Data.Tyro.Internal+ , Lib.Prelude build-depends: base , tyro , protolude >= 0.1.6 && < 0.2@@ -41,6 +46,10 @@ , test-framework-hunit , HUnit , text+ , bytestring+ , vector+ , singletons+ , reflection , aeson ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010