{-# 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 path -> repr tree obj -> Proxy (TypeAtPath obj tree path)
typeAtPath _ _ = Proxy (TypeAtPath obj tree path)
forall k (t :: k). Proxy t
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 :: 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)

-- | Reflect a path as an SQL JSON path string
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