@@ -1,13 +1,15 @@
1−{-# LANGUAGE DefaultSignatures #-}
2−{-# LANGUAGE DerivingStrategies #-}
1+
2+
33{-# LANGUAGE ScopedTypeVariables #-}
4−{-# LANGUAGE TypeApplications #-}
4+
55{-# LANGUAGE TypeFamilies #-}
66{-# LANGUAGE StandaloneDeriving #-}
77{-# LANGUAGE DerivingVia #-}
88
99
1010
11+
12+
1113module Roboservant.Types.BuildFrom where
1214
1315import Data.List.NonEmpty (NonEmpty(..))
@@ -18,17 +20,63 @@ import qualified Type.Reflection as R
1820import Data.Kind
1921import Roboservant.Types.Internal
2022import Data.Hashable
23+import qualified Data.IntSet as IntSet
24+import Data.IntSet(IntSet)
25+import Data.Maybe(catMaybes,fromMaybe)
26+
27+buildFrom :: forall x . (Hashable x, BuildFrom x, Typeable x) => Stash -> Maybe (StashValue x)
28+buildFrom stash = buildStash (maybe [] (NEL.toList . getStashValue) (DM.lookup R.typeRep (getStash stash))
29+ <> extras stash )
30+ where
31+
32+ buildStash :: [([Provenance], x)] -> Maybe (StashValue x)
33+ buildStash = fmap (foldr1 addStash . fmap promoteToStash) . NEL.nonEmpty
34+
35+ promoteToStash :: ([Provenance], x) -> StashValue x
36+ promoteToStash (p,x) = StashValue (pure (p,x))
37+ (IntSet.singleton (hash x))
38+
39+ -- | sorta fiddly. looks like (<>), but in general it's not safe to add arbitrary StashValues, because
40+ -- there's no guarantee that they came from the same run, which would invalidate all the provenance stuff.
41+ -- in this context it's safe because we have no access to anything else.
42+ --
43+ -- we _do_ have to check here that the new elements are not already contained, however.
44+ addStash :: StashValue x -> StashValue x -> StashValue x
45+ addStash old (StashValue newVal _)
46+ = let insertableVals = NEL.filter ((`IntSet.notMember` stashHash old) . hash) newVal
47+ in StashValue ( addListToNE (getStashValue old) insertableVals )
48+ (IntSet.union (IntSet.fromList . map hash . fmap snd . NEL.toList $ newVal) (stashHash old))
2149
22−class Typeable x => BuildFrom (x :: Type) where
23− buildFrom :: Stash -> Maybe (StashValue x)
50+ addListToNE :: NonEmpty a -> [a] -> NonEmpty a
51+ addListToNE ne l = NEL.fromList (NEL.toList ne <> l)
2452
25−-- | this is a little esoteric: basically, we're always going to use this with
26−-- deriving-via, so we need to look up the underlying `x` and then wrap it in Atom.
27−instance Typeable x => BuildFrom (Atom x) where
28− buildFrom = fmap (fmap Atom) <$> DM.lookup R.typeRep . getStash
53+-- addToHash :: x -> IntSet -> IntSet
54+-- addToHash x = IntSet.insert
55+
56+class (Hashable x, Typeable x) => BuildFrom (x :: Type) where
57+ extras :: Stash -> [([Provenance], x)]
58+
59+instance (Hashable x, Typeable x) => BuildFrom (Atom x) where
60+ extras _ = []
2961
3062deriving via (Atom Bool) instance BuildFrom Bool
3163
64+-- instance (Typeable x, Hashable x, BuildFrom x) => BuildFrom (Maybe x) where
65+-- extras dict = _
66+
67+
68+-- collapseList :: (Hashable a, Typeable a) => [a] -> Maybe (StashValue a)
69+-- collapseList = fmap buildStashValue . NE.nonEmpty -- . filter jsonParseable
70+-- where
71+-- -- this is... not particularly principled. the provenance stuff probably needs to be reworked.
72+-- buildStashValue values = StashValue
73+-- { getStashValue = fmap ([],) values
74+-- , stashHash = IntSet.fromList $ hash <$> NE.toList values
75+-- }
76+-- -- instance (BuildFrom a) => BuildFrom [a] -- where
77+-- --breakdown x = toDyn x :| mconcat (map (NEL.toList . breakdown) x)
78+
79+
3280-- instance (Typeable x, Hashable x, BuildFrom x) => BuildFrom (Maybe x) where
3381-- buildFrom dict = Just options
3482-- where options :: StashValue (Maybe x)