mirror of
https://github.com/circuithub/rel8.git
synced 2024-08-17 20:00:23 +03:00
test
This commit is contained in:
parent
d08428cdb4
commit
8febff7309
@ -35,10 +35,8 @@ where
|
||||
-- base
|
||||
import Control.Applicative ( liftA2 )
|
||||
import Control.Monad ( join, liftM2 )
|
||||
import Data.Bifunctor ( bimap, first )
|
||||
import Data.Foldable ( traverse_ )
|
||||
import Data.Bifunctor ( bimap )
|
||||
import Data.Functor.Contravariant ( (>$<) )
|
||||
import Data.Maybe ( fromMaybe )
|
||||
import Prelude hiding ( filter, lookup, zip, zipWith )
|
||||
|
||||
-- rel8
|
||||
@ -78,7 +76,7 @@ import Data.Semigroup.Traversable.Class ( bitraverse1 )
|
||||
-- \"Identity\" 'Tabulation's are created using 'tabulate'. 'Tabulation's can
|
||||
-- be composed with 'Query's with 'prebind' or 'postbind' to form new
|
||||
-- 'Tabulation's.
|
||||
newtype Tabulation k a = Tabulation (k -> Query (Maybe k, a))
|
||||
newtype Tabulation k a = Tabulation (k -> Query (k, a))
|
||||
deriving stock Functor
|
||||
|
||||
|
||||
@ -97,18 +95,12 @@ instance EqTable k => Bind (Tabulation k) where
|
||||
|
||||
instance EqTable k => Monad (Tabulation k) where
|
||||
Tabulation as >>= f = Tabulation $ \i -> do
|
||||
(mk, a) <- as i
|
||||
case mk of
|
||||
Nothing -> case f a of
|
||||
Tabulation bs -> bs i
|
||||
Just k -> case f a of
|
||||
Tabulation bs -> do
|
||||
(mk', b) <- bs k
|
||||
case mk' of
|
||||
Nothing -> pure (mk, b)
|
||||
Just k' -> do
|
||||
where_ $ k ==: k'
|
||||
pure (mk', b)
|
||||
(k, a) <- as i
|
||||
case f a of
|
||||
Tabulation bs -> do
|
||||
(k', b) <- bs k
|
||||
where_ $ k ==: k'
|
||||
pure (k', b)
|
||||
|
||||
|
||||
instance EqTable k => AltTable (Tabulation k) where
|
||||
@ -133,7 +125,7 @@ instance (EqTable k, Table Expr a, Semigroup a) => Monoid (Tabulation k a)
|
||||
|
||||
|
||||
liftQuery :: Query a -> Tabulation k a
|
||||
liftQuery query = Tabulation $ const $ fmap (Nothing,) query
|
||||
liftQuery query = Tabulation $ \k -> fmap (k,) query
|
||||
|
||||
|
||||
-- | 'tabulate' creates an \"identity\" @'Tabulation' k a@ that allows @a@ be
|
||||
@ -172,12 +164,11 @@ tabulateA key a = fromQuery $ (,a) <$> key a
|
||||
|
||||
-- | Analgous to 'Data.Map.Strict.fromList'.
|
||||
fromQuery :: Query (k, a) -> Tabulation k a
|
||||
fromQuery = Tabulation . const . fmap (first Just)
|
||||
fromQuery = Tabulation . const
|
||||
|
||||
|
||||
indexed :: Tabulation k a -> Tabulation k (k, a)
|
||||
indexed (Tabulation query) = Tabulation $ \i ->
|
||||
(\(mk, a) -> (mk, (fromMaybe i mk, a))) <$> query i
|
||||
indexed (Tabulation query) = Tabulation $ fmap (\(k, a) -> (k, (k, a))) . query
|
||||
|
||||
|
||||
ifilter :: (k -> a -> Expr Bool) -> Tabulation k a -> Tabulation k a
|
||||
@ -209,8 +200,8 @@ infixr 1 `postbind`
|
||||
-- 'lookup' can and often does contain multiple results.
|
||||
lookup :: EqTable k => k -> Tabulation k a -> Query a
|
||||
lookup key (Tabulation query) = do
|
||||
(mk, a) <- query key
|
||||
traverse_ (where_ . (key ==:)) mk
|
||||
(k, a) <- query key
|
||||
where_ $ key ==: k
|
||||
pure a
|
||||
|
||||
|
||||
@ -355,7 +346,7 @@ optionalTabulation :: EqTable k
|
||||
=> Tabulation k a -> Tabulation k (MaybeTable a)
|
||||
optionalTabulation as = Tabulation $ \k -> do
|
||||
ma <- optional $ lookup k as
|
||||
pure (Just k, ma)
|
||||
pure (k, ma)
|
||||
|
||||
|
||||
manyTabulation :: (EqTable k, Table Expr a)
|
||||
@ -373,5 +364,4 @@ someTabulation = aggregateTabulation . fmap nonEmptyAgg
|
||||
|
||||
|
||||
toQuery :: Tabulation k a -> Tabulation k (Query (k, a))
|
||||
toQuery (Tabulation as) = Tabulation $ \k ->
|
||||
pure (Nothing, first (fromMaybe k) <$> as k)
|
||||
toQuery (Tabulation as) = Tabulation $ \k -> pure (k, as k)
|
||||
|
Loading…
Reference in New Issue
Block a user