{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
module Typson.Pathing
(
type (:->)
, TypeAtPath
, typeAtPath
, 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(..))
data key :-> path
infixr 4 :->
typeAtPath :: proxy path
-> repr tree obj
-> Proxy (TypeAtPath obj tree path)
typeAtPath :: proxy path -> repr tree obj -> Proxy (TypeAtPath obj tree path)
typeAtPath _ _ = Proxy (TypeAtPath obj tree path)
forall k (t :: k). Proxy t
Proxy
type family TypeAtPath (obj :: Type) (tree :: Tree) (path :: k) :: Type where
TypeAtPath obj
('Node aggr ('Edge fieldName q field subTree ': rest))
fieldName
= ApQuantity q field
TypeAtPath (f obj)
('IndexedNode k subTree)
(key :: k)
= ApQuantity 'Nullable obj
TypeAtPath (f obj)
('IndexedNode k subTree)
((key :: k) :-> nextKey)
= ApQuantity 'Nullable (TypeAtPath obj subTree nextKey)
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 "\"."
)
TypeAtPath obj
('Node aggr ('Edge fieldName q field subFields ': rest))
(fieldName :-> nextKey)
= ApQuantity q (TypeAtPath field subFields nextKey)
TypeAtPath obj
('Node aggr ('Edge fieldName q field subFields ': rest))
key
= TypeAtPath obj ('Node aggr rest) 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 "\""
type InvalidKey idx obj
= 'Text "Invalid JSON path: expected a key for "
':<>: 'ShowType obj
':<>: 'Text " but got "
':<>: 'ShowType idx
type family ApQuantity (q :: Multiplicity) (b :: Type) :: Type where
ApQuantity 'Nullable (Maybe a) = Maybe a
ApQuantity 'Nullable a = Maybe a
ApQuantity 'Singleton a = a
data PathComponent
= Key String
| Idx Integer
class ReflectPath path where
reflectPath :: proxy path -> NE.NonEmpty PathComponent
instance KnownSymbol key => ReflectPath (key :: Symbol) where
reflectPath :: proxy key -> NonEmpty PathComponent
reflectPath _ = String -> PathComponent
Key (Proxy key -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy key
forall k (t :: k). Proxy t
Proxy @key)) PathComponent -> [PathComponent] -> NonEmpty PathComponent
forall a. a -> [a] -> NonEmpty a
NE.:| []
instance KnownNat idx => ReflectPath (idx :: Nat) where
reflectPath :: proxy idx -> NonEmpty PathComponent
reflectPath _ = Integer -> PathComponent
Idx (Proxy idx -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy idx
forall k (t :: k). Proxy t
Proxy @idx)) PathComponent -> [PathComponent] -> NonEmpty PathComponent
forall a. a -> [a] -> NonEmpty a
NE.:| []
instance (ReflectPath key, ReflectPath path)
=> ReflectPath (key :-> path) where
reflectPath :: proxy (key :-> path) -> NonEmpty PathComponent
reflectPath _ = Proxy key -> NonEmpty PathComponent
forall k (path :: k) (proxy :: k -> *).
ReflectPath path =>
proxy path -> NonEmpty PathComponent
reflectPath (Proxy key
forall k (t :: k). Proxy t
Proxy @key) NonEmpty PathComponent
-> NonEmpty PathComponent -> NonEmpty PathComponent
forall a. Semigroup a => a -> a -> a
<> Proxy path -> NonEmpty PathComponent
forall k (path :: k) (proxy :: k -> *).
ReflectPath path =>
proxy path -> NonEmpty PathComponent
reflectPath (Proxy path
forall k (t :: k). Proxy t
Proxy @path)
sqlPath :: ReflectPath path => proxy path -> String
sqlPath :: proxy path -> String
sqlPath = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate " -> " ([String] -> String)
-> (proxy path -> [String]) -> proxy path -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PathComponent -> String) -> [PathComponent] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PathComponent -> String
pathToString ([PathComponent] -> [String])
-> (proxy path -> [PathComponent]) -> proxy path -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty PathComponent -> [PathComponent]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty PathComponent -> [PathComponent])
-> (proxy path -> NonEmpty PathComponent)
-> proxy path
-> [PathComponent]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. proxy path -> NonEmpty PathComponent
forall k (path :: k) (proxy :: k -> *).
ReflectPath path =>
proxy path -> NonEmpty PathComponent
reflectPath
where
pathToString :: PathComponent -> String
pathToString (Key s :: String
s) = "'" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "'"
pathToString (Idx i :: Integer
i) = Integer -> String
forall a. Show a => a -> String
show Integer
i