{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Record.Anon.Internal.Plugin.TC.Row.KnownRow (
KnownRow(..)
, fromList
, toList
, visibleMap
, traverse
, indexed
, NotSubRow(..)
, isSubRow
) where
import Prelude hiding (traverse)
import qualified Prelude
import Control.Monad.State (State, evalState, state)
import Data.Either (partitionEithers)
import Data.Record.Anon.Internal.Core.FieldName (FieldName)
import Data.Record.Anon.Internal.Util.SmallHashMap (SmallHashMap)
import Data.Record.Anon.Internal.Plugin.TC.Row.KnownField (KnownField(..))
import Data.Record.Anon.Internal.Plugin.TC.GhcTcPluginAPI
import qualified Data.Record.Anon.Internal.Util.SmallHashMap as HashMap
data KnownRow a = KnownRow {
KnownRow a -> [KnownField a]
knownRecordVector :: [KnownField a]
, KnownRow a -> SmallHashMap FieldName Int
knownRecordVisible :: SmallHashMap FieldName Int
, KnownRow a -> Bool
knownRecordAllVisible :: Bool
}
deriving (a -> KnownRow b -> KnownRow a
(a -> b) -> KnownRow a -> KnownRow b
(forall a b. (a -> b) -> KnownRow a -> KnownRow b)
-> (forall a b. a -> KnownRow b -> KnownRow a) -> Functor KnownRow
forall a b. a -> KnownRow b -> KnownRow a
forall a b. (a -> b) -> KnownRow a -> KnownRow b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> KnownRow b -> KnownRow a
$c<$ :: forall a b. a -> KnownRow b -> KnownRow a
fmap :: (a -> b) -> KnownRow a -> KnownRow b
$cfmap :: forall a b. (a -> b) -> KnownRow a -> KnownRow b
Functor, KnownRow a -> Bool
(a -> m) -> KnownRow a -> m
(a -> b -> b) -> b -> KnownRow a -> b
(forall m. Monoid m => KnownRow m -> m)
-> (forall m a. Monoid m => (a -> m) -> KnownRow a -> m)
-> (forall m a. Monoid m => (a -> m) -> KnownRow a -> m)
-> (forall a b. (a -> b -> b) -> b -> KnownRow a -> b)
-> (forall a b. (a -> b -> b) -> b -> KnownRow a -> b)
-> (forall b a. (b -> a -> b) -> b -> KnownRow a -> b)
-> (forall b a. (b -> a -> b) -> b -> KnownRow a -> b)
-> (forall a. (a -> a -> a) -> KnownRow a -> a)
-> (forall a. (a -> a -> a) -> KnownRow a -> a)
-> (forall a. KnownRow a -> [a])
-> (forall a. KnownRow a -> Bool)
-> (forall a. KnownRow a -> Int)
-> (forall a. Eq a => a -> KnownRow a -> Bool)
-> (forall a. Ord a => KnownRow a -> a)
-> (forall a. Ord a => KnownRow a -> a)
-> (forall a. Num a => KnownRow a -> a)
-> (forall a. Num a => KnownRow a -> a)
-> Foldable KnownRow
forall a. Eq a => a -> KnownRow a -> Bool
forall a. Num a => KnownRow a -> a
forall a. Ord a => KnownRow a -> a
forall m. Monoid m => KnownRow m -> m
forall a. KnownRow a -> Bool
forall a. KnownRow a -> Int
forall a. KnownRow a -> [a]
forall a. (a -> a -> a) -> KnownRow a -> a
forall m a. Monoid m => (a -> m) -> KnownRow a -> m
forall b a. (b -> a -> b) -> b -> KnownRow a -> b
forall a b. (a -> b -> b) -> b -> KnownRow a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: KnownRow a -> a
$cproduct :: forall a. Num a => KnownRow a -> a
sum :: KnownRow a -> a
$csum :: forall a. Num a => KnownRow a -> a
minimum :: KnownRow a -> a
$cminimum :: forall a. Ord a => KnownRow a -> a
maximum :: KnownRow a -> a
$cmaximum :: forall a. Ord a => KnownRow a -> a
elem :: a -> KnownRow a -> Bool
$celem :: forall a. Eq a => a -> KnownRow a -> Bool
length :: KnownRow a -> Int
$clength :: forall a. KnownRow a -> Int
null :: KnownRow a -> Bool
$cnull :: forall a. KnownRow a -> Bool
toList :: KnownRow a -> [a]
$ctoList :: forall a. KnownRow a -> [a]
foldl1 :: (a -> a -> a) -> KnownRow a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> KnownRow a -> a
foldr1 :: (a -> a -> a) -> KnownRow a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> KnownRow a -> a
foldl' :: (b -> a -> b) -> b -> KnownRow a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> KnownRow a -> b
foldl :: (b -> a -> b) -> b -> KnownRow a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> KnownRow a -> b
foldr' :: (a -> b -> b) -> b -> KnownRow a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> KnownRow a -> b
foldr :: (a -> b -> b) -> b -> KnownRow a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> KnownRow a -> b
foldMap' :: (a -> m) -> KnownRow a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> KnownRow a -> m
foldMap :: (a -> m) -> KnownRow a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> KnownRow a -> m
fold :: KnownRow m -> m
$cfold :: forall m. Monoid m => KnownRow m -> m
Foldable)
toList :: KnownRow a -> [KnownField a]
toList :: KnownRow a -> [KnownField a]
toList = KnownRow a -> [KnownField a]
forall a. KnownRow a -> [KnownField a]
knownRecordVector
visibleMap :: KnownRow a -> SmallHashMap FieldName (KnownField a)
visibleMap :: KnownRow a -> SmallHashMap FieldName (KnownField a)
visibleMap KnownRow{Bool
[KnownField a]
SmallHashMap FieldName Int
knownRecordAllVisible :: Bool
knownRecordVisible :: SmallHashMap FieldName Int
knownRecordVector :: [KnownField a]
knownRecordAllVisible :: forall a. KnownRow a -> Bool
knownRecordVisible :: forall a. KnownRow a -> SmallHashMap FieldName Int
knownRecordVector :: forall a. KnownRow a -> [KnownField a]
..} = ([KnownField a]
knownRecordVector [KnownField a] -> Int -> KnownField a
forall a. [a] -> Int -> a
!!) (Int -> KnownField a)
-> SmallHashMap FieldName Int
-> SmallHashMap FieldName (KnownField a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SmallHashMap FieldName Int
knownRecordVisible
fromList :: forall a.
[KnownField a]
-> KnownRow a
fromList :: [KnownField a] -> KnownRow a
fromList = [KnownField a]
-> Int
-> SmallHashMap FieldName Int
-> Bool
-> [KnownField a]
-> KnownRow a
go [] Int
0 SmallHashMap FieldName Int
forall k a. SmallHashMap k a
HashMap.empty Bool
True
where
go :: [KnownField a]
-> Int
-> SmallHashMap FieldName Int
-> Bool
-> [KnownField a]
-> KnownRow a
go :: [KnownField a]
-> Int
-> SmallHashMap FieldName Int
-> Bool
-> [KnownField a]
-> KnownRow a
go [KnownField a]
accFields !Int
nextIndex !SmallHashMap FieldName Int
accVisible !Bool
accAllVisible = \case
[] -> KnownRow :: forall a.
[KnownField a] -> SmallHashMap FieldName Int -> Bool -> KnownRow a
KnownRow {
knownRecordVector :: [KnownField a]
knownRecordVector = [KnownField a] -> [KnownField a]
forall a. [a] -> [a]
reverse [KnownField a]
accFields
, knownRecordVisible :: SmallHashMap FieldName Int
knownRecordVisible = SmallHashMap FieldName Int
accVisible
, knownRecordAllVisible :: Bool
knownRecordAllVisible = Bool
accAllVisible
}
KnownField a
f:[KnownField a]
fs
| FieldName
name FieldName -> SmallHashMap FieldName Int -> Bool
forall k a. (Hashable k, Ord k) => k -> SmallHashMap k a -> Bool
`HashMap.member` SmallHashMap FieldName Int
accVisible ->
[KnownField a]
-> Int
-> SmallHashMap FieldName Int
-> Bool
-> [KnownField a]
-> KnownRow a
go (KnownField a
f KnownField a -> [KnownField a] -> [KnownField a]
forall a. a -> [a] -> [a]
: [KnownField a]
accFields)
(Int -> Int
forall a. Enum a => a -> a
succ Int
nextIndex)
SmallHashMap FieldName Int
accVisible
Bool
False
[KnownField a]
fs
| Bool
otherwise ->
[KnownField a]
-> Int
-> SmallHashMap FieldName Int
-> Bool
-> [KnownField a]
-> KnownRow a
go (KnownField a
f KnownField a -> [KnownField a] -> [KnownField a]
forall a. a -> [a] -> [a]
: [KnownField a]
accFields)
(Int -> Int
forall a. Enum a => a -> a
succ Int
nextIndex)
(FieldName
-> Int -> SmallHashMap FieldName Int -> SmallHashMap FieldName Int
forall k a.
(Hashable k, Ord k) =>
k -> a -> SmallHashMap k a -> SmallHashMap k a
HashMap.insert FieldName
name Int
nextIndex SmallHashMap FieldName Int
accVisible)
Bool
accAllVisible
[KnownField a]
fs
where
name :: FieldName
name = KnownField a -> FieldName
forall a. KnownField a -> FieldName
knownFieldName KnownField a
f
traverse :: forall m a b.
Applicative m
=> KnownRow a
-> (FieldName -> a -> m b)
-> m (KnownRow b)
traverse :: KnownRow a -> (FieldName -> a -> m b) -> m (KnownRow b)
traverse KnownRow{Bool
[KnownField a]
SmallHashMap FieldName Int
knownRecordAllVisible :: Bool
knownRecordVisible :: SmallHashMap FieldName Int
knownRecordVector :: [KnownField a]
knownRecordAllVisible :: forall a. KnownRow a -> Bool
knownRecordVisible :: forall a. KnownRow a -> SmallHashMap FieldName Int
knownRecordVector :: forall a. KnownRow a -> [KnownField a]
..} FieldName -> a -> m b
f =
[KnownField b] -> KnownRow b
mkRow ([KnownField b] -> KnownRow b)
-> m [KnownField b] -> m (KnownRow b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (KnownField a -> m (KnownField b))
-> [KnownField a] -> m [KnownField b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
Prelude.traverse KnownField a -> m (KnownField b)
f' [KnownField a]
knownRecordVector
where
mkRow :: [KnownField b] -> KnownRow b
mkRow :: [KnownField b] -> KnownRow b
mkRow [KnownField b]
updated = KnownRow :: forall a.
[KnownField a] -> SmallHashMap FieldName Int -> Bool -> KnownRow a
KnownRow {
knownRecordVector :: [KnownField b]
knownRecordVector = [KnownField b]
updated
, knownRecordVisible :: SmallHashMap FieldName Int
knownRecordVisible = SmallHashMap FieldName Int
knownRecordVisible
, knownRecordAllVisible :: Bool
knownRecordAllVisible = Bool
knownRecordAllVisible
}
f' :: KnownField a -> m (KnownField b)
f' :: KnownField a -> m (KnownField b)
f' (KnownField FieldName
nm a
info) = FieldName -> b -> KnownField b
forall a. FieldName -> a -> KnownField a
KnownField FieldName
nm (b -> KnownField b) -> m b -> m (KnownField b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldName -> a -> m b
f FieldName
nm a
info
indexed :: KnownRow a -> KnownRow (Int, a)
indexed :: KnownRow a -> KnownRow (Int, a)
indexed KnownRow a
r =
(State Int (KnownRow (Int, a)) -> Int -> KnownRow (Int, a))
-> Int -> State Int (KnownRow (Int, a)) -> KnownRow (Int, a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State Int (KnownRow (Int, a)) -> Int -> KnownRow (Int, a)
forall s a. State s a -> s -> a
evalState Int
0 (State Int (KnownRow (Int, a)) -> KnownRow (Int, a))
-> State Int (KnownRow (Int, a)) -> KnownRow (Int, a)
forall a b. (a -> b) -> a -> b
$
KnownRow a
-> (FieldName -> a -> StateT Int Identity (Int, a))
-> State Int (KnownRow (Int, a))
forall (m :: * -> *) a b.
Applicative m =>
KnownRow a -> (FieldName -> a -> m b) -> m (KnownRow b)
traverse KnownRow a
r ((a -> StateT Int Identity (Int, a))
-> FieldName -> a -> StateT Int Identity (Int, a)
forall a b. a -> b -> a
const a -> StateT Int Identity (Int, a)
forall a. a -> State Int (Int, a)
aux)
where
aux :: a -> State Int (Int, a)
aux :: a -> State Int (Int, a)
aux a
a = (Int -> ((Int, a), Int)) -> State Int (Int, a)
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((Int -> ((Int, a), Int)) -> State Int (Int, a))
-> (Int -> ((Int, a), Int)) -> State Int (Int, a)
forall a b. (a -> b) -> a -> b
$ \Int
i -> ((Int
i, a
a), Int -> Int
forall a. Enum a => a -> a
succ Int
i)
data NotSubRow =
TargetContainsShadowedFields
| SourceMissesFields [FieldName]
deriving (Int -> NotSubRow -> ShowS
[NotSubRow] -> ShowS
NotSubRow -> String
(Int -> NotSubRow -> ShowS)
-> (NotSubRow -> String)
-> ([NotSubRow] -> ShowS)
-> Show NotSubRow
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NotSubRow] -> ShowS
$cshowList :: [NotSubRow] -> ShowS
show :: NotSubRow -> String
$cshow :: NotSubRow -> String
showsPrec :: Int -> NotSubRow -> ShowS
$cshowsPrec :: Int -> NotSubRow -> ShowS
Show, NotSubRow -> NotSubRow -> Bool
(NotSubRow -> NotSubRow -> Bool)
-> (NotSubRow -> NotSubRow -> Bool) -> Eq NotSubRow
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NotSubRow -> NotSubRow -> Bool
$c/= :: NotSubRow -> NotSubRow -> Bool
== :: NotSubRow -> NotSubRow -> Bool
$c== :: NotSubRow -> NotSubRow -> Bool
Eq)
isSubRow :: forall a b.
KnownRow a
-> KnownRow b
-> Either NotSubRow [(Int, (a, b))]
isSubRow :: KnownRow a -> KnownRow b -> Either NotSubRow [(Int, (a, b))]
isSubRow KnownRow a
recordA KnownRow b
recordB =
if Bool -> Bool
not (KnownRow b -> Bool
forall a. KnownRow a -> Bool
knownRecordAllVisible KnownRow b
recordB) then
NotSubRow -> Either NotSubRow [(Int, (a, b))]
forall a b. a -> Either a b
Left NotSubRow
TargetContainsShadowedFields
else
([FieldName]
-> [(Int, (a, b))] -> Either NotSubRow [(Int, (a, b))])
-> ([FieldName], [(Int, (a, b))])
-> Either NotSubRow [(Int, (a, b))]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [FieldName] -> [(Int, (a, b))] -> Either NotSubRow [(Int, (a, b))]
forall x. [FieldName] -> x -> Either NotSubRow x
checkMissing
(([FieldName], [(Int, (a, b))])
-> Either NotSubRow [(Int, (a, b))])
-> ([Either FieldName (Int, (a, b))]
-> ([FieldName], [(Int, (a, b))]))
-> [Either FieldName (Int, (a, b))]
-> Either NotSubRow [(Int, (a, b))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either FieldName (Int, (a, b))] -> ([FieldName], [(Int, (a, b))])
forall a b. [Either a b] -> ([a], [b])
partitionEithers
([Either FieldName (Int, (a, b))]
-> Either NotSubRow [(Int, (a, b))])
-> [Either FieldName (Int, (a, b))]
-> Either NotSubRow [(Int, (a, b))]
forall a b. (a -> b) -> a -> b
$ (KnownField b -> Either FieldName (Int, (a, b)))
-> [KnownField b] -> [Either FieldName (Int, (a, b))]
forall a b. (a -> b) -> [a] -> [b]
map KnownField b -> Either FieldName (Int, (a, b))
findInA (KnownRow b -> [KnownField b]
forall a. KnownRow a -> [KnownField a]
toList KnownRow b
recordB)
where
findInA :: KnownField b -> Either FieldName (Int, (a, b))
findInA :: KnownField b -> Either FieldName (Int, (a, b))
findInA KnownField b
b =
case FieldName
-> SmallHashMap FieldName (KnownField (Int, a))
-> Maybe (KnownField (Int, a))
forall k a. (Hashable k, Ord k) => k -> SmallHashMap k a -> Maybe a
HashMap.lookup (KnownField b -> FieldName
forall a. KnownField a -> FieldName
knownFieldName KnownField b
b) (KnownRow (Int, a) -> SmallHashMap FieldName (KnownField (Int, a))
forall a. KnownRow a -> SmallHashMap FieldName (KnownField a)
visibleMap (KnownRow a -> KnownRow (Int, a)
forall a. KnownRow a -> KnownRow (Int, a)
indexed KnownRow a
recordA)) of
Maybe (KnownField (Int, a))
Nothing -> FieldName -> Either FieldName (Int, (a, b))
forall a b. a -> Either a b
Left (FieldName -> Either FieldName (Int, (a, b)))
-> FieldName -> Either FieldName (Int, (a, b))
forall a b. (a -> b) -> a -> b
$ KnownField b -> FieldName
forall a. KnownField a -> FieldName
knownFieldName KnownField b
b
Just KnownField (Int, a)
a -> (Int, (a, b)) -> Either FieldName (Int, (a, b))
forall a b. b -> Either a b
Right ((Int, (a, b)) -> Either FieldName (Int, (a, b)))
-> (Int, (a, b)) -> Either FieldName (Int, (a, b))
forall a b. (a -> b) -> a -> b
$ ((Int, a), b) -> (Int, (a, b))
forall i. ((i, a), b) -> (i, (a, b))
distrib (KnownField (Int, a) -> (Int, a)
forall a. KnownField a -> a
knownFieldInfo KnownField (Int, a)
a, KnownField b -> b
forall a. KnownField a -> a
knownFieldInfo KnownField b
b)
checkMissing :: [FieldName] -> x -> Either NotSubRow x
checkMissing :: [FieldName] -> x -> Either NotSubRow x
checkMissing [] x
x = x -> Either NotSubRow x
forall a b. b -> Either a b
Right x
x
checkMissing [FieldName]
missing x
_ = NotSubRow -> Either NotSubRow x
forall a b. a -> Either a b
Left (NotSubRow -> Either NotSubRow x)
-> NotSubRow -> Either NotSubRow x
forall a b. (a -> b) -> a -> b
$ [FieldName] -> NotSubRow
SourceMissesFields [FieldName]
missing
distrib :: ((i, a), b) -> (i, (a, b))
distrib :: ((i, a), b) -> (i, (a, b))
distrib ((i
i, a
a), b
b) = (i
i, (a
a, b
b))
instance Outputable a => Outputable (KnownRow a) where
ppr :: KnownRow a -> SDoc
ppr = [KnownField a] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([KnownField a] -> SDoc)
-> (KnownRow a -> [KnownField a]) -> KnownRow a -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KnownRow a -> [KnownField a]
forall a. KnownRow a -> [KnownField a]
toList