{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE DeriveFoldable      #-}
{-# LANGUAGE DeriveFunctor       #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Information about a record
--
-- Intended for qualified import.
--
-- > import Data.Record.Anon.Internal.Plugin.TC.Row.KnownRow (KnownRow(..))
-- > import qualified Data.Record.Anon.Internal.Plugin.TC.Row.KnownRow as KnownRow
module Data.Record.Anon.Internal.Plugin.TC.Row.KnownRow (
    -- * Definition
    KnownRow(..)
    -- * Construction
  , fromList
  , toList
  , visibleMap
    -- * Combinators
  , traverse
  , indexed
    -- * Check for subrows
  , 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

{-------------------------------------------------------------------------------
  Definition
-------------------------------------------------------------------------------}

-- | Record with statically known shape
data KnownRow a = KnownRow {
      -- | Information about each field in the record, in user-specified order.
      --
      -- Order matters, because records with the same fields in a different
      -- order are not considered equal by the library (merely isomorphic).
      --
      -- May contain duplicates (if fields are shadowed).
      forall a. KnownRow a -> [KnownField a]
knownRecordVector :: [KnownField a]

      -- | "Most recent" position of each field in the record
      --
      -- Shadowed fields are not included in this map.
      --
      -- Invariant:
      --
      -- >     HashMap.lookup n knownRecordNames == Just i
      -- > ==> knownFieldName (knownRecordVector V.! i) == n
    , forall a. KnownRow a -> SmallHashMap FieldName Int
knownRecordVisible :: SmallHashMap FieldName Int

      -- | Are all fields in this record visible?
      --
      -- 'False' if some fields are shadowed.
    , forall a. KnownRow a -> Bool
knownRecordAllVisible :: Bool
    }
  deriving (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
<$ :: forall a b. a -> KnownRow b -> KnownRow a
$c<$ :: forall a b. a -> KnownRow b -> KnownRow a
fmap :: forall a b. (a -> b) -> KnownRow a -> KnownRow b
$cfmap :: forall a b. (a -> b) -> KnownRow a -> KnownRow b
Functor, 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 :: forall a. Num a => KnownRow a -> a
$cproduct :: forall a. Num a => KnownRow a -> a
sum :: forall a. Num a => KnownRow a -> a
$csum :: forall a. Num a => KnownRow a -> a
minimum :: forall a. Ord a => KnownRow a -> a
$cminimum :: forall a. Ord a => KnownRow a -> a
maximum :: forall a. Ord a => KnownRow a -> a
$cmaximum :: forall a. Ord a => KnownRow a -> a
elem :: forall a. Eq a => a -> KnownRow a -> Bool
$celem :: forall a. Eq a => a -> KnownRow a -> Bool
length :: forall a. KnownRow a -> Int
$clength :: forall a. KnownRow a -> Int
null :: forall a. KnownRow a -> Bool
$cnull :: forall a. KnownRow a -> Bool
toList :: forall a. KnownRow a -> [a]
$ctoList :: forall a. KnownRow a -> [a]
foldl1 :: forall a. (a -> a -> a) -> KnownRow a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> KnownRow a -> a
foldr1 :: forall a. (a -> a -> a) -> KnownRow a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> KnownRow a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> KnownRow a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> KnownRow a -> b
foldl :: forall b a. (b -> a -> b) -> b -> KnownRow a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> KnownRow a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> KnownRow a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> KnownRow a -> b
foldr :: forall a b. (a -> b -> b) -> b -> KnownRow a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> KnownRow a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> KnownRow a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> KnownRow a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> KnownRow a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> KnownRow a -> m
fold :: forall m. Monoid m => KnownRow m -> m
$cfold :: forall m. Monoid m => KnownRow m -> m
Foldable)

{-------------------------------------------------------------------------------
  Conversion
-------------------------------------------------------------------------------}

toList :: KnownRow a -> [KnownField a]
toList :: forall a. KnownRow a -> [KnownField a]
toList = forall a. KnownRow a -> [KnownField a]
knownRecordVector

visibleMap :: KnownRow a -> SmallHashMap FieldName (KnownField a)
visibleMap :: forall a. 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 forall a. [a] -> Int -> a
!!) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SmallHashMap FieldName Int
knownRecordVisible

{-------------------------------------------------------------------------------
  Construction
-------------------------------------------------------------------------------}

fromList :: forall a.
     [KnownField a]
     -- ^ Fields of the record in the order they appear in the row types
     --
     -- In other words, fields earlier in the list shadow later fields.
  -> KnownRow a
fromList :: forall a. [KnownField a] -> KnownRow a
fromList = [KnownField a]
-> Int
-> SmallHashMap FieldName Int
-> Bool
-> [KnownField a]
-> KnownRow a
go [] Int
0 forall k a. SmallHashMap k a
HashMap.empty Bool
True
  where
    go :: [KnownField a]  -- Acc fields, reverse order (includes shadowed)
       -> Int             -- Next index
       -> SmallHashMap FieldName Int -- Acc indices of visible fields
       -> Bool            -- Are all already processed fields visible?
       -> [KnownField a]  -- To process
       -> 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 {
            knownRecordVector :: [KnownField a]
knownRecordVector     = 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 forall k a. (Hashable k, Ord k) => k -> SmallHashMap k a -> Bool
`HashMap.member` SmallHashMap FieldName Int
accVisible ->
              -- Field shadowed
              [KnownField a]
-> Int
-> SmallHashMap FieldName Int
-> Bool
-> [KnownField a]
-> KnownRow a
go (KnownField a
f forall a. a -> [a] -> [a]
: [KnownField a]
accFields)
                 (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 forall a. a -> [a] -> [a]
: [KnownField a]
accFields)
                 (forall a. Enum a => a -> a
succ Int
nextIndex)
                 (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 = forall a. KnownField a -> FieldName
knownFieldName KnownField a
f

{-------------------------------------------------------------------------------
  Combinators
-------------------------------------------------------------------------------}

traverse :: forall m a b.
     Applicative m
  => KnownRow a
  -> (FieldName -> a -> m b)
  -> m (KnownRow b)
traverse :: forall (m :: * -> *) a b.
Applicative m =>
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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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 {
          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) = forall a. FieldName -> a -> KnownField a
KnownField FieldName
nm 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 :: forall a. KnownRow a -> KnownRow (Int, a)
indexed KnownRow a
r =
    forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
evalState Int
0 forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) a b.
Applicative m =>
KnownRow a -> (FieldName -> a -> m b) -> m (KnownRow b)
traverse KnownRow a
r (forall a b. a -> b -> a
const forall a. a -> State Int (Int, a)
aux)
  where
    aux :: a -> State Int (Int, a)
    aux :: forall a. a -> State Int (Int, a)
aux a
a = forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state forall a b. (a -> b) -> a -> b
$ \Int
i -> ((Int
i, a
a), forall a. Enum a => a -> a
succ Int
i)

{-------------------------------------------------------------------------------
  Check for projections
-------------------------------------------------------------------------------}

-- | Reason why we cannot failed to prove 'SubRow'
data NotSubRow =
    -- | We do not support precords with shadowed fields
    --
    -- Since these fields can only come from the source record, and shadowed
    -- fields in the source record are invisible, shadowed fields in the target
    -- could only be duplicates of the same field in the source. This is not
    -- particularly useful, so we don't support it. Moreover, since we actually
    -- create /lenses/ from these subrows, it is important that every field in
    -- the source record corresponds to at most /one/ field in the target.
    TargetContainsShadowedFields

    -- | Some fields in the target are missing in the source
  | SourceMissesFields [FieldName]
  deriving (Int -> NotSubRow -> ShowS
[NotSubRow] -> ShowS
NotSubRow -> String
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
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)

-- | Check if one row is a subrow of another
--
-- If it is, returns the paired information from both records in the order of
-- the /target/ record along with the index into the /source/ record.
--
-- See 'NotSubRow' for some discussion of shadowing.
isSubRow :: forall a b.
     KnownRow a
  -> KnownRow b
  -> Either NotSubRow [(Int, (a, b))]
isSubRow :: forall a b.
KnownRow a -> KnownRow b -> Either NotSubRow [(Int, (a, b))]
isSubRow KnownRow a
recordA KnownRow b
recordB =
    if Bool -> Bool
not (forall a. KnownRow a -> Bool
knownRecordAllVisible KnownRow b
recordB) then
      forall a b. a -> Either a b
Left NotSubRow
TargetContainsShadowedFields
    else
        forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall x. [FieldName] -> x -> Either NotSubRow x
checkMissing
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [Either a b] -> ([a], [b])
partitionEithers
      forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map KnownField b -> Either FieldName (Int, (a, b))
findInA (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 forall k a. (Hashable k, Ord k) => k -> SmallHashMap k a -> Maybe a
HashMap.lookup (forall a. KnownField a -> FieldName
knownFieldName KnownField b
b) (forall a. KnownRow a -> SmallHashMap FieldName (KnownField a)
visibleMap (forall a. KnownRow a -> KnownRow (Int, a)
indexed KnownRow a
recordA)) of
          Maybe (KnownField (Int, a))
Nothing -> forall a b. a -> Either a b
Left  forall a b. (a -> b) -> a -> b
$ forall a. KnownField a -> FieldName
knownFieldName KnownField b
b
          Just KnownField (Int, a)
a  -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall i. ((i, a), b) -> (i, (a, b))
distrib (forall a. KnownField a -> a
knownFieldInfo KnownField (Int, a)
a, forall a. KnownField a -> a
knownFieldInfo KnownField b
b)

    checkMissing :: [FieldName] -> x -> Either NotSubRow x
    checkMissing :: forall x. [FieldName] -> x -> Either NotSubRow x
checkMissing []      x
x = forall a b. b -> Either a b
Right x
x
    checkMissing [FieldName]
missing x
_ = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [FieldName] -> NotSubRow
SourceMissesFields [FieldName]
missing

    distrib :: ((i, a), b) -> (i, (a, b))
    distrib :: forall i. ((i, a), b) -> (i, (a, b))
distrib ((i
i, a
a), b
b) = (i
i, (a
a, b
b))

{-------------------------------------------------------------------------------
  Outputable
-------------------------------------------------------------------------------}

instance Outputable a => Outputable (KnownRow a) where
  ppr :: KnownRow a -> SDoc
ppr = forall a. Outputable a => a -> SDoc
ppr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. KnownRow a -> [KnownField a]
toList