typson-core (empty) → 0.1.0.0
raw patch · 8 files changed
+901/−0 lines, 8 filesdep +aesondep +basedep +containerssetup-changed
Dependencies added: aeson, base, containers, profunctors, text, unordered-containers, vector
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- src/Typson.hs +11/−0
- src/Typson/JsonTree.hs +433/−0
- src/Typson/Optics.hs +215/−0
- src/Typson/Pathing.hs +166/−0
- typson-core.cabal +41/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for typson-core++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Aaron Allen (c) 2020++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 Aaron Allen 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
+ src/Typson.hs view
@@ -0,0 +1,11 @@+module Typson+ ( -- * Core Functionality+ module Typson.JsonTree+ , module Typson.Pathing+ -- * Utility+ , module Typson.Optics+ ) where++import Typson.JsonTree+import Typson.Pathing+import Typson.Optics
+ src/Typson/JsonTree.hs view
@@ -0,0 +1,433 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE UndecidableInstances #-} -- for the custom type error+--------------------------------------------------------------------------------+-- |+-- Module : Typson.JsonTree+-- Description : Provides the core type classes and data structures for JSON+-- representation+-- Copyright : (c) Aaron Allen, 2020+-- Maintainer : Aaron Allen <aaronallen8455@gmail.com>+-- License : BSD-style (see the file LICENSE)+-- Stability : experimental+-- Portability : non-portable+--+--------------------------------------------------------------------------------+module Typson.JsonTree+ ( -- * Schema Semantics+ -- | Type classes and type-level data structures for representing the+ -- JSON structure of data.++ -- ** Defining JSON Schemas+ ObjectSYM(..)+ , FieldSYM(..)+ , UnionSYM(..)+ , JsonSchema+ , key+ -- ** Core Interpreters+ -- | A single schema can be interpreted in different ways. This allows it to+ -- be used as both an encoder and decoder.+ -- Because the schema semantics are using the final tagless style, users are+ -- able to write their own interpreters.+ , ObjectEncoder(..)+ , ObjectDecoder(..)+ , ObjectTree(..)+ -- ** Specialized Indexed Free Applicative+ , TreeBuilder+ , (<<$>)+ , (<<*>)+ , runAp+ , runAp_+ -- ** Core Data Structure+ , type Tree(..)+ , type Edge(..)+ , type Aggregator(..)+ , type Multiplicity(..)+ , NoDuplicateKeys+ ) where++import Control.Monad ((<=<))+import Data.Aeson ((.:), (.:?), (.=), FromJSON, ToJSON, FromJSONKey, ToJSONKey)+import qualified Data.Aeson.Types as Aeson+import Data.Functor.Identity (Identity(..))+import qualified Data.HashMap.Strict as HM+import Data.Kind (Constraint, Type)+import qualified Data.Map.Strict as M+import Data.Proxy (Proxy(..))+import qualified Data.Set as S+import Data.String (IsString)+import qualified Data.Text as T+import qualified Data.Vector as V+import GHC.TypeLits (ErrorMessage(..), KnownSymbol, Nat, Symbol, TypeError, symbolVal)++--------------------------------------------------------------------------------+-- Type-level JSON Tree Representation+--------------------------------------------------------------------------------++-- | This is the data structure used to represent the JSON form of a haskell type. It is+-- only used at the type level via the @DataKinds@ extension. You shouldn't write+-- this type yourself, instead it's recommended that you let the compiler infer+-- it using the @PartialTypeSignatures@ extension and turning off warnings for+-- partial signatures using @-fno-warn-partial-type-signatures@. The @Tree@+-- argument in the type signatures of your schemas can then be filled with @_@.+--+-- @+-- personJ :: JsonSchema _ Person+-- @+data Tree = Node Aggregator [Edge] -- Invariant: [Edge] is non-empty+ | IndexedNode Type Tree+ -- ^ A node representing a container indexed by some kind+ | Leaf++data Edge+ = Edge+ Symbol -- ^ The json field key+ Multiplicity -- ^ The multiplicity of the field's value+ Type -- ^ The type of the value at the key+ Tree -- ^ 'Tree' for the value's type++data Aggregator+ = Product -- ^ Object has all fields from a list+ | Sum -- ^ Object has exactly one field from a list of possible fields++data Multiplicity+ = Singleton -- ^ A non-null field+ | Nullable -- ^ A field that can be @null@++--------------------------------------------------------------------------------+-- Final-tagless "Symantics" for Object Construction+--------------------------------------------------------------------------------++-- | Used to interpret JSON trees for haskell record types.+class FieldSYM repr => ObjectSYM (repr :: Tree -> Type -> Type) where+ -- | Declares the schema for a record type.+ --+ -- @+ -- data Person =+ -- Person+ -- { name :: Text+ -- , age :: Int+ -- }+ --+ -- personJ :: JsonSchema _ Person+ -- personJ = object \"Person\" $+ -- Person+ -- \<\<$> field (key \@\"name\") name prim+ -- \<\<*> field (key \@\"age\") age prim+ -- @+ object :: ( tree ~ 'Node 'Product edges+ , NoDuplicateKeys o edges+ )+ => String -- ^ Name of the object as it will appear in parse errors+ -> TreeBuilder (Field repr o) tree o -- ^ The collection of fields+ -> repr tree o++ -- | Serves as a schema for a type that cannot itself be broken down into+ -- named fields. The type must have 'FromJSON' and 'ToJSON' instances.+ prim :: ( FromJSON v+ , ToJSON v+ )+ => repr 'Leaf v++ -- | Given a schema for some type @a@, create a schema for @[a]@.+ --+ -- This will allow you to write queries specifying an index into the list:+ --+ -- @+ -- type ListQuery = \"foo\" :-> \"bar\" :-> 3 :-> \"baz\"+ -- @+ list :: repr tree o -- ^ Element schema+ -> repr ('IndexedNode Nat tree) [o]++ -- | Produces a schema for a 'Map' given a schema for it's elements type. The+ -- key of the map should be some sort of string.+ -- You can have arbitrary keys when constructing a query path into a @textMap@+ -- schema.+ textMap :: (FromJSONKey k, ToJSONKey k, IsString k, Ord k)+ => repr tree o -- ^ Element schema+ -> repr ('IndexedNode Symbol tree) (M.Map k o)++ -- | Construct a 'Set' schema given a schema for it's elements.+ set :: Ord o+ => repr tree o -- ^ Element schema+ -> repr ('IndexedNode Nat tree) (S.Set o)++ -- | Construct a 'Vector' schema given a schema for it's elements.+ vector :: repr tree o -- ^ Element schema+ -> repr ('IndexedNode Nat tree) (V.Vector o)++class FieldSYM repr where+ data Field repr :: Type -> Tree -> Type -> Type++ -- | Defines a required field+ field :: ( KnownSymbol key+ , edge ~ 'Edge key 'Singleton field subTree+ , tree ~ 'Node 'Product '[edge]+ )+ => proxy key -- ^ The 'Symbol' to use as the key in the JSON object+ -> (obj -> field) -- ^ The accessor for the field+ -> repr subTree field -- ^ Schema for the type of the field+ -> Field repr obj tree field++ -- | Defines an optional field. Will parse 'Nothing' for either a @null@ JSON+ -- value or if the key is missing. Will encode 'Nothing' as @null@.+ optField :: ( KnownSymbol key+ , edge ~ 'Edge key 'Nullable field subTree+ , tree ~ 'Node 'Product '[edge]+ )+ => proxy key -- ^ The 'Symbol' to use as the key in the JSON object+ -> (obj -> Maybe field) -- ^ The accessor for the field+ -> repr subTree field -- ^ Schema for the type of the field+ -> Field repr obj tree (Maybe field)++ -- | Defines an optional field where parsing will emit the given default value+ -- if the field is @null@ or the key is absent.+ optFieldDef :: ( KnownSymbol key+ , edge ~ 'Edge key 'Singleton field subTree+ , tree ~ 'Node 'Product '[edge]+ )+ => proxy key -- ^ The 'Symbol' to use as the key in the JSON object+ -> (obj -> field) -- ^ The accessor for the field+ -> field -- ^ Default value to emit+ -> repr subTree field -- ^ Schema for the type of the field+ -> Field repr obj tree field+ optFieldDef p getter _ sub = field p getter sub++-- | Used to interpret JSON trees for haskell sum types.+class UnionSYM (repr :: Tree -> Type -> Type) where+ -- | The result produced from each tag+ type Result repr union :: Type+ data Tag repr :: Type -> Tree -> Type -> Type++ -- | Declares a schema for a tagged sum type+ --+ -- @+ -- data Classifier+ -- = Flora Plant+ -- | Fauna Animal+ --+ -- classifierJ :: JsonSchema _ Classifier+ -- classifierJ = union \"Classifier\" $+ -- classifierTags+ -- \<\<$> tag (key \@\"flora\") Flora plantJ+ -- \<\<*> tag (key \@"\fauna\") Fauna animalJ+ -- @+ --+ -- The resulting JSON is an object with a single field with a key/value pair+ -- corresponding to one of the branches of the sum type.+ union :: ( tree ~ 'Node 'Sum edges+ , NoDuplicateKeys union edges+ )+ => String -- ^ Name of the union as it will appear in parse errors+ -> TreeBuilder (Tag repr union) tree (union -> Result repr union)+ -- ^ A collection of tags, one for each branch of the union+ -> repr tree union++ -- | Used to declare a single branch of a sum type. The constructor for the+ -- branch should take a single argument. If you require more than one argument+ -- then you should package them up into a separate record type.+ tag :: ( KnownSymbol name+ , edge ~ 'Edge name 'Nullable v subTree+ , tree ~ 'Node 'Sum '[edge]+ )+ => proxy name -- ^ 'Symbol' used as the JSON key for the field+ -> (v -> union) -- ^ Data constructor+ -> repr subTree v -- ^ Schema for the value that this branch tags+ -> Tag repr union tree (v -> Result repr union)++-- | A rank-N type synonym used in the type signature of JSON schemas+type JsonSchema t a = forall repr. (ObjectSYM repr, UnionSYM repr) => repr t a++-- | A synonym for 'Proxy' that takes a 'Symbol'. Intended to be used in 'field'+-- and 'tag' definitions.+key :: Proxy (key :: Symbol)+key = Proxy++--------------------------------------------------------------------------------+-- Tree Proxy+--------------------------------------------------------------------------------++data TreeProxy (t :: Tree) o = TreeProxy++-- | Used to pass a 'Tree' around at the value level.+newtype ObjectTree (t :: Tree) o =+ ObjectTree { getObjectTree :: TreeProxy t o }++instance ObjectSYM ObjectTree where+ object _ _ = ObjectTree TreeProxy+ list _ = ObjectTree TreeProxy+ textMap _ = ObjectTree TreeProxy+ set _ = ObjectTree TreeProxy+ vector _ = ObjectTree TreeProxy+ prim = ObjectTree TreeProxy++instance FieldSYM ObjectTree where+ data Field ObjectTree o t a = FieldProxy+ field _ _ _ = FieldProxy+ optField _ _ _ = FieldProxy++instance UnionSYM ObjectTree where+ data Tag ObjectTree u t a = TagProxy+ type Result ObjectTree u = ()+ union _ _ = ObjectTree TreeProxy+ tag _ _ _ = TagProxy++--------------------------------------------------------------------------------+-- JSON Encoding+--------------------------------------------------------------------------------++-- | Use a 'Tree' to encode a type as an Aeson 'Value'+newtype ObjectEncoder (t :: Tree) o =+ ObjectEncoder+ { -- | Uses a schema as a JSON encoder+ --+ -- @+ -- instance ToJSON Person where+ -- toJSON = encodeObject personJ+ -- @+ encodeObject :: o -> Aeson.Value+ }++instance ObjectSYM ObjectEncoder where+ object _ fields = ObjectEncoder $ \o ->+ Aeson.Object $ runAp_ (`unFieldEncoder` o) fields+ list (ObjectEncoder e) = ObjectEncoder $ Aeson.toJSON . map e+ textMap (ObjectEncoder e) = ObjectEncoder $ Aeson.toJSON . fmap e+ set (ObjectEncoder e) = ObjectEncoder $ Aeson.toJSON . map e . S.toList+ vector (ObjectEncoder e) = ObjectEncoder $ Aeson.toJSON . fmap e+ prim = ObjectEncoder Aeson.toJSON++instance FieldSYM ObjectEncoder where+ newtype Field ObjectEncoder o t a =+ FieldEncoder { unFieldEncoder :: o -> Aeson.Object }+ field ky acc (ObjectEncoder so) =+ FieldEncoder $ \o -> T.pack (symbolVal ky) .= so (acc o)+ optField ky acc (ObjectEncoder so) =+ FieldEncoder $ \o -> T.pack (symbolVal ky) .= (so <$> acc o)++instance UnionSYM ObjectEncoder where+ newtype Tag ObjectEncoder u t a =+ TagEncoder { unTagEncoder :: a }+ type Result ObjectEncoder u = Aeson.Value+ union _ tags = ObjectEncoder $+ runIdentity (runAp (Identity . unTagEncoder) tags)+ tag name _ valueEncoder =+ TagEncoder $ \v ->+ Aeson.object+ [ T.pack (symbolVal name) .= encodeObject valueEncoder v ]++--------------------------------------------------------------------------------+-- JSON Decoding+--------------------------------------------------------------------------------++-- | Use a 'Tree' to decode a type from an Aeson 'Value'+newtype ObjectDecoder (t :: Tree) o =+ ObjectDecoder+ { -- | Uses a schema as a JSON parser+ --+ -- @+ -- instance FromJSON Person where+ -- parseJSON = decodeObject personJ+ -- @+ decodeObject :: Aeson.Value -> Aeson.Parser o+ }++instance ObjectSYM ObjectDecoder where+ object name fields = ObjectDecoder . Aeson.withObject name $ \obj ->+ runAp (`unFieldDecoder` obj) fields+ list (ObjectDecoder d) = ObjectDecoder $ traverse d <=< Aeson.parseJSON+ textMap (ObjectDecoder d) = ObjectDecoder $ traverse d <=< Aeson.parseJSON+ set (ObjectDecoder d) = ObjectDecoder $ fmap S.fromList+ . traverse d <=< Aeson.parseJSON+ vector (ObjectDecoder d) = ObjectDecoder $ traverse d <=< Aeson.parseJSON+ prim = ObjectDecoder Aeson.parseJSON++instance FieldSYM ObjectDecoder where+ newtype Field ObjectDecoder o t a =+ FieldDecoder { unFieldDecoder :: Aeson.Object -> Aeson.Parser a }+ field ky _ (ObjectDecoder d) = FieldDecoder $ \obj -> do+ so <- obj .: T.pack (symbolVal ky)+ d so+ optField ky _ (ObjectDecoder d) = FieldDecoder $ \obj -> do+ mbSo <- obj .:? T.pack (symbolVal ky)+ traverse d mbSo+ optFieldDef ky _ def (ObjectDecoder d) = FieldDecoder $ \obj -> do+ mbSo <- obj .:? T.pack (symbolVal ky)+ maybe (pure def) d mbSo++instance UnionSYM ObjectDecoder where+ newtype Tag ObjectDecoder u t a =+ TagDecoder { unTagDecoder :: HM.HashMap T.Text (Aeson.Value -> Aeson.Parser u) }+ type Result ObjectDecoder u = ()+ union name tags = ObjectDecoder .+ Aeson.withObject name $ \obj -> do+ let decoderMap = runAp_ unTagDecoder tags+ decodeVal k v nxt =+ case HM.lookup k decoderMap of+ Nothing -> nxt+ Just tagDecoder ->+ tagDecoder v+ HM.foldrWithKey decodeVal (fail "Unable to find a matching tag") obj+ tag name constr valueDecoder =+ TagDecoder . HM.singleton (T.pack $ symbolVal name)+ $ fmap constr . decodeObject valueDecoder++--------------------------------------------------------------------------------+-- No Duplicate Keys Constraint+--------------------------------------------------------------------------------++-- | A constraint that raises a type error if an object has more than one field+-- with the same key.+type family NoDuplicateKeys (obj :: Type) (edges :: [Edge]) :: Constraint where+ NoDuplicateKeys obj ('Edge key q ty subTree ': rest)+ = (KeyNotPresent key obj rest, NoDuplicateKeys obj rest)+ NoDuplicateKeys obj '[] = ()++type family KeyNotPresent (key :: Symbol) (obj :: Type) (edges :: [Edge]) :: Constraint where+ KeyNotPresent key obj ('Edge key q ty subTree ': rest)+ = TypeError ('Text "Duplicate JSON key \""+ ':<>: 'Text key+ ':<>: 'Text "\" in object "+ ':<>: 'ShowType obj+ )+ KeyNotPresent key obj ('Edge notKey q ty subTree ': rest)+ = KeyNotPresent key obj rest+ KeyNotPresent key obj '[] = ()++--------------------------------------------------------------------------------+-- Free Indexed Applicative+--------------------------------------------------------------------------------++-- | An indexed free applicative variant that is used to build 'Tree's by+-- gathering up all the edges.+data TreeBuilder (f :: Tree -> Type -> Type) (t :: Tree) (a :: Type) where+ Pure :: a -> TreeBuilder f ('Node aggr '[]) a+ Ap :: TreeBuilder f ('Node aggr edges) (a -> b)+ -> f ('Node aggr '[edge]) a+ -> TreeBuilder f ('Node aggr (edge ': edges)) b++-- | Used like '<$>' in schema definitions+(<<$>) :: (a -> b)+ -> f ('Node aggr '[edge]) a+ -> TreeBuilder f ('Node aggr '[edge]) b+f <<$> i = Pure f `Ap` i+infixl 4 <<$>++-- | Used like '<*>' in schema definitions+(<<*>) :: TreeBuilder f ('Node aggr edges) (a -> b)+ -> f ('Node aggr '[edge]) a+ -> TreeBuilder f ('Node aggr (edge ': edges)) b+(<<*>) = Ap+infixl 4 <<*>++runAp_ :: Monoid m => (forall a' t'. f t' a' -> m) -> TreeBuilder f t a -> m+runAp_ _ (Pure _) = mempty+runAp_ f (Ap p c) = runAp_ f p <> f c++runAp :: Applicative g => (forall a' t'. f t' a' -> g a') -> TreeBuilder f t a -> g a+runAp _ (Pure a) = pure a+runAp f (Ap p c) = runAp f p <*> f c+
+ src/Typson/Optics.hs view
@@ -0,0 +1,215 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+--------------------------------------------------------------------------------+-- |+-- Module : Typson.Optics+-- Description : Interpreting schemas as optics+-- Copyright : (c) Aaron Allen, 2020+-- Maintainer : Aaron Allen <aaronallen8455@gmail.com>+-- License : BSD-style (see the file LICENSE)+-- Stability : experimental+-- Portability : non-portable+--+--------------------------------------------------------------------------------+module Typson.Optics+ ( -- * Optics+ -- | van Laarhoven style optics derived from schemas.+ fieldLens+ , fieldPrism+ ) where++import Data.Functor.Identity (Identity(..))+import Data.Profunctor (Profunctor(dimap))+import Data.Profunctor.Choice (Choice(..))+import Data.Kind (Type)+import Data.Monoid (First(..))+import Data.Proxy (Proxy(..))+import Data.Type.Equality ((:~:)(..))+import GHC.TypeLits (KnownSymbol, Symbol, sameSymbol)+import Unsafe.Coerce (unsafeCoerce)++import Typson.JsonTree (Aggregator(..), Edge(..), FieldSYM(..), Multiplicity(..), ObjectSYM(..), Tree(..), UnionSYM(..), runAp, runAp_)+import Typson.Pathing (TypeAtPath)++--------------------------------------------------------------------------------+-- Derive Optics for Fields+--------------------------------------------------------------------------------++-- | Produce a 'Lens' given a key for an object field and a schema+--+-- >>> edward ^. fieldLens (key @"name") personJ+-- "Edward"+--+fieldLens :: ( KnownSymbol key+ , tree ~ 'Node 'Product edges+ , TypeAtPath obj tree key ~ ty+ )+ => proxy key -- ^ The field's key+ -> Optic key ty tree obj -- ^ The object's schema+ -> Lens' obj ty+fieldLens _ (Lens l) = l++-- | Produce a 'Prism' given a key for a union tag and a schema+--+-- >>> dog ^? fieldLens (key @"classifier") lifeFormJ . fieldPrism (key @"fauna") classifierJ+-- Just (Animal {favoriteFoods = ["Chicken","Peanut Butter","Salmon"], isGoodPet = True})+--+fieldPrism :: ( KnownSymbol key+ , tree ~ 'Node 'Sum edges+ , TypeAtPath obj tree key ~ Maybe ty+ )+ => proxy key -- ^ The tag's key+ -> Optic key ty tree obj -- ^ The union's schema+ -> Prism' obj ty+fieldPrism _ (Prism p) = p++type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s+type Prism' s a = forall p f. (Choice p, Applicative f) => p a (f a) -> p s (f s)++data Optic (key :: Symbol) (val :: Type) (t :: Tree) (o :: Type) where+ Lens :: t ~ 'Node 'Product es => Lens' o val -> Optic key val t o+ Prism :: t ~ 'Node 'Sum es => Prism' o val -> Optic key val t o+ AbsurdLeaf :: t ~ 'Leaf => Optic key val t o+ AbsurdIndexed :: t ~ 'IndexedNode k st => Optic key val t o++--------------------------------------------------------------------------------+-- Optics implementations+--------------------------------------------------------------------------------++instance KnownSymbol queryKey+ => ObjectSYM (Optic queryKey queryType) where++ object _ fields = Lens $ \afa obj ->+ case getFirst $ runAp_ fGetter fields of+ Nothing -> error "impossible" -- if it type checked, there's guaranteed to be a match+ Just getter ->+ let val = getter obj+ setter o a =+ runIdentity $ runAp (\s -> Identity $ fSetter s a o) fields+ in setter obj <$> afa val++ list _ = AbsurdIndexed+ textMap _ = AbsurdIndexed+ set _ = AbsurdIndexed+ vector _ = AbsurdIndexed++ prim = AbsurdLeaf++instance KnownSymbol queryKey+ => FieldSYM (Optic queryKey queryType) where++ data Field (Optic queryKey queryType) obj tree fieldType =+ Focus { fGetter :: First (obj -> queryType)+ , fSetter :: queryType+ -> obj+ -> fieldType+ }++ field :: forall field key subTree tree obj repr proxy edge.+ ( KnownSymbol key+ , edge ~ 'Edge key 'Singleton field subTree+ , tree ~ 'Node 'Product '[edge]+ )+ => proxy key+ -> (obj -> field)+ -> repr subTree field+ -> Field (Optic queryKey queryType) obj tree field+ field _ getter _ =+ case sameField (Proxy @'(queryKey, queryType)) (Proxy @'(key, field)) of+ Nothing ->+ Focus+ { fGetter = First Nothing+ , fSetter = \_ obj -> getter obj+ }+ Just Refl ->+ Focus+ { fGetter = First $ Just getter+ , fSetter = const+ }++ optField :: forall field key subTree tree obj repr proxy edge.+ ( KnownSymbol key+ , edge ~ 'Edge key 'Nullable field subTree+ , tree ~ 'Node 'Product '[edge]+ )+ => proxy key+ -> (obj -> Maybe field)+ -> repr subTree field+ -> Field (Optic queryKey queryType) obj tree (Maybe field)+ optField _ getter _ =+ case sameField (Proxy @'(queryKey, queryType)) (Proxy @'(key, Maybe field)) of+ Nothing ->+ Focus+ { fGetter = First Nothing+ , fSetter = \_ obj -> getter obj+ }+ Just Refl ->+ Focus+ { fGetter = First $ Just getter+ , fSetter = const+ }++instance KnownSymbol queryKey => UnionSYM (Optic queryKey queryType) where+ type Result (Optic queryKey queryType) union = Maybe queryType++ data Tag (Optic queryKey queryType) union tree vToRes =+ Facet+ { fExtract :: vToRes+ , fEmbed :: First (queryType -> union)+ }++ union _ tags = Prism $ \pafa ->+ case getFirst $ runAp_ fEmbed tags of+ Nothing -> error "impossible" -- if it type checked, there's guaranteed to be a match+ Just embed ->+ dimap f g $ right' pafa+ where+ f u = maybe (Left u) Right+ $ runIdentity (runAp (Identity . fExtract) tags) u+ g = either pure (fmap embed)++ tag :: forall name union v subTree tree proxy edge.+ ( KnownSymbol name+ , edge ~ 'Edge name 'Nullable v subTree+ , tree ~ 'Node 'Sum '[edge]+ )+ => proxy name+ -> (v -> union)+ -> Optic queryKey queryType subTree v+ -> Tag (Optic queryKey queryType) union tree (v -> Maybe queryType)+ tag _ embed _ =+ case sameField (Proxy @'(queryKey, queryType)) (Proxy @'(name, v)) of+ Nothing ->+ Facet+ { fExtract = const Nothing+ , fEmbed = First Nothing+ }+ Just Refl ->+ Facet+ { fExtract = Just+ , fEmbed = First $ Just embed+ }++--------------------------------------------------------------------------------+-- Utility+--------------------------------------------------------------------------------++-- | If the field identifiers are the same, we assume that the field types+-- are also equal, however, this is not enforced by the type system. The+-- TypeAtPath type family is relied upon to enforce this invariant.+sameField :: forall fieldA fieldB typeA typeB.+ (KnownSymbol fieldA, KnownSymbol fieldB)+ => Proxy '(fieldA ,typeA)+ -> Proxy '(fieldB, typeB)+ -> Maybe ('(fieldA, typeA) :~: '(fieldB, typeB))+sameField _ _ =+ unsafeCoerce <$> sameSymbol (Proxy @fieldA) (Proxy @fieldB)+
+ src/Typson/Pathing.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+--------------------------------------------------------------------------------+-- |+-- Module : Typson.Pathing+-- Description : Provides JSON pathing primitives+-- Copyright : (c) Aaron Allen, 2020+-- Maintainer : Aaron Allen <aaronallen8455@gmail.com>+-- License : BSD-style (see the file LICENSE)+-- Stability : experimental+-- Portability : non-portable+--+--------------------------------------------------------------------------------+module Typson.Pathing+ ( -- * Pathing+ -- | Components for constructing JSON paths for queries.+ type (:->)+ , TypeAtPath+ , typeAtPath+ -- * Path Reflection+ , PathComponent(..)+ , ReflectPath(..)+ , sqlPath+ ) where++import Data.Kind (Type)+import Data.List (intercalate)+import qualified Data.List.NonEmpty as NE+import Data.Proxy (Proxy(..))+import GHC.TypeLits (ErrorMessage(..), KnownNat, KnownSymbol, Nat, Symbol, TypeError, natVal, symbolVal)++import Typson.JsonTree (Edge(..), Multiplicity(..), Tree(..))++--------------------------------------------------------------------------------+-- Type-level PostgreSQL JSON path components+--------------------------------------------------------------------------------++-- | A type operator for building a JSON query path from multiple components.+--+-- @+-- type MyQuery = "foo" :-> "bar" :-> 2 :-> "baz"+-- @+data key :-> path -- key is polykinded, can be a Symbol or a Nat+infixr 4 :->++--------------------------------------------------------------------------------+-- Get the result type for a query at a given path+--------------------------------------------------------------------------------++-- | Get the result type for a query at a given path.+typeAtPath :: proxy path -- ^ A path proxy+ -> repr tree obj -- ^ Schema for the type being queried+ -> Proxy (TypeAtPath obj tree path)+typeAtPath _ _ = Proxy++-- | Determine the type of the query result for a path into a JSON schema.+-- Nullability is propagated so that the result will be wrapped with 'Maybe' if+-- one or more components of the path are nullable.+type family TypeAtPath (obj :: Type) (tree :: Tree) (path :: k) :: Type where+ -- Final key matches, return the field's type+ TypeAtPath obj+ ('Node aggr ('Edge fieldName q field subTree ': rest))+ fieldName+ = ApQuantity q field++ -- Final component is a map key, return the field's type+ TypeAtPath (f obj)+ ('IndexedNode k subTree)+ (key :: k)+ = ApQuantity 'Nullable obj++ -- Accept any valid key as the index into a map+ TypeAtPath (f obj)+ ('IndexedNode k subTree)+ ((key :: k) :-> nextKey)+ = ApQuantity 'Nullable (TypeAtPath obj subTree nextKey)++ -- Invalid Map key+ TypeAtPath obj+ ('IndexedNode k subTree)+ key+ = TypeError ('Text "Invalid JSON path: expected a "+ ':<>: 'ShowType k+ ':<>: 'Text " index for "+ ':<>: 'ShowType obj+ ':<>: 'Text " but got \""+ ':<>: 'ShowType key+ ':<>: 'Text "\"."+ )++ -- Key matches, descend into sub-object preserving Maybe+ TypeAtPath obj+ ('Node aggr ('Edge fieldName q field subFields ': rest))+ (fieldName :-> nextKey)+ = ApQuantity q (TypeAtPath field subFields nextKey)++ -- Key doesn't match, try the next field+ TypeAtPath obj+ ('Node aggr ('Edge fieldName q field subFields ': rest))+ key+ = TypeAtPath obj ('Node aggr rest) key++ -- No match for the key+ TypeAtPath obj tree (key :: Symbol) = TypeError (MissingKey obj key)+ TypeAtPath obj tree ((key :: Symbol) :-> path) = TypeError (MissingKey obj key)+ TypeAtPath obj tree (idx :-> nextKey) = TypeError (InvalidKey idx obj)+ TypeAtPath obj tree idx = TypeError (InvalidKey idx obj)++type MissingKey obj key+ = 'Text "JSON key not present in "+ ':<>: 'ShowType obj+ ':<>: 'Text ": \""+ ':<>: 'Text key+ ':<>: 'Text "\"" -- this is requiring UndecidableInstances++type InvalidKey idx obj+ = 'Text "Invalid JSON path: expected a key for "+ ':<>: 'ShowType obj+ ':<>: 'Text " but got "+ ':<>: 'ShowType idx++--------------------------------------------------------------------------------+-- Utilities+--------------------------------------------------------------------------------++-- | Applies a field's multiplicity to the type it contains.+-- Using this requires UndecidableInstances+type family ApQuantity (q :: Multiplicity) (b :: Type) :: Type where+ ApQuantity 'Nullable (Maybe a) = Maybe a+ ApQuantity 'Nullable a = Maybe a+ ApQuantity 'Singleton a = a++--------------------------------------------------------------------------------+-- Path Reflection+--------------------------------------------------------------------------------++data PathComponent+ = Key String+ | Idx Integer++class ReflectPath path where+ -- | Reflect a type-level path to it's value level 'PathComponent's.+ reflectPath :: proxy path -> NE.NonEmpty PathComponent++instance KnownSymbol key => ReflectPath (key :: Symbol) where+ reflectPath _ = Key (symbolVal (Proxy @key)) NE.:| []++instance KnownNat idx => ReflectPath (idx :: Nat) where+ reflectPath _ = Idx (natVal (Proxy @idx)) NE.:| []++instance (ReflectPath key, ReflectPath path)+ => ReflectPath (key :-> path) where+ reflectPath _ = reflectPath (Proxy @key) <> reflectPath (Proxy @path)++-- | Reflect a path as an SQL JSON path string+sqlPath :: ReflectPath path => proxy path -> String+sqlPath = intercalate " -> " . map pathToString . NE.toList . reflectPath+ where+ pathToString (Key s) = "'" <> s <> "'"+ pathToString (Idx i) = show i
+ typson-core.cabal view
@@ -0,0 +1,41 @@+cabal-version: 1.12+name: typson-core+version: 0.1.0.0+license: BSD3+license-file: LICENSE+copyright: 2020 Aaron Allen+maintainer: aaronallen8455@gmail.com+author: Aaron Allen+homepage: https://github.com/aaronallen8455/typson#readme+bug-reports: https://github.com/aaronallen8455/typson/issues+synopsis: Type-safe PostgreSQL JSON Querying+description:+ Please see the README on GitHub at <https://github.com/aaronallen8455/typson#readme>++category: Database+build-type: Simple+extra-source-files: ChangeLog.md++source-repository head+ type: git+ location: https://github.com/aaronallen8455/typson++library+ exposed-modules:+ Typson+ Typson.JsonTree+ Typson.Optics+ Typson.Pathing++ hs-source-dirs: src+ other-modules: Paths_typson_core+ default-language: Haskell2010+ ghc-options: -Wall+ build-depends:+ aeson >=1.4.7.1 && <1.5,+ base >=4.7 && <5,+ containers >=0.6.2.1 && <0.7,+ profunctors >=5.5.2 && <5.6,+ text >=1.2.4.0 && <1.3,+ unordered-containers >=0.2.10.0 && <0.3,+ vector >=0.12.1.2 && <0.13