diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for typson-core + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. 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/src/Typson.hs b/src/Typson.hs new file mode 100644 --- /dev/null +++ b/src/Typson.hs @@ -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 diff --git a/src/Typson/JsonTree.hs b/src/Typson/JsonTree.hs new file mode 100644 --- /dev/null +++ b/src/Typson/JsonTree.hs @@ -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 +-- 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 + diff --git a/src/Typson/Optics.hs b/src/Typson/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Typson/Optics.hs @@ -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 +-- 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) + diff --git a/src/Typson/Pathing.hs b/src/Typson/Pathing.hs new file mode 100644 --- /dev/null +++ b/src/Typson/Pathing.hs @@ -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 +-- 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 diff --git a/typson-core.cabal b/typson-core.cabal new file mode 100644 --- /dev/null +++ b/typson-core.cabal @@ -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 + +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