{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Roboservant.Types.BuildFrom where

import Data.List(nub)
import qualified Data.Dependent.Map as DM
import Data.Hashable
import qualified Data.IntSet as IntSet
import Data.Kind
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NEL
import Data.Typeable (Typeable)
import GHC.Generics
import Roboservant.Types.Internal
import qualified Type.Reflection as R
import Servant(NoContent)
import Roboservant.Types.Orphans()

buildFrom :: forall x. (Hashable x, BuildFrom x, Typeable x) => Stash -> Maybe (StashValue x)
buildFrom :: forall x.
(Hashable x, BuildFrom x, Typeable x) =>
Stash -> Maybe (StashValue x)
buildFrom = [([Provenance], x)] -> Maybe (StashValue x)
buildStash ([([Provenance], x)] -> Maybe (StashValue x))
-> (Stash -> [([Provenance], x)]) -> Stash -> Maybe (StashValue x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stash -> [([Provenance], x)]
forall x.
(Hashable x, BuildFrom x, Typeable x) =>
Stash -> [([Provenance], x)]
buildFrom'
  where
    buildStash :: [([Provenance], x)] -> Maybe (StashValue x)
    buildStash :: [([Provenance], x)] -> Maybe (StashValue x)
buildStash = (NonEmpty ([Provenance], x) -> StashValue x)
-> Maybe (NonEmpty ([Provenance], x)) -> Maybe (StashValue x)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((StashValue x -> StashValue x -> StashValue x)
-> NonEmpty (StashValue x) -> StashValue x
forall a. (a -> a -> a) -> NonEmpty a -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 StashValue x -> StashValue x -> StashValue x
addStash (NonEmpty (StashValue x) -> StashValue x)
-> (NonEmpty ([Provenance], x) -> NonEmpty (StashValue x))
-> NonEmpty ([Provenance], x)
-> StashValue x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Provenance], x) -> StashValue x)
-> NonEmpty ([Provenance], x) -> NonEmpty (StashValue x)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Provenance], x) -> StashValue x
promoteToStash) (Maybe (NonEmpty ([Provenance], x)) -> Maybe (StashValue x))
-> ([([Provenance], x)] -> Maybe (NonEmpty ([Provenance], x)))
-> [([Provenance], x)]
-> Maybe (StashValue x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [([Provenance], x)] -> Maybe (NonEmpty ([Provenance], x))
forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty
    promoteToStash :: ([Provenance], x) -> StashValue x
    promoteToStash :: ([Provenance], x) -> StashValue x
promoteToStash ([Provenance]
p, x
x) =
      NonEmpty ([Provenance], x) -> IntSet -> StashValue x
forall a. NonEmpty ([Provenance], a) -> IntSet -> StashValue a
StashValue
        (([Provenance], x) -> NonEmpty ([Provenance], x)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Provenance]
p, x
x))
        (Key -> IntSet
IntSet.singleton (x -> Key
forall a. Hashable a => a -> Key
hash x
x))
    addStash :: StashValue x -> StashValue x -> StashValue x
    addStash :: StashValue x -> StashValue x -> StashValue x
addStash StashValue x
old (StashValue NonEmpty ([Provenance], x)
newVal IntSet
_) =
      let insertableVals :: [([Provenance], x)]
insertableVals = (([Provenance], x) -> Bool)
-> NonEmpty ([Provenance], x) -> [([Provenance], x)]
forall a. (a -> Bool) -> NonEmpty a -> [a]
NEL.filter ((Key -> IntSet -> Bool
`IntSet.notMember` StashValue x -> IntSet
forall a. StashValue a -> IntSet
stashHash StashValue x
old) (Key -> Bool)
-> (([Provenance], x) -> Key) -> ([Provenance], x) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Provenance], x) -> Key
forall a. Hashable a => a -> Key
hash) NonEmpty ([Provenance], x)
newVal
       in NonEmpty ([Provenance], x) -> IntSet -> StashValue x
forall a. NonEmpty ([Provenance], a) -> IntSet -> StashValue a
StashValue
            (NonEmpty ([Provenance], x)
-> [([Provenance], x)] -> NonEmpty ([Provenance], x)
forall a. NonEmpty a -> [a] -> NonEmpty a
addListToNE (StashValue x -> NonEmpty ([Provenance], x)
forall a. StashValue a -> NonEmpty ([Provenance], a)
getStashValue StashValue x
old) [([Provenance], x)]
insertableVals)
            (IntSet -> IntSet -> IntSet
IntSet.union ([Key] -> IntSet
IntSet.fromList ([Key] -> IntSet)
-> (NonEmpty ([Provenance], x) -> [Key])
-> NonEmpty ([Provenance], x)
-> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (x -> Key) -> [x] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map x -> Key
forall a. Hashable a => a -> Key
hash ([x] -> [Key])
-> (NonEmpty ([Provenance], x) -> [x])
-> NonEmpty ([Provenance], x)
-> [Key]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Provenance], x) -> x) -> [([Provenance], x)] -> [x]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Provenance], x) -> x
forall a b. (a, b) -> b
snd ([([Provenance], x)] -> [x])
-> (NonEmpty ([Provenance], x) -> [([Provenance], x)])
-> NonEmpty ([Provenance], x)
-> [x]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty ([Provenance], x) -> [([Provenance], x)]
forall a. NonEmpty a -> [a]
NEL.toList (NonEmpty ([Provenance], x) -> IntSet)
-> NonEmpty ([Provenance], x) -> IntSet
forall a b. (a -> b) -> a -> b
$ NonEmpty ([Provenance], x)
newVal) (StashValue x -> IntSet
forall a. StashValue a -> IntSet
stashHash StashValue x
old))
    addListToNE :: NonEmpty a -> [a] -> NonEmpty a
    addListToNE :: forall a. NonEmpty a -> [a] -> NonEmpty a
addListToNE NonEmpty a
ne [a]
l = [a] -> NonEmpty a
forall a. HasCallStack => [a] -> NonEmpty a
NEL.fromList (NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
NEL.toList NonEmpty a
ne [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [a]
l)

buildFrom' :: forall x. (Hashable x, BuildFrom x, Typeable x) => Stash -> [([Provenance], x)]
buildFrom' :: forall x.
(Hashable x, BuildFrom x, Typeable x) =>
Stash -> [([Provenance], x)]
buildFrom' Stash
stash =
  [([Provenance], x)]
-> (StashValue x -> [([Provenance], x)])
-> Maybe (StashValue x)
-> [([Provenance], x)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (NonEmpty ([Provenance], x) -> [([Provenance], x)]
forall a. NonEmpty a -> [a]
NEL.toList (NonEmpty ([Provenance], x) -> [([Provenance], x)])
-> (StashValue x -> NonEmpty ([Provenance], x))
-> StashValue x
-> [([Provenance], x)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StashValue x -> NonEmpty ([Provenance], x)
forall a. StashValue a -> NonEmpty ([Provenance], a)
getStashValue) (TypeRep x -> DMap TypeRep StashValue -> Maybe (StashValue x)
forall {k1} (k2 :: k1 -> *) (f :: k1 -> *) (v :: k1).
GCompare k2 =>
k2 v -> DMap k2 f -> Maybe (f v)
DM.lookup TypeRep x
forall {k} (a :: k). Typeable a => TypeRep a
R.typeRep (Stash -> DMap TypeRep StashValue
getStash Stash
stash))
    [([Provenance], x)] -> [([Provenance], x)] -> [([Provenance], x)]
forall a. Semigroup a => a -> a -> a
<> Stash -> [([Provenance], x)]
forall x. BuildFrom x => Stash -> [([Provenance], x)]
extras Stash
stash

class (Hashable x, Typeable x) => BuildFrom (x :: Type) where
  extras :: Stash -> [([Provenance], x)]

instance (Hashable x, Typeable x) => BuildFrom (Atom x) where
  extras :: Stash -> [([Provenance], Atom x)]
extras Stash
_ = []

deriving via (Atom Bool) instance BuildFrom Bool

deriving via (Compound (Maybe x)) instance (Typeable x, Hashable x, BuildFrom x) => BuildFrom (Maybe x)

-- this isn't wonderful, but we need a hand-rolled instance for recursive datatypes right now.
-- with an arbitrary-ish interface, we could use a size parameter, rng access etc.
instance (Eq x, BuildFrom x) => BuildFrom [x] where
  extras :: Stash -> [([Provenance], [x])]
extras Stash
stash =
    [([Provenance], [x])] -> [([Provenance], [x])]
forall a. Eq a => [a] -> [a]
nub ([([Provenance], [x])] -> [([Provenance], [x])])
-> [([Provenance], [x])] -> [([Provenance], [x])]
forall a b. (a -> b) -> a -> b
$ ([([Provenance], x)] -> ([Provenance], [x]))
-> [[([Provenance], x)]] -> [([Provenance], [x])]
forall a b. (a -> b) -> [a] -> [b]
map (\[([Provenance], x)]
xs -> ((([Provenance], x) -> [Provenance])
-> [([Provenance], x)] -> [Provenance]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Provenance], x) -> [Provenance]
forall a b. (a, b) -> a
fst [([Provenance], x)]
xs, (([Provenance], x) -> x) -> [([Provenance], x)] -> [x]
forall a b. (a -> b) -> [a] -> [b]
map ([Provenance], x) -> x
forall a b. (a, b) -> b
snd [([Provenance], x)]
xs)) ([[([Provenance], x)]] -> [([Provenance], [x])])
-> [[([Provenance], x)]] -> [([Provenance], [x])]
forall a b. (a -> b) -> a -> b
$ [([Provenance], x)] -> [[([Provenance], x)]]
forall {a}. [a] -> [[a]]
notpowerset ([([Provenance], x)] -> [[([Provenance], x)]])
-> [([Provenance], x)] -> [[([Provenance], x)]]
forall a b. (a -> b) -> a -> b
$ forall x.
(Hashable x, BuildFrom x, Typeable x) =>
Stash -> [([Provenance], x)]
buildFrom' @x Stash
stash
    where
      -- powerset creates way too much stuff. something better here eventually.
      notpowerset :: [a] -> [[a]]
notpowerset [a]
xs = [][a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[a]
xs[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:(a -> [a]) -> [a] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map a -> [a]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
xs


instance (Hashable x, Typeable x, Generic x, GBuildFrom (Rep x)) => BuildFrom (Compound (x :: Type)) where
  extras :: Stash -> [([Provenance], Compound x)]
extras Stash
stash = (Rep x Any -> Compound x)
-> ([Provenance], Rep x Any) -> ([Provenance], Compound x)
forall a b. (a -> b) -> ([Provenance], a) -> ([Provenance], b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (x -> Compound x
forall x. x -> Compound x
Compound (x -> Compound x) -> (Rep x Any -> x) -> Rep x Any -> Compound x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep x Any -> x
forall a x. Generic a => Rep a x -> a
forall x. Rep x x -> x
to) (([Provenance], Rep x Any) -> ([Provenance], Compound x))
-> [([Provenance], Rep x Any)] -> [([Provenance], Compound x)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stash -> [([Provenance], Rep x Any)]
forall a. Stash -> [([Provenance], Rep x a)]
forall k (f :: k -> *) (a :: k).
GBuildFrom f =>
Stash -> [([Provenance], f a)]
gExtras Stash
stash

deriving via (Atom Int) instance BuildFrom Int

deriving via (Atom Char) instance BuildFrom Char

class GBuildFrom (f :: k -> Type) where
  gExtras :: Stash -> [([Provenance], f a)]

instance GBuildFrom b => GBuildFrom (M1 D a b) where
  gExtras :: forall (a :: k). Stash -> [([Provenance], M1 D a b a)]
gExtras = (([Provenance], b a) -> ([Provenance], M1 D a b a))
-> [([Provenance], b a)] -> [([Provenance], M1 D a b a)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((b a -> M1 D a b a)
-> ([Provenance], b a) -> ([Provenance], M1 D a b a)
forall a b. (a -> b) -> ([Provenance], a) -> ([Provenance], b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b a -> M1 D a b a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1) ([([Provenance], b a)] -> [([Provenance], M1 D a b a)])
-> (Stash -> [([Provenance], b a)])
-> Stash
-> [([Provenance], M1 D a b a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stash -> [([Provenance], b a)]
forall (a :: k). Stash -> [([Provenance], b a)]
forall k (f :: k -> *) (a :: k).
GBuildFrom f =>
Stash -> [([Provenance], f a)]
gExtras

-- not recursion safe!
instance (GBuildFrom a, GBuildFrom b) => GBuildFrom (a :+: b) where
  gExtras :: forall (a :: k). Stash -> [([Provenance], (:+:) a b a)]
gExtras Stash
stash =
    ((a a -> (:+:) a b a)
-> ([Provenance], a a) -> ([Provenance], (:+:) a b a)
forall a b. (a -> b) -> ([Provenance], a) -> ([Provenance], b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a a -> (:+:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (([Provenance], a a) -> ([Provenance], (:+:) a b a))
-> [([Provenance], a a)] -> [([Provenance], (:+:) a b a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stash -> [([Provenance], a a)]
forall (a :: k). Stash -> [([Provenance], a a)]
forall k (f :: k -> *) (a :: k).
GBuildFrom f =>
Stash -> [([Provenance], f a)]
gExtras Stash
stash)
      [([Provenance], (:+:) a b a)]
-> [([Provenance], (:+:) a b a)] -> [([Provenance], (:+:) a b a)]
forall a. Semigroup a => a -> a -> a
<> ((b a -> (:+:) a b a)
-> ([Provenance], b a) -> ([Provenance], (:+:) a b a)
forall a b. (a -> b) -> ([Provenance], a) -> ([Provenance], b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b a -> (:+:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (([Provenance], b a) -> ([Provenance], (:+:) a b a))
-> [([Provenance], b a)] -> [([Provenance], (:+:) a b a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stash -> [([Provenance], b a)]
forall (a :: k). Stash -> [([Provenance], b a)]
forall k (f :: k -> *) (a :: k).
GBuildFrom f =>
Stash -> [([Provenance], f a)]
gExtras Stash
stash)

instance (GBuildFrom a, GBuildFrom b) => GBuildFrom (a :*: b) where
  gExtras :: forall (a :: k). Stash -> [([Provenance], (:*:) a b a)]
gExtras Stash
stash = [([Provenance]
pa [Provenance] -> [Provenance] -> [Provenance]
forall a. Semigroup a => a -> a -> a
<> [Provenance]
pb, a a
a' a a -> b a -> (:*:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: b a
b') | ([Provenance]
pa, a a
a') <- Stash -> [([Provenance], a a)]
forall (a :: k). Stash -> [([Provenance], a a)]
forall k (f :: k -> *) (a :: k).
GBuildFrom f =>
Stash -> [([Provenance], f a)]
gExtras Stash
stash, ([Provenance]
pb, b a
b') <- Stash -> [([Provenance], b a)]
forall (a :: k). Stash -> [([Provenance], b a)]
forall k (f :: k -> *) (a :: k).
GBuildFrom f =>
Stash -> [([Provenance], f a)]
gExtras Stash
stash]

instance GBuildFrom b => GBuildFrom (M1 C a b) where
  gExtras :: forall (a :: k). Stash -> [([Provenance], M1 C a b a)]
gExtras = (([Provenance], b a) -> ([Provenance], M1 C a b a))
-> [([Provenance], b a)] -> [([Provenance], M1 C a b a)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((b a -> M1 C a b a)
-> ([Provenance], b a) -> ([Provenance], M1 C a b a)
forall a b. (a -> b) -> ([Provenance], a) -> ([Provenance], b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b a -> M1 C a b a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1) ([([Provenance], b a)] -> [([Provenance], M1 C a b a)])
-> (Stash -> [([Provenance], b a)])
-> Stash
-> [([Provenance], M1 C a b a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stash -> [([Provenance], b a)]
forall (a :: k). Stash -> [([Provenance], b a)]
forall k (f :: k -> *) (a :: k).
GBuildFrom f =>
Stash -> [([Provenance], f a)]
gExtras

instance GBuildFrom b => GBuildFrom (M1 S a b) where
  gExtras :: forall (a :: k). Stash -> [([Provenance], M1 S a b a)]
gExtras = (([Provenance], b a) -> ([Provenance], M1 S a b a))
-> [([Provenance], b a)] -> [([Provenance], M1 S a b a)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((b a -> M1 S a b a)
-> ([Provenance], b a) -> ([Provenance], M1 S a b a)
forall a b. (a -> b) -> ([Provenance], a) -> ([Provenance], b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b a -> M1 S a b a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1) ([([Provenance], b a)] -> [([Provenance], M1 S a b a)])
-> (Stash -> [([Provenance], b a)])
-> Stash
-> [([Provenance], M1 S a b a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stash -> [([Provenance], b a)]
forall (a :: k). Stash -> [([Provenance], b a)]
forall k (f :: k -> *) (a :: k).
GBuildFrom f =>
Stash -> [([Provenance], f a)]
gExtras

instance BuildFrom a => GBuildFrom (K1 i a) where
  gExtras :: forall (a :: k). Stash -> [([Provenance], K1 i a a)]
gExtras = (([Provenance], a) -> ([Provenance], K1 i a a))
-> [([Provenance], a)] -> [([Provenance], K1 i a a)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> K1 i a a) -> ([Provenance], a) -> ([Provenance], K1 i a a)
forall a b. (a -> b) -> ([Provenance], a) -> ([Provenance], b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1) ([([Provenance], a)] -> [([Provenance], K1 i a a)])
-> (Stash -> [([Provenance], a)])
-> Stash
-> [([Provenance], K1 i a a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stash -> [([Provenance], a)]
forall x.
(Hashable x, BuildFrom x, Typeable x) =>
Stash -> [([Provenance], x)]
buildFrom'

instance GBuildFrom U1 where
  gExtras :: forall (a :: k). Stash -> [([Provenance], U1 a)]
gExtras Stash
_ = [([], U1 a
forall k (p :: k). U1 p
U1)]

deriving via (Atom NoContent) instance BuildFrom NoContent