{-# LANGUAGE FlexibleInstances, UndecidableInstances, FlexibleContexts, TemplateHaskell #-}
module Hyper.Type.AST.Row
( RowConstraints(..), RowKey
, RowExtend(..), eKey, eVal, eRest, W_RowExtend(..)
, FlatRowExtends(..), freExtends, freRest, W_FlatRowExtends(..)
, MorphWitness(..)
, flattenRow, flattenRowExtend, unflattenRow
, verifyRowExtendConstraints, rowExtendStructureMismatch
, rowElementInfer
) where
import Control.Lens (Prism', Lens', contains)
import qualified Control.Lens as Lens
import Control.Monad (foldM)
import qualified Data.Map as Map
import Generics.Constraints (Constraints, makeDerivings, makeInstances)
import Hyper
import Hyper.Unify
import Hyper.Unify.New (newTerm, newUnbound)
import Hyper.Unify.Term (UTerm(..), _UTerm, UTermBody(..), uBody)
import Text.Show.Combinators ((@|), showCon)
import Hyper.Internal.Prelude
class
(Ord (RowConstraintsKey constraints), TypeConstraints constraints) =>
RowConstraints constraints where
type RowConstraintsKey constraints
forbidden :: Lens' constraints (Set (RowConstraintsKey constraints))
type RowKey typ = RowConstraintsKey (TypeConstraintsOf typ)
data RowExtend key val rest h = RowExtend
{ RowExtend key val rest h -> key
_eKey :: key
, RowExtend key val rest h -> h :# val
_eVal :: h :# val
, RowExtend key val rest h -> h :# rest
_eRest :: h :# rest
} deriving (forall x.
RowExtend key val rest h -> Rep (RowExtend key val rest h) x)
-> (forall x.
Rep (RowExtend key val rest h) x -> RowExtend key val rest h)
-> Generic (RowExtend key val rest h)
forall x.
Rep (RowExtend key val rest h) x -> RowExtend key val rest h
forall x.
RowExtend key val rest h -> Rep (RowExtend key val rest h) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall key (val :: HyperType) (rest :: HyperType) (h :: AHyperType)
x.
Rep (RowExtend key val rest h) x -> RowExtend key val rest h
forall key (val :: HyperType) (rest :: HyperType) (h :: AHyperType)
x.
RowExtend key val rest h -> Rep (RowExtend key val rest h) x
$cto :: forall key (val :: HyperType) (rest :: HyperType) (h :: AHyperType)
x.
Rep (RowExtend key val rest h) x -> RowExtend key val rest h
$cfrom :: forall key (val :: HyperType) (rest :: HyperType) (h :: AHyperType)
x.
RowExtend key val rest h -> Rep (RowExtend key val rest h) x
Generic
data FlatRowExtends key val rest h = FlatRowExtends
{ FlatRowExtends key val rest h -> Map key (h :# val)
_freExtends :: Map key (h :# val)
, FlatRowExtends key val rest h -> h :# rest
_freRest :: h :# rest
} deriving (forall x.
FlatRowExtends key val rest h
-> Rep (FlatRowExtends key val rest h) x)
-> (forall x.
Rep (FlatRowExtends key val rest h) x
-> FlatRowExtends key val rest h)
-> Generic (FlatRowExtends key val rest h)
forall x.
Rep (FlatRowExtends key val rest h) x
-> FlatRowExtends key val rest h
forall x.
FlatRowExtends key val rest h
-> Rep (FlatRowExtends key val rest h) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall key (val :: HyperType) (rest :: HyperType) (h :: AHyperType)
x.
Rep (FlatRowExtends key val rest h) x
-> FlatRowExtends key val rest h
forall key (val :: HyperType) (rest :: HyperType) (h :: AHyperType)
x.
FlatRowExtends key val rest h
-> Rep (FlatRowExtends key val rest h) x
$cto :: forall key (val :: HyperType) (rest :: HyperType) (h :: AHyperType)
x.
Rep (FlatRowExtends key val rest h) x
-> FlatRowExtends key val rest h
$cfrom :: forall key (val :: HyperType) (rest :: HyperType) (h :: AHyperType)
x.
FlatRowExtends key val rest h
-> Rep (FlatRowExtends key val rest h) x
Generic
makeLenses ''RowExtend
makeLenses ''FlatRowExtends
makeCommonInstances [''FlatRowExtends]
makeZipMatch ''RowExtend
makeHContext ''RowExtend
makeHMorph ''RowExtend
makeHTraversableApplyAndBases ''RowExtend
makeHTraversableApplyAndBases ''FlatRowExtends
makeDerivings [''Eq, ''Ord] [''RowExtend]
makeInstances [''Binary, ''NFData] [''RowExtend]
instance
Constraints (RowExtend key val rest h) Show =>
Show (RowExtend key val rest h) where
showsPrec :: Int -> RowExtend key val rest h -> ShowS
showsPrec Int
p (RowExtend key
h h :# val
v h :# rest
r) = (String -> PrecShowS
showCon String
"RowExtend" PrecShowS -> key -> PrecShowS
forall a. Show a => PrecShowS -> a -> PrecShowS
@| key
h PrecShowS -> (h :# val) -> PrecShowS
forall a. Show a => PrecShowS -> a -> PrecShowS
@| h :# val
v PrecShowS -> (h :# rest) -> PrecShowS
forall a. Show a => PrecShowS -> a -> PrecShowS
@| h :# rest
r) Int
p
{-# INLINE flattenRowExtend #-}
flattenRowExtend ::
(Ord key, Monad m) =>
(v # rest -> m (Maybe (RowExtend key val rest # v))) ->
RowExtend key val rest # v ->
m (FlatRowExtends key val rest # v)
flattenRowExtend :: ((v # rest) -> m (Maybe (RowExtend key val rest # v)))
-> (RowExtend key val rest # v)
-> m (FlatRowExtends key val rest # v)
flattenRowExtend (v # rest) -> m (Maybe (RowExtend key val rest # v))
nextExtend (RowExtend key
h 'AHyperType v :# val
v 'AHyperType v :# rest
rest) =
((v # rest) -> m (Maybe (RowExtend key val rest # v)))
-> (v # rest) -> m (FlatRowExtends key val rest # v)
forall key (m :: * -> *) (v :: HyperType) (rest :: HyperType)
(val :: HyperType).
(Ord key, Monad m) =>
((v # rest) -> m (Maybe (RowExtend key val rest # v)))
-> (v # rest) -> m (FlatRowExtends key val rest # v)
flattenRow (v # rest) -> m (Maybe (RowExtend key val rest # v))
nextExtend v # rest
'AHyperType v :# rest
rest
m (FlatRowExtends key val rest # v)
-> ((FlatRowExtends key val rest # v)
-> FlatRowExtends key val rest # v)
-> m (FlatRowExtends key val rest # v)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Map key (v ('AHyperType val))
-> Identity (Map key (v ('AHyperType val))))
-> (FlatRowExtends key val rest # v)
-> Identity (FlatRowExtends key val rest # v)
forall key (val :: HyperType) (rest :: HyperType) (h :: AHyperType)
key (val :: HyperType).
Lens
(FlatRowExtends key val rest h)
(FlatRowExtends key val rest h)
(Map key (h :# val))
(Map key (h :# val))
freExtends ((Map key (v ('AHyperType val))
-> Identity (Map key (v ('AHyperType val))))
-> (FlatRowExtends key val rest # v)
-> Identity (FlatRowExtends key val rest # v))
-> (Map key (v ('AHyperType val)) -> Map key (v ('AHyperType val)))
-> (FlatRowExtends key val rest # v)
-> FlatRowExtends key val rest # v
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (v ('AHyperType val) -> v ('AHyperType val) -> v ('AHyperType val))
-> Map key (v ('AHyperType val))
-> Map key (v ('AHyperType val))
-> Map key (v ('AHyperType val))
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (String
-> v ('AHyperType val)
-> v ('AHyperType val)
-> v ('AHyperType val)
forall a. HasCallStack => String -> a
error String
"Colliding keys") (key -> v ('AHyperType val) -> Map key (v ('AHyperType val))
forall k a. k -> a -> Map k a
Map.singleton key
h v ('AHyperType val)
'AHyperType v :# val
v)
{-# INLINE flattenRow #-}
flattenRow ::
(Ord key, Monad m) =>
(v # rest -> m (Maybe (RowExtend key val rest # v))) ->
v # rest ->
m (FlatRowExtends key val rest # v)
flattenRow :: ((v # rest) -> m (Maybe (RowExtend key val rest # v)))
-> (v # rest) -> m (FlatRowExtends key val rest # v)
flattenRow (v # rest) -> m (Maybe (RowExtend key val rest # v))
nextExtend v # rest
x =
(v # rest) -> m (Maybe (RowExtend key val rest # v))
nextExtend v # rest
x
m (Maybe (RowExtend key val rest # v))
-> (Maybe (RowExtend key val rest # v)
-> m (FlatRowExtends key val rest # v))
-> m (FlatRowExtends key val rest # v)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (FlatRowExtends key val rest # v)
-> ((RowExtend key val rest # v)
-> m (FlatRowExtends key val rest # v))
-> Maybe (RowExtend key val rest # v)
-> m (FlatRowExtends key val rest # v)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((FlatRowExtends key val rest # v)
-> m (FlatRowExtends key val rest # v)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map key ('AHyperType v :# val)
-> ('AHyperType v :# rest) -> FlatRowExtends key val rest # v
forall key (val :: HyperType) (rest :: HyperType)
(h :: AHyperType).
Map key (h :# val) -> (h :# rest) -> FlatRowExtends key val rest h
FlatRowExtends Map key ('AHyperType v :# val)
forall a. Monoid a => a
mempty v # rest
'AHyperType v :# rest
x)) (((v # rest) -> m (Maybe (RowExtend key val rest # v)))
-> (RowExtend key val rest # v)
-> m (FlatRowExtends key val rest # v)
forall key (m :: * -> *) (v :: HyperType) (rest :: HyperType)
(val :: HyperType).
(Ord key, Monad m) =>
((v # rest) -> m (Maybe (RowExtend key val rest # v)))
-> (RowExtend key val rest # v)
-> m (FlatRowExtends key val rest # v)
flattenRowExtend (v # rest) -> m (Maybe (RowExtend key val rest # v))
nextExtend)
{-# INLINE unflattenRow #-}
unflattenRow ::
Monad m =>
(RowExtend key val rest # v -> m (v # rest)) ->
FlatRowExtends key val rest # v -> m (v # rest)
unflattenRow :: ((RowExtend key val rest # v) -> m (v # rest))
-> (FlatRowExtends key val rest # v) -> m (v # rest)
unflattenRow (RowExtend key val rest # v) -> m (v # rest)
mkExtend (FlatRowExtends Map key ('AHyperType v :# val)
fields 'AHyperType v :# rest
rest) =
Map key (v ('AHyperType val))
Map key ('AHyperType v :# val)
fields Map key (v ('AHyperType val))
-> IndexedGetting
key
(Endo [(key, v ('AHyperType val))])
(Map key (v ('AHyperType val)))
(v ('AHyperType val))
-> [(key, v ('AHyperType val))]
forall s i a. s -> IndexedGetting i (Endo [(i, a)]) s a -> [(i, a)]
^@.. IndexedGetting
key
(Endo [(key, v ('AHyperType val))])
(Map key (v ('AHyperType val)))
(v ('AHyperType val))
forall i (t :: * -> *) a b.
TraversableWithIndex i t =>
IndexedTraversal i (t a) (t b) a b
Lens.itraversed [(key, v ('AHyperType val))]
-> ([(key, v ('AHyperType val))] -> m (v # rest)) -> m (v # rest)
forall a b. a -> (a -> b) -> b
& ((v # rest) -> (key, v ('AHyperType val)) -> m (v # rest))
-> (v # rest) -> [(key, v ('AHyperType val))] -> m (v # rest)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (v # rest) -> (key, v ('AHyperType val)) -> m (v # rest)
f v # rest
'AHyperType v :# rest
rest
where
f :: (v # rest) -> (key, v ('AHyperType val)) -> m (v # rest)
f v # rest
acc (key
key, v ('AHyperType val)
val) = key
-> ('AHyperType v :# val)
-> ('AHyperType v :# rest)
-> RowExtend key val rest # v
forall key (val :: HyperType) (rest :: HyperType)
(h :: AHyperType).
key -> (h :# val) -> (h :# rest) -> RowExtend key val rest h
RowExtend key
key v ('AHyperType val)
'AHyperType v :# val
val v # rest
'AHyperType v :# rest
acc (RowExtend key val rest # v)
-> ((RowExtend key val rest # v) -> m (v # rest)) -> m (v # rest)
forall a b. a -> (a -> b) -> b
& (RowExtend key val rest # v) -> m (v # rest)
mkExtend
{-# INLINE verifyRowExtendConstraints #-}
verifyRowExtendConstraints ::
RowConstraints (TypeConstraintsOf rowTyp) =>
(TypeConstraintsOf rowTyp -> TypeConstraintsOf valTyp) ->
TypeConstraintsOf rowTyp ->
RowExtend (RowKey rowTyp) valTyp rowTyp # h ->
Maybe (RowExtend (RowKey rowTyp) valTyp rowTyp # WithConstraint h)
verifyRowExtendConstraints :: (TypeConstraintsOf rowTyp -> TypeConstraintsOf valTyp)
-> TypeConstraintsOf rowTyp
-> (RowExtend (RowKey rowTyp) valTyp rowTyp # h)
-> Maybe
(RowExtend (RowKey rowTyp) valTyp rowTyp # WithConstraint h)
verifyRowExtendConstraints TypeConstraintsOf rowTyp -> TypeConstraintsOf valTyp
toChildC TypeConstraintsOf rowTyp
c (RowExtend RowKey rowTyp
h 'AHyperType h :# valTyp
v 'AHyperType h :# rowTyp
rest)
| TypeConstraintsOf rowTyp
c TypeConstraintsOf rowTyp
-> Getting Bool (TypeConstraintsOf rowTyp) Bool -> Bool
forall s a. s -> Getting a s a -> a
^. (Set (RowKey rowTyp) -> Const Bool (Set (RowKey rowTyp)))
-> TypeConstraintsOf rowTyp
-> Const Bool (TypeConstraintsOf rowTyp)
forall constraints.
RowConstraints constraints =>
Lens' constraints (Set (RowConstraintsKey constraints))
forbidden ((Set (RowKey rowTyp) -> Const Bool (Set (RowKey rowTyp)))
-> TypeConstraintsOf rowTyp
-> Const Bool (TypeConstraintsOf rowTyp))
-> ((Bool -> Const Bool Bool)
-> Set (RowKey rowTyp) -> Const Bool (Set (RowKey rowTyp)))
-> Getting Bool (TypeConstraintsOf rowTyp) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Set (RowKey rowTyp)) -> Lens' (Set (RowKey rowTyp)) Bool
forall m. Contains m => Index m -> Lens' m Bool
contains Index (Set (RowKey rowTyp))
RowKey rowTyp
h = Maybe (RowExtend (RowKey rowTyp) valTyp rowTyp # WithConstraint h)
forall a. Maybe a
Nothing
| Bool
otherwise =
RowKey rowTyp
-> ('AHyperType (WithConstraint h) :# valTyp)
-> ('AHyperType (WithConstraint h) :# rowTyp)
-> RowExtend (RowKey rowTyp) valTyp rowTyp # WithConstraint h
forall key (val :: HyperType) (rest :: HyperType)
(h :: AHyperType).
key -> (h :# val) -> (h :# rest) -> RowExtend key val rest h
RowExtend RowKey rowTyp
h
(TypeConstraintsOf (GetHyperType ('AHyperType valTyp))
-> h ('AHyperType valTyp) -> WithConstraint h ('AHyperType valTyp)
forall (h :: HyperType) (ast :: AHyperType).
TypeConstraintsOf (GetHyperType ast)
-> h ast -> WithConstraint h ast
WithConstraint (TypeConstraintsOf rowTyp
c TypeConstraintsOf rowTyp
-> (TypeConstraintsOf rowTyp -> TypeConstraintsOf rowTyp)
-> TypeConstraintsOf rowTyp
forall a b. a -> (a -> b) -> b
& (Set (RowKey rowTyp) -> Identity (Set (RowKey rowTyp)))
-> TypeConstraintsOf rowTyp -> Identity (TypeConstraintsOf rowTyp)
forall constraints.
RowConstraints constraints =>
Lens' constraints (Set (RowConstraintsKey constraints))
forbidden ((Set (RowKey rowTyp) -> Identity (Set (RowKey rowTyp)))
-> TypeConstraintsOf rowTyp -> Identity (TypeConstraintsOf rowTyp))
-> Set (RowKey rowTyp)
-> TypeConstraintsOf rowTyp
-> TypeConstraintsOf rowTyp
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set (RowKey rowTyp)
forall a. Monoid a => a
mempty TypeConstraintsOf rowTyp
-> (TypeConstraintsOf rowTyp -> TypeConstraintsOf valTyp)
-> TypeConstraintsOf valTyp
forall a b. a -> (a -> b) -> b
& TypeConstraintsOf rowTyp -> TypeConstraintsOf valTyp
toChildC) h ('AHyperType valTyp)
'AHyperType h :# valTyp
v)
(TypeConstraintsOf (GetHyperType ('AHyperType rowTyp))
-> h ('AHyperType rowTyp) -> WithConstraint h ('AHyperType rowTyp)
forall (h :: HyperType) (ast :: AHyperType).
TypeConstraintsOf (GetHyperType ast)
-> h ast -> WithConstraint h ast
WithConstraint (TypeConstraintsOf rowTyp
c TypeConstraintsOf rowTyp
-> (TypeConstraintsOf rowTyp -> TypeConstraintsOf rowTyp)
-> TypeConstraintsOf rowTyp
forall a b. a -> (a -> b) -> b
& (Set (RowKey rowTyp) -> Identity (Set (RowKey rowTyp)))
-> TypeConstraintsOf rowTyp -> Identity (TypeConstraintsOf rowTyp)
forall constraints.
RowConstraints constraints =>
Lens' constraints (Set (RowConstraintsKey constraints))
forbidden ((Set (RowKey rowTyp) -> Identity (Set (RowKey rowTyp)))
-> TypeConstraintsOf rowTyp -> Identity (TypeConstraintsOf rowTyp))
-> ((Bool -> Identity Bool)
-> Set (RowKey rowTyp) -> Identity (Set (RowKey rowTyp)))
-> (Bool -> Identity Bool)
-> TypeConstraintsOf rowTyp
-> Identity (TypeConstraintsOf rowTyp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Set (RowKey rowTyp)) -> Lens' (Set (RowKey rowTyp)) Bool
forall m. Contains m => Index m -> Lens' m Bool
contains Index (Set (RowKey rowTyp))
RowKey rowTyp
h ((Bool -> Identity Bool)
-> TypeConstraintsOf rowTyp -> Identity (TypeConstraintsOf rowTyp))
-> Bool -> TypeConstraintsOf rowTyp -> TypeConstraintsOf rowTyp
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True) h ('AHyperType rowTyp)
'AHyperType h :# rowTyp
rest)
(RowExtend (RowKey rowTyp) valTyp rowTyp # WithConstraint h)
-> ((RowExtend (RowKey rowTyp) valTyp rowTyp # WithConstraint h)
-> Maybe
(RowExtend (RowKey rowTyp) valTyp rowTyp # WithConstraint h))
-> Maybe
(RowExtend (RowKey rowTyp) valTyp rowTyp # WithConstraint h)
forall a b. a -> (a -> b) -> b
& (RowExtend (RowKey rowTyp) valTyp rowTyp # WithConstraint h)
-> Maybe
(RowExtend (RowKey rowTyp) valTyp rowTyp # WithConstraint h)
forall a. a -> Maybe a
Just
{-# INLINE rowExtendStructureMismatch #-}
rowExtendStructureMismatch ::
Ord key =>
( Unify m rowTyp
, Unify m valTyp
) =>
(forall c. Unify m c => UVarOf m # c -> UVarOf m # c -> m (UVarOf m # c)) ->
Prism' (rowTyp # UVarOf m) (RowExtend key valTyp rowTyp # UVarOf m) ->
RowExtend key valTyp rowTyp # UVarOf m ->
RowExtend key valTyp rowTyp # UVarOf m ->
m ()
rowExtendStructureMismatch :: (forall (c :: HyperType).
Unify m c =>
(UVarOf m # c) -> (UVarOf m # c) -> m (UVarOf m # c))
-> Prism'
(rowTyp # UVarOf m) (RowExtend key valTyp rowTyp # UVarOf m)
-> (RowExtend key valTyp rowTyp # UVarOf m)
-> (RowExtend key valTyp rowTyp # UVarOf m)
-> m ()
rowExtendStructureMismatch forall (c :: HyperType).
Unify m c =>
(UVarOf m # c) -> (UVarOf m # c) -> m (UVarOf m # c)
match Prism' (rowTyp # UVarOf m) (RowExtend key valTyp rowTyp # UVarOf m)
extend RowExtend key valTyp rowTyp # UVarOf m
r0 RowExtend key valTyp rowTyp # UVarOf m
r1 =
do
FlatRowExtends key valTyp rowTyp # UVarOf m
flat0 <- ((UVarOf m # rowTyp)
-> m (Maybe (RowExtend key valTyp rowTyp # UVarOf m)))
-> (RowExtend key valTyp rowTyp # UVarOf m)
-> m (FlatRowExtends key valTyp rowTyp # UVarOf m)
forall key (m :: * -> *) (v :: HyperType) (rest :: HyperType)
(val :: HyperType).
(Ord key, Monad m) =>
((v # rest) -> m (Maybe (RowExtend key val rest # v)))
-> (RowExtend key val rest # v)
-> m (FlatRowExtends key val rest # v)
flattenRowExtend (UVarOf m # rowTyp)
-> m (Maybe (RowExtend key valTyp rowTyp # UVarOf m))
nextExtend RowExtend key valTyp rowTyp # UVarOf m
r0
FlatRowExtends key valTyp rowTyp # UVarOf m
flat1 <- ((UVarOf m # rowTyp)
-> m (Maybe (RowExtend key valTyp rowTyp # UVarOf m)))
-> (RowExtend key valTyp rowTyp # UVarOf m)
-> m (FlatRowExtends key valTyp rowTyp # UVarOf m)
forall key (m :: * -> *) (v :: HyperType) (rest :: HyperType)
(val :: HyperType).
(Ord key, Monad m) =>
((v # rest) -> m (Maybe (RowExtend key val rest # v)))
-> (RowExtend key val rest # v)
-> m (FlatRowExtends key val rest # v)
flattenRowExtend (UVarOf m # rowTyp)
-> m (Maybe (RowExtend key valTyp rowTyp # UVarOf m))
nextExtend RowExtend key valTyp rowTyp # UVarOf m
r1
((UVarOf m # valTyp)
-> (UVarOf m # valTyp) -> m (UVarOf m # valTyp))
-> Map key (UVarOf m # valTyp)
-> Map key (UVarOf m # valTyp)
-> Map key (m (UVarOf m # valTyp))
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith (UVarOf m # valTyp) -> (UVarOf m # valTyp) -> m (UVarOf m # valTyp)
forall (c :: HyperType).
Unify m c =>
(UVarOf m # c) -> (UVarOf m # c) -> m (UVarOf m # c)
match (FlatRowExtends key valTyp rowTyp # UVarOf m
flat0 (FlatRowExtends key valTyp rowTyp # UVarOf m)
-> Getting
(Map key (UVarOf m # valTyp))
(FlatRowExtends key valTyp rowTyp # UVarOf m)
(Map key (UVarOf m # valTyp))
-> Map key (UVarOf m # valTyp)
forall s a. s -> Getting a s a -> a
^. Getting
(Map key (UVarOf m # valTyp))
(FlatRowExtends key valTyp rowTyp # UVarOf m)
(Map key (UVarOf m # valTyp))
forall key (val :: HyperType) (rest :: HyperType) (h :: AHyperType)
key (val :: HyperType).
Lens
(FlatRowExtends key val rest h)
(FlatRowExtends key val rest h)
(Map key (h :# val))
(Map key (h :# val))
freExtends) (FlatRowExtends key valTyp rowTyp # UVarOf m
flat1 (FlatRowExtends key valTyp rowTyp # UVarOf m)
-> Getting
(Map key (UVarOf m # valTyp))
(FlatRowExtends key valTyp rowTyp # UVarOf m)
(Map key (UVarOf m # valTyp))
-> Map key (UVarOf m # valTyp)
forall s a. s -> Getting a s a -> a
^. Getting
(Map key (UVarOf m # valTyp))
(FlatRowExtends key valTyp rowTyp # UVarOf m)
(Map key (UVarOf m # valTyp))
forall key (val :: HyperType) (rest :: HyperType) (h :: AHyperType)
key (val :: HyperType).
Lens
(FlatRowExtends key val rest h)
(FlatRowExtends key val rest h)
(Map key (h :# val))
(Map key (h :# val))
freExtends)
Map key (m (UVarOf m # valTyp))
-> (Map key (m (UVarOf m # valTyp)) -> m ()) -> m ()
forall a b. a -> (a -> b) -> b
& Map key (m (UVarOf m # valTyp)) -> m ()
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Applicative f) =>
t (f a) -> f ()
sequenceA_
UVarOf m # rowTyp
restVar <- TypeConstraintsOf (GetHyperType ('AHyperType rowTyp))
-> UTerm (UVarOf m) ('AHyperType rowTyp)
forall (v :: HyperType) (ast :: AHyperType).
TypeConstraintsOf (GetHyperType ast) -> UTerm v ast
UUnbound TypeConstraintsOf (GetHyperType ('AHyperType rowTyp))
forall a. Monoid a => a
mempty UTerm (UVarOf m) ('AHyperType rowTyp)
-> (UTerm (UVarOf m) ('AHyperType rowTyp) -> m (UVarOf m # rowTyp))
-> m (UVarOf m # rowTyp)
forall a b. a -> (a -> b) -> b
& BindingDict (UVarOf m) m rowTyp
-> UTerm (UVarOf m) ('AHyperType rowTyp) -> m (UVarOf m # rowTyp)
forall (v :: HyperType) (m :: * -> *) (t :: HyperType).
BindingDict v m t -> (UTerm v # t) -> m (v # t)
newVar BindingDict (UVarOf m) m rowTyp
forall (m :: * -> *) (t :: HyperType).
Unify m t =>
BindingDict (UVarOf m) m t
binding
let side :: (FlatRowExtends key valTyp rowTyp # UVarOf m)
-> (FlatRowExtends key valTyp rowTyp # UVarOf m)
-> m (UVarOf m # rowTyp)
side FlatRowExtends key valTyp rowTyp # UVarOf m
x FlatRowExtends key valTyp rowTyp # UVarOf m
y =
((RowExtend key valTyp rowTyp # UVarOf m) -> m (UVarOf m # rowTyp))
-> (FlatRowExtends key valTyp rowTyp # UVarOf m)
-> m (UVarOf m # rowTyp)
forall (m :: * -> *) key (val :: HyperType) (rest :: HyperType)
(v :: HyperType).
Monad m =>
((RowExtend key val rest # v) -> m (v # rest))
-> (FlatRowExtends key val rest # v) -> m (v # rest)
unflattenRow (RowExtend key valTyp rowTyp # UVarOf m) -> m (UVarOf m # rowTyp)
mkExtend FlatRowExtends :: forall key (val :: HyperType) (rest :: HyperType)
(h :: AHyperType).
Map key (h :# val) -> (h :# rest) -> FlatRowExtends key val rest h
FlatRowExtends
{ _freExtends :: Map key ('AHyperType (UVarOf m) :# valTyp)
_freExtends =
(FlatRowExtends key valTyp rowTyp # UVarOf m
x (FlatRowExtends key valTyp rowTyp # UVarOf m)
-> Getting
(Map key (UVarOf m # valTyp))
(FlatRowExtends key valTyp rowTyp # UVarOf m)
(Map key (UVarOf m # valTyp))
-> Map key (UVarOf m # valTyp)
forall s a. s -> Getting a s a -> a
^. Getting
(Map key (UVarOf m # valTyp))
(FlatRowExtends key valTyp rowTyp # UVarOf m)
(Map key (UVarOf m # valTyp))
forall key (val :: HyperType) (rest :: HyperType) (h :: AHyperType)
key (val :: HyperType).
Lens
(FlatRowExtends key val rest h)
(FlatRowExtends key val rest h)
(Map key (h :# val))
(Map key (h :# val))
freExtends) Map key (UVarOf m # valTyp)
-> Map key (UVarOf m # valTyp) -> Map key (UVarOf m # valTyp)
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` (FlatRowExtends key valTyp rowTyp # UVarOf m
y (FlatRowExtends key valTyp rowTyp # UVarOf m)
-> Getting
(Map key (UVarOf m # valTyp))
(FlatRowExtends key valTyp rowTyp # UVarOf m)
(Map key (UVarOf m # valTyp))
-> Map key (UVarOf m # valTyp)
forall s a. s -> Getting a s a -> a
^. Getting
(Map key (UVarOf m # valTyp))
(FlatRowExtends key valTyp rowTyp # UVarOf m)
(Map key (UVarOf m # valTyp))
forall key (val :: HyperType) (rest :: HyperType) (h :: AHyperType)
key (val :: HyperType).
Lens
(FlatRowExtends key val rest h)
(FlatRowExtends key val rest h)
(Map key (h :# val))
(Map key (h :# val))
freExtends)
, _freRest :: 'AHyperType (UVarOf m) :# rowTyp
_freRest = 'AHyperType (UVarOf m) :# rowTyp
UVarOf m # rowTyp
restVar
} m (UVarOf m # rowTyp)
-> ((UVarOf m # rowTyp) -> m (UVarOf m # rowTyp))
-> m (UVarOf m # rowTyp)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (UVarOf m # rowTyp) -> (UVarOf m # rowTyp) -> m (UVarOf m # rowTyp)
forall (c :: HyperType).
Unify m c =>
(UVarOf m # c) -> (UVarOf m # c) -> m (UVarOf m # c)
match (FlatRowExtends key valTyp rowTyp # UVarOf m
y (FlatRowExtends key valTyp rowTyp # UVarOf m)
-> Getting
(UVarOf m # rowTyp)
(FlatRowExtends key valTyp rowTyp # UVarOf m)
(UVarOf m # rowTyp)
-> UVarOf m # rowTyp
forall s a. s -> Getting a s a -> a
^. Getting
(UVarOf m # rowTyp)
(FlatRowExtends key valTyp rowTyp # UVarOf m)
(UVarOf m # rowTyp)
forall key (val :: HyperType) (rest :: HyperType) (h :: AHyperType)
(rest :: HyperType).
Lens
(FlatRowExtends key val rest h)
(FlatRowExtends key val rest h)
(h :# rest)
(h :# rest)
freRest)
UVarOf m # rowTyp
_ <- (FlatRowExtends key valTyp rowTyp # UVarOf m)
-> (FlatRowExtends key valTyp rowTyp # UVarOf m)
-> m (UVarOf m # rowTyp)
side FlatRowExtends key valTyp rowTyp # UVarOf m
flat0 FlatRowExtends key valTyp rowTyp # UVarOf m
flat1
UVarOf m # rowTyp
_ <- (FlatRowExtends key valTyp rowTyp # UVarOf m)
-> (FlatRowExtends key valTyp rowTyp # UVarOf m)
-> m (UVarOf m # rowTyp)
side FlatRowExtends key valTyp rowTyp # UVarOf m
flat1 FlatRowExtends key valTyp rowTyp # UVarOf m
flat0
() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
where
mkExtend :: (RowExtend key valTyp rowTyp # UVarOf m) -> m (UVarOf m # rowTyp)
mkExtend RowExtend key valTyp rowTyp # UVarOf m
ext = TypeConstraintsOf (GetHyperType ('AHyperType rowTyp))
-> ('AHyperType rowTyp :# UVarOf m)
-> UTermBody (UVarOf m) ('AHyperType rowTyp)
forall (v1 :: HyperType) (ast :: AHyperType).
TypeConstraintsOf (GetHyperType ast)
-> (ast :# v1) -> UTermBody v1 ast
UTermBody TypeConstraintsOf (GetHyperType ('AHyperType rowTyp))
forall a. Monoid a => a
mempty (Tagged
(RowExtend key valTyp rowTyp # UVarOf m)
(Identity (RowExtend key valTyp rowTyp # UVarOf m))
-> Tagged (rowTyp # UVarOf m) (Identity (rowTyp # UVarOf m))
Prism' (rowTyp # UVarOf m) (RowExtend key valTyp rowTyp # UVarOf m)
extend (Tagged
(RowExtend key valTyp rowTyp # UVarOf m)
(Identity (RowExtend key valTyp rowTyp # UVarOf m))
-> Tagged (rowTyp # UVarOf m) (Identity (rowTyp # UVarOf m)))
-> (RowExtend key valTyp rowTyp # UVarOf m) -> rowTyp # UVarOf m
forall t b. AReview t b -> b -> t
# RowExtend key valTyp rowTyp # UVarOf m
ext) UTermBody (UVarOf m) ('AHyperType rowTyp)
-> (UTermBody (UVarOf m) ('AHyperType rowTyp)
-> UTerm (UVarOf m) ('AHyperType rowTyp))
-> UTerm (UVarOf m) ('AHyperType rowTyp)
forall a b. a -> (a -> b) -> b
& UTermBody (UVarOf m) ('AHyperType rowTyp)
-> UTerm (UVarOf m) ('AHyperType rowTyp)
forall (v :: HyperType) (ast :: AHyperType).
UTermBody v ast -> UTerm v ast
UTerm UTerm (UVarOf m) ('AHyperType rowTyp)
-> (UTerm (UVarOf m) ('AHyperType rowTyp) -> m (UVarOf m # rowTyp))
-> m (UVarOf m # rowTyp)
forall a b. a -> (a -> b) -> b
& BindingDict (UVarOf m) m rowTyp
-> UTerm (UVarOf m) ('AHyperType rowTyp) -> m (UVarOf m # rowTyp)
forall (v :: HyperType) (m :: * -> *) (t :: HyperType).
BindingDict v m t -> (UTerm v # t) -> m (v # t)
newVar BindingDict (UVarOf m) m rowTyp
forall (m :: * -> *) (t :: HyperType).
Unify m t =>
BindingDict (UVarOf m) m t
binding
nextExtend :: (UVarOf m # rowTyp)
-> m (Maybe (RowExtend key valTyp rowTyp # UVarOf m))
nextExtend UVarOf m # rowTyp
v = (UVarOf m # rowTyp)
-> m (UVarOf m # rowTyp, UTerm (UVarOf m) ('AHyperType rowTyp))
forall (m :: * -> *) (t :: HyperType).
Unify m t =>
(UVarOf m # t) -> m (UVarOf m # t, UTerm (UVarOf m) # t)
semiPruneLookup UVarOf m # rowTyp
v m (UVarOf m # rowTyp, UTerm (UVarOf m) ('AHyperType rowTyp))
-> ((UVarOf m # rowTyp, UTerm (UVarOf m) ('AHyperType rowTyp))
-> Maybe (RowExtend key valTyp rowTyp # UVarOf m))
-> m (Maybe (RowExtend key valTyp rowTyp # UVarOf m))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ((UVarOf m # rowTyp, UTerm (UVarOf m) ('AHyperType rowTyp))
-> Getting
(First (RowExtend key valTyp rowTyp # UVarOf m))
(UVarOf m # rowTyp, UTerm (UVarOf m) ('AHyperType rowTyp))
(RowExtend key valTyp rowTyp # UVarOf m)
-> Maybe (RowExtend key valTyp rowTyp # UVarOf m)
forall s a. s -> Getting (First a) s a -> Maybe a
^? (UTerm (UVarOf m) ('AHyperType rowTyp)
-> Const
(First (RowExtend key valTyp rowTyp # UVarOf m))
(UTerm (UVarOf m) ('AHyperType rowTyp)))
-> (UVarOf m # rowTyp, UTerm (UVarOf m) ('AHyperType rowTyp))
-> Const
(First (RowExtend key valTyp rowTyp # UVarOf m))
(UVarOf m # rowTyp, UTerm (UVarOf m) ('AHyperType rowTyp))
forall s t a b. Field2 s t a b => Lens s t a b
Lens._2 ((UTerm (UVarOf m) ('AHyperType rowTyp)
-> Const
(First (RowExtend key valTyp rowTyp # UVarOf m))
(UTerm (UVarOf m) ('AHyperType rowTyp)))
-> (UVarOf m # rowTyp, UTerm (UVarOf m) ('AHyperType rowTyp))
-> Const
(First (RowExtend key valTyp rowTyp # UVarOf m))
(UVarOf m # rowTyp, UTerm (UVarOf m) ('AHyperType rowTyp)))
-> (((RowExtend key valTyp rowTyp # UVarOf m)
-> Const
(First (RowExtend key valTyp rowTyp # UVarOf m))
(RowExtend key valTyp rowTyp # UVarOf m))
-> UTerm (UVarOf m) ('AHyperType rowTyp)
-> Const
(First (RowExtend key valTyp rowTyp # UVarOf m))
(UTerm (UVarOf m) ('AHyperType rowTyp)))
-> Getting
(First (RowExtend key valTyp rowTyp # UVarOf m))
(UVarOf m # rowTyp, UTerm (UVarOf m) ('AHyperType rowTyp))
(RowExtend key valTyp rowTyp # UVarOf m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTermBody (UVarOf m) ('AHyperType rowTyp)
-> Const
(First (RowExtend key valTyp rowTyp # UVarOf m))
(UTermBody (UVarOf m) ('AHyperType rowTyp)))
-> UTerm (UVarOf m) ('AHyperType rowTyp)
-> Const
(First (RowExtend key valTyp rowTyp # UVarOf m))
(UTerm (UVarOf m) ('AHyperType rowTyp))
forall (v :: HyperType) (ast :: AHyperType).
Prism' (UTerm v ast) (UTermBody v ast)
_UTerm ((UTermBody (UVarOf m) ('AHyperType rowTyp)
-> Const
(First (RowExtend key valTyp rowTyp # UVarOf m))
(UTermBody (UVarOf m) ('AHyperType rowTyp)))
-> UTerm (UVarOf m) ('AHyperType rowTyp)
-> Const
(First (RowExtend key valTyp rowTyp # UVarOf m))
(UTerm (UVarOf m) ('AHyperType rowTyp)))
-> (((RowExtend key valTyp rowTyp # UVarOf m)
-> Const
(First (RowExtend key valTyp rowTyp # UVarOf m))
(RowExtend key valTyp rowTyp # UVarOf m))
-> UTermBody (UVarOf m) ('AHyperType rowTyp)
-> Const
(First (RowExtend key valTyp rowTyp # UVarOf m))
(UTermBody (UVarOf m) ('AHyperType rowTyp)))
-> ((RowExtend key valTyp rowTyp # UVarOf m)
-> Const
(First (RowExtend key valTyp rowTyp # UVarOf m))
(RowExtend key valTyp rowTyp # UVarOf m))
-> UTerm (UVarOf m) ('AHyperType rowTyp)
-> Const
(First (RowExtend key valTyp rowTyp # UVarOf m))
(UTerm (UVarOf m) ('AHyperType rowTyp))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((rowTyp # UVarOf m)
-> Const
(First (RowExtend key valTyp rowTyp # UVarOf m))
(rowTyp # UVarOf m))
-> UTermBody (UVarOf m) ('AHyperType rowTyp)
-> Const
(First (RowExtend key valTyp rowTyp # UVarOf m))
(UTermBody (UVarOf m) ('AHyperType rowTyp))
forall (v1 :: HyperType) (ast :: AHyperType) (v2 :: HyperType).
Lens (UTermBody v1 ast) (UTermBody v2 ast) (ast :# v1) (ast :# v2)
uBody (((rowTyp # UVarOf m)
-> Const
(First (RowExtend key valTyp rowTyp # UVarOf m))
(rowTyp # UVarOf m))
-> UTermBody (UVarOf m) ('AHyperType rowTyp)
-> Const
(First (RowExtend key valTyp rowTyp # UVarOf m))
(UTermBody (UVarOf m) ('AHyperType rowTyp)))
-> (((RowExtend key valTyp rowTyp # UVarOf m)
-> Const
(First (RowExtend key valTyp rowTyp # UVarOf m))
(RowExtend key valTyp rowTyp # UVarOf m))
-> (rowTyp # UVarOf m)
-> Const
(First (RowExtend key valTyp rowTyp # UVarOf m))
(rowTyp # UVarOf m))
-> ((RowExtend key valTyp rowTyp # UVarOf m)
-> Const
(First (RowExtend key valTyp rowTyp # UVarOf m))
(RowExtend key valTyp rowTyp # UVarOf m))
-> UTermBody (UVarOf m) ('AHyperType rowTyp)
-> Const
(First (RowExtend key valTyp rowTyp # UVarOf m))
(UTermBody (UVarOf m) ('AHyperType rowTyp))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((RowExtend key valTyp rowTyp # UVarOf m)
-> Const
(First (RowExtend key valTyp rowTyp # UVarOf m))
(RowExtend key valTyp rowTyp # UVarOf m))
-> (rowTyp # UVarOf m)
-> Const
(First (RowExtend key valTyp rowTyp # UVarOf m))
(rowTyp # UVarOf m)
Prism' (rowTyp # UVarOf m) (RowExtend key valTyp rowTyp # UVarOf m)
extend)
{-# INLINE rowElementInfer #-}
rowElementInfer ::
forall m valTyp rowTyp.
( UnifyGen m valTyp
, UnifyGen m rowTyp
, RowConstraints (TypeConstraintsOf rowTyp)
) =>
(RowExtend (RowKey rowTyp) valTyp rowTyp # UVarOf m -> rowTyp # UVarOf m) ->
RowKey rowTyp ->
m (UVarOf m # valTyp, UVarOf m # rowTyp)
rowElementInfer :: ((RowExtend (RowKey rowTyp) valTyp rowTyp # UVarOf m)
-> rowTyp # UVarOf m)
-> RowKey rowTyp -> m (UVarOf m # valTyp, UVarOf m # rowTyp)
rowElementInfer (RowExtend (RowKey rowTyp) valTyp rowTyp # UVarOf m)
-> rowTyp # UVarOf m
extendToRow RowKey rowTyp
h =
do
UVarOf m # rowTyp
restVar <-
Proxy rowTyp -> m (TypeConstraintsOf rowTyp)
forall (m :: * -> *) (t :: HyperType).
UnifyGen m t =>
Proxy t -> m (TypeConstraintsOf t)
scopeConstraints (Proxy rowTyp
forall k (t :: k). Proxy t
Proxy @rowTyp)
m (TypeConstraintsOf rowTyp)
-> (TypeConstraintsOf rowTyp -> m (UVarOf m # rowTyp))
-> m (UVarOf m # rowTyp)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BindingDict (UVarOf m) m rowTyp
-> (UTerm (UVarOf m) # rowTyp) -> m (UVarOf m # rowTyp)
forall (v :: HyperType) (m :: * -> *) (t :: HyperType).
BindingDict v m t -> (UTerm v # t) -> m (v # t)
newVar BindingDict (UVarOf m) m rowTyp
forall (m :: * -> *) (t :: HyperType).
Unify m t =>
BindingDict (UVarOf m) m t
binding ((UTerm (UVarOf m) # rowTyp) -> m (UVarOf m # rowTyp))
-> (TypeConstraintsOf rowTyp -> UTerm (UVarOf m) # rowTyp)
-> TypeConstraintsOf rowTyp
-> m (UVarOf m # rowTyp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeConstraintsOf rowTyp -> UTerm (UVarOf m) # rowTyp
forall (v :: HyperType) (ast :: AHyperType).
TypeConstraintsOf (GetHyperType ast) -> UTerm v ast
UUnbound (TypeConstraintsOf rowTyp -> UTerm (UVarOf m) # rowTyp)
-> (TypeConstraintsOf rowTyp -> TypeConstraintsOf rowTyp)
-> TypeConstraintsOf rowTyp
-> UTerm (UVarOf m) # rowTyp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Set (RowKey rowTyp) -> Identity (Set (RowKey rowTyp)))
-> TypeConstraintsOf rowTyp -> Identity (TypeConstraintsOf rowTyp)
forall constraints.
RowConstraints constraints =>
Lens' constraints (Set (RowConstraintsKey constraints))
forbidden ((Set (RowKey rowTyp) -> Identity (Set (RowKey rowTyp)))
-> TypeConstraintsOf rowTyp -> Identity (TypeConstraintsOf rowTyp))
-> ((Bool -> Identity Bool)
-> Set (RowKey rowTyp) -> Identity (Set (RowKey rowTyp)))
-> (Bool -> Identity Bool)
-> TypeConstraintsOf rowTyp
-> Identity (TypeConstraintsOf rowTyp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Set (RowKey rowTyp)) -> Lens' (Set (RowKey rowTyp)) Bool
forall m. Contains m => Index m -> Lens' m Bool
contains Index (Set (RowKey rowTyp))
RowKey rowTyp
h ((Bool -> Identity Bool)
-> TypeConstraintsOf rowTyp -> Identity (TypeConstraintsOf rowTyp))
-> Bool -> TypeConstraintsOf rowTyp -> TypeConstraintsOf rowTyp
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True)
UVarOf m # valTyp
part <- m (UVarOf m # valTyp)
forall (m :: * -> *) (t :: HyperType).
UnifyGen m t =>
m (UVarOf m # t)
newUnbound
UVarOf m # rowTyp
whole <- RowKey rowTyp
-> ('AHyperType (UVarOf m) :# valTyp)
-> ('AHyperType (UVarOf m) :# rowTyp)
-> RowExtend (RowKey rowTyp) valTyp rowTyp # UVarOf m
forall key (val :: HyperType) (rest :: HyperType)
(h :: AHyperType).
key -> (h :# val) -> (h :# rest) -> RowExtend key val rest h
RowExtend RowKey rowTyp
h 'AHyperType (UVarOf m) :# valTyp
UVarOf m # valTyp
part 'AHyperType (UVarOf m) :# rowTyp
UVarOf m # rowTyp
restVar (RowExtend (RowKey rowTyp) valTyp rowTyp # UVarOf m)
-> ((RowExtend (RowKey rowTyp) valTyp rowTyp # UVarOf m)
-> rowTyp # UVarOf m)
-> rowTyp # UVarOf m
forall a b. a -> (a -> b) -> b
& (RowExtend (RowKey rowTyp) valTyp rowTyp # UVarOf m)
-> rowTyp # UVarOf m
extendToRow (rowTyp # UVarOf m)
-> ((rowTyp # UVarOf m) -> m (UVarOf m # rowTyp))
-> m (UVarOf m # rowTyp)
forall a b. a -> (a -> b) -> b
& (rowTyp # UVarOf m) -> m (UVarOf m # rowTyp)
forall (m :: * -> *) (t :: HyperType).
UnifyGen m t =>
(t # UVarOf m) -> m (UVarOf m # t)
newTerm
(UVarOf m # valTyp, UVarOf m # rowTyp)
-> m (UVarOf m # valTyp, UVarOf m # rowTyp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UVarOf m # valTyp
part, UVarOf m # rowTyp
whole)