module Text.GrammarCombinators.Base.Domain (
DomainMap(supIx, subIx),
DomainEmbedding(supPF),
SubVal(MkSubVal, unSubVal),
IxMapId, IxMapBase, IxMapSeq, ApplyIxMap,
MemoFam(toMemo, fromMemo), Memo, memoFamily,
FoldFam(foldFam),
EqFam(overrideIdx, eqIdx), overrideIdxK,
ShowFam(showIdx),
Domain,
memoFamilyK, toMemoK, fromMemoK,
LiftFam(liftIdxE, liftIdxP),
LeftIx, RightIx,
MergeDomain (LeftIdx, RightIdx),
EitherFunctor (LeftR, RightR),
unLeftR, unRightR
) where
import Generics.MultiRec.Base
import Generics.MultiRec.HFunctor
import Language.Haskell.TH.Syntax (Exp, Pat)
data IxMapId
data IxMapBase (m :: * -> *)
data IxMapSeq (l1 :: *) (l2 :: * -> *)
type family ApplyIxMap (m :: *) ix
type instance ApplyIxMap (IxMapBase m) ix = m ix
type instance ApplyIxMap (IxMapSeq l1 l2) ix = ApplyIxMap l1 (l2 ix)
type instance ApplyIxMap IxMapId ix = ix
class MemoFam (phi :: * -> *) where
data Memo phi :: (* -> *) -> *
fromMemo :: Memo phi v -> (forall ix. phi ix -> v ix)
toMemo :: (forall ix. phi ix -> v ix) -> Memo phi v
memoFamily :: (MemoFam phi) =>
(forall ix. phi ix -> v ix) -> (forall ix. phi ix -> v ix)
memoFamily f = fromMemo (toMemo f)
memoFamilyK :: (MemoFam phi) =>
(forall ix. phi ix -> v) -> (forall ix. phi ix -> v)
memoFamilyK f = fromMemoK (toMemoK f)
toMemoK :: (MemoFam phi) =>
(forall ix. phi ix -> v) -> Memo phi (K0 v)
toMemoK f = toMemo (K0 . f)
fromMemoK :: (MemoFam phi) =>
Memo phi (K0 v) -> phi ix -> v
fromMemoK m = unK0 . fromMemo m
class FoldFam phi where
foldFam :: (forall ix. phi ix -> b -> b) -> b -> b
class ShowFam phi where
showIdx :: forall ix. phi ix -> String
class EqFam phi where
eqIdx :: forall ix1 ix2. phi ix1 -> phi ix2 -> Bool
eqIdx idx1 = overrideIdxK (const False) idx1 True
overrideIdx :: (forall ix'. phi ix' -> r ix') -> phi oix ->
r oix -> phi ix -> r ix
overrideIdxK :: (EqFam phi) => (forall ix'. phi ix' -> v) -> phi oix -> v -> phi ix -> v
overrideIdxK f idx v = unK0 . overrideIdx (K0 . f) idx (K0 v)
class (FoldFam phi,
ShowFam phi,
EqFam phi,
MemoFam phi) => Domain phi
class DomainMap phi phi' supIxT where
supIx :: phi' ix -> phi (supIxT ix)
subIx :: phi (supIxT ix) -> phi' ix
class (DomainMap phi phi' supIxT) =>
DomainEmbedding phi phi' supIxT where
supPF :: (HFunctor phi (PF phi)) =>
phi' ix -> phi (supIxT ix) ->
PF phi' (SubVal supIxT r) ix -> PF phi r (supIxT ix)
data SubVal (supIxT :: * -> *) v ix = MkSubVal {
unSubVal :: v (supIxT ix)
} deriving (Show)
class LiftFam phi where
liftIdxE :: phi ix -> Exp
liftIdxP :: phi ix -> Pat
data LeftIx ix
data RightIx ix
data MergeDomain phiL phiR ix where
LeftIdx :: phiL ix -> MergeDomain phiL phiR (LeftIx ix)
RightIdx :: phiR ix -> MergeDomain phiL phiR (RightIx ix)
instance (MemoFam phiL, MemoFam phiR) =>
MemoFam (MergeDomain phiL phiR) where
data Memo (MergeDomain phiL phiR) v = MemoMD (Memo phiL (SubVal LeftIx v)) (Memo phiR (SubVal RightIx v))
fromMemo (MemoMD ml _) (LeftIdx idx) = unSubVal $ fromMemo ml idx
fromMemo (MemoMD _ mr) (RightIdx idx) = unSubVal $ fromMemo mr idx
toMemo f = MemoMD (toMemo (MkSubVal . f . LeftIdx)) (toMemo (MkSubVal . f . RightIdx))
instance (ShowFam phiL, ShowFam phiR) =>
ShowFam (MergeDomain phiL phiR) where
showIdx (LeftIdx idx) = concat ["LeftIdx (", (showIdx idx), ")"]
showIdx (RightIdx idx) = concat ["RightIdx (", (showIdx idx), ")"]
instance (FoldFam phiL, FoldFam phiR) =>
FoldFam (MergeDomain phiL phiR) where
foldFam f n = foldFam (f . LeftIdx) $ foldFam (f . RightIdx) n
instance (EqFam phiL, EqFam phiR) =>
EqFam (MergeDomain phiL phiR) where
overrideIdx f (LeftIdx idx) v (LeftIdx idx') = unSubVal $ overrideIdx (MkSubVal . f . LeftIdx) idx (MkSubVal v) idx'
overrideIdx f (RightIdx idx) v (RightIdx idx') = unSubVal $ overrideIdx (MkSubVal . f . RightIdx) idx (MkSubVal v) idx'
overrideIdx f _ _ idx = f idx
instance (Domain phiL, Domain phiR) => Domain (MergeDomain phiL phiR)
data EitherFunctor rL rR ix where
LeftR :: rL ix -> EitherFunctor rL rR (LeftIx ix)
RightR :: rR ix -> EitherFunctor rL rR (RightIx ix)
instance (Show (rL ix)) => Show (EitherFunctor rL rR (LeftIx ix)) where
show (LeftR v) = show v
instance (Show (rR ix)) => Show (EitherFunctor rL rR (RightIx ix)) where
show (RightR v) = show v
unLeftR :: EitherFunctor rL rR (LeftIx ix) -> rL ix
unLeftR (LeftR v) = v
unRightR :: EitherFunctor rL rR (RightIx ix) -> rR ix
unRightR (RightR v) = v
type instance PF (MergeDomain phiL phiR) = PF phiL :+: PF phiR