{-# 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 StashValue x -> StashValue x -> StashValue x
addStash forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Provenance], x) -> StashValue x
promoteToStash) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty
    promoteToStash :: ([Provenance], x) -> StashValue x
    promoteToStash :: ([Provenance], x) -> StashValue x
promoteToStash ([Provenance]
p, x
x) =
      forall a. NonEmpty ([Provenance], a) -> IntSet -> StashValue a
StashValue
        (forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Provenance]
p, x
x))
        (Key -> IntSet
IntSet.singleton (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 = forall a. (a -> Bool) -> NonEmpty a -> [a]
NEL.filter ((Key -> IntSet -> Bool
`IntSet.notMember` forall a. StashValue a -> IntSet
stashHash StashValue x
old) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Hashable a => a -> Key
hash) NonEmpty ([Provenance], x)
newVal
       in forall a. NonEmpty ([Provenance], a) -> IntSet -> StashValue a
StashValue
            (forall a. NonEmpty a -> [a] -> NonEmpty a
addListToNE (forall a. StashValue a -> NonEmpty ([Provenance], a)
getStashValue StashValue x
old) [([Provenance], x)]
insertableVals)
            (IntSet -> IntSet -> IntSet
IntSet.union ([Key] -> IntSet
IntSet.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Hashable a => a -> Key
hash forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
NEL.toList forall a b. (a -> b) -> a -> b
$ NonEmpty ([Provenance], x)
newVal) (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 = forall a. [a] -> NonEmpty a
NEL.fromList (forall a. NonEmpty a -> [a]
NEL.toList NonEmpty a
ne 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 =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a. NonEmpty a -> [a]
NEL.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. StashValue a -> NonEmpty ([Provenance], a)
getStashValue) (forall {k1} (k2 :: k1 -> *) (f :: k1 -> *) (v :: k1).
GCompare k2 =>
k2 v -> DMap k2 f -> Maybe (f v)
DM.lookup forall {k} (a :: k). Typeable a => TypeRep a
R.typeRep (Stash -> DMap TypeRep StashValue
getStash Stash
stash))
    forall a. Semigroup a => a -> a -> a
<> 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 =
    forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\[([Provenance], x)]
xs -> (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> a
fst [([Provenance], x)]
xs, forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [([Provenance], x)]
xs)) forall a b. (a -> b) -> a -> b
$ forall {a}. [a] -> [[a]]
notpowerset 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 = []forall a. a -> [a] -> [a]
:[a]
xsforall a. a -> [a] -> [a]
:forall a b. (a -> b) -> [a] -> [b]
map 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall x. x -> Compound x
Compound forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => Rep a x -> a
to) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 =
    (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k (f :: k -> *) (a :: k).
GBuildFrom f =>
Stash -> [([Provenance], f a)]
gExtras Stash
stash)
      forall a. Semigroup a => a -> a -> a
<> (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall a. Semigroup a => a -> a -> a
<> [Provenance]
pb, a a
a' forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: b a
b') | ([Provenance]
pa, a a
a') <- forall k (f :: k -> *) (a :: k).
GBuildFrom f =>
Stash -> [([Provenance], f a)]
gExtras Stash
stash, ([Provenance]
pb, b a
b') <- 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k i c (p :: k). c -> K1 i c p
K1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
_ = [([], forall k (p :: k). U1 p
U1)]

deriving via (Atom NoContent) instance BuildFrom NoContent