module Text.GrammarCombinators.Transform.LeftCorner (
LCBaseIx, LCNTMinNTIx, LCNTMinTIx,
LCDomain (LCBase, LCNTMinNT, LCNTMinT),
LCValue( LCBV, LCNTMinNTV, LCNTMinTV ),
transformLeftCorner,
transformLeftCornerE
) where
import Text.GrammarCombinators.Base
import Text.GrammarCombinators.Utils.CalcFirst
import Data.Map (Map, (!))
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Enumerable
import Control.Applicative ((<*>))
data LCBaseIx ix
data LCNTMinNTIx ix' ix
data LCNTMinTIx t ix
data LCDomain phi t ix where
LCBase :: phi ix -> LCDomain phi t (LCBaseIx ix)
LCNTMinNT :: phi ix' -> phi ix -> LCDomain phi t (LCNTMinNTIx ix' ix)
LCNTMinT :: t -> phi ix -> LCDomain phi t (LCNTMinTIx t ix)
instance (ShowFam phi, Show t) => ShowFam (LCDomain phi t) where
showIdx (LCBase idx) = showIdx idx
showIdx (LCNTMinNT idx' idx) = showIdx idx ++ "-" ++ showIdx idx'
showIdx (LCNTMinT tt idx) = showIdx idx ++ "-" ++ show tt
instance (Token t, FoldFam phi) => FoldFam (LCDomain phi t) where
foldFam (f :: forall ix. LCDomain phi t ix -> b -> b) n =
let n' = foldFam (f . LCBase) n
f' :: forall ix. phi ix -> b -> b
f' idx = foldFam (f . (LCNTMinNT `flip` idx))
n'' = foldFam f' n'
f'' tt = foldFam (f . LCNTMinT tt)
n''' = foldr f'' n'' enumerate
in n'''
newtype WrapLCNTMinNTMemo phi r ix' =
WLCNTMNTM { unWLCNTMNT :: Memo phi (SubVal (LCNTMinNTIx ix') r) }
instance (MemoFam phi, Token t) =>
MemoFam (LCDomain phi t) where
data Memo (LCDomain phi t) r =
MemoLCD (Memo phi (SubVal LCBaseIx r))
(Memo phi (WrapLCNTMinNTMemo phi r))
(Map t (Memo phi (SubVal (LCNTMinTIx t) r)))
toMemo f = MemoLCD (toMemo (MkSubVal . f . LCBase))
(toMemo (WLCNTMNTM . (\idx' -> toMemo (MkSubVal . f . LCNTMinNT idx'))))
(Map.fromList (map (\tt -> (tt, toMemo (MkSubVal . f . LCNTMinT tt))) enumerate))
fromMemo (MemoLCD mb _ _) (LCBase idx) = unSubVal $ fromMemo mb idx
fromMemo (MemoLCD _ mnmn _) (LCNTMinNT idx' idx) =
unSubVal $ fromMemo (unWLCNTMNT $ fromMemo mnmn idx') idx
fromMemo (MemoLCD _ _ mnmt) (LCNTMinT tt idx) =
unSubVal $ fromMemo (mnmt ! tt) idx
instance (Domain phi, Token t) => Domain (LCDomain phi t)
newtype WrapFSect phi r ix = WFS {
unWFS :: forall ix'. phi ix' -> r (LCNTMinNTIx ix ix')
}
instance (EqFam phi, Token t) => EqFam (LCDomain phi t) where
overrideIdx f (LCBase idx) v (LCBase idx') =
unSubVal $ overrideIdx (MkSubVal . f . LCBase) idx (MkSubVal v) idx'
overrideIdx (f :: forall ix'. LCDomain phi t ix' -> r ix') (LCNTMinNT (idx :: phi ix) (idxm :: phi ixm)) v (LCNTMinNT idxr idxmr) =
let
fc :: forall ix' ixm'. phi ix' -> phi ixm' -> r (LCNTMinNTIx ix' ixm')
fc idx' idxm' = f $ LCNTMinNT idx' idxm'
fsect' :: forall ix'. phi ix' -> r (LCNTMinNTIx ix ix')
fsect' idxm' = unSubVal $ overrideIdx (MkSubVal . fc idx) idxm (MkSubVal v) idxm'
fc' :: forall ix' ixm'. phi ix' -> phi ixm' -> r (LCNTMinNTIx ix' ixm')
fc' idxm' = unWFS $ overrideIdx (\idx' -> WFS $ fc idx') idx (WFS fsect') idxm'
in fc' idxr idxmr
overrideIdx f (LCNTMinT tt idx) v (LCNTMinT tt' idx') =
if tt == tt'
then unSubVal $ overrideIdx (MkSubVal . f . LCNTMinT tt) idx (MkSubVal v) idx'
else f (LCNTMinT tt' idx')
overrideIdx f _ _ idx' = f idx'
instance DomainMap (LCDomain phi t) phi LCBaseIx where
supIx = LCBase
subIx (LCBase idx) = idx
data family LCValue (r :: * -> *) t ix
data instance LCValue r t (LCBaseIx ix) = LCBV { unLCBV :: r ix } deriving (Show)
data instance LCValue r t (LCNTMinNTIx ix' ix) = LCNTMinNTV { unLCNTMinNTV :: r ix' -> r ix}
data instance LCValue r t (LCNTMinTIx t ix) = LCNTMinTV { unLCNTMinTV :: ConcreteToken t -> r ix }
data TransformLCRule p (unused1 :: * -> *) (unused2 :: * -> *) (phi :: * -> *) (r :: * -> *) t v =
MkTLCIR {
tlcEmpty :: Maybe v,
tlcFull :: p v,
tlcNTMinNT :: forall ix'. phi ix' -> p (r ix' -> v),
tlcNTMinT :: t -> p (ConcreteToken t -> v)
}
instance (ProductionRule p,
EpsProductionRule p,
RecProductionRule p (LCDomain phi t) (LCValue r t)) =>
ProductionRule (TransformLCRule p (LCDomain phi t) (LCValue r t) phi r t) where
(ra :: TransformLCRule p (LCDomain phi t) (LCValue r t) phi r t (a -> b)) >>> rb =
let
es = tlcEmpty ra <*> tlcEmpty rb
emptyA = maybe die epsilon $ tlcEmpty ra
f = tlcFull ra >>> tlcFull rb
rNTMinNT :: phi ix' -> p (r ix' -> b)
rNTMinNT idx' = flip $>> tlcNTMinNT ra idx' >>> tlcFull rb
||| (.) $>> emptyA >>> tlcNTMinNT rb idx'
rNTMinT tt = flip $>> tlcNTMinT ra tt >>> tlcFull rb
||| (.) $>> emptyA >>> tlcNTMinT rb tt
in MkTLCIR es f rNTMinNT rNTMinT
(ra :: TransformLCRule p (LCDomain phi t) (LCValue r t) phi r t a) ||| rb =
let
es = case (tlcEmpty ra, tlcEmpty rb) of
(Just _, Just _) -> error "Ambiguous: empty disjunction"
(Just va, Nothing) -> Just va
(Nothing, Just vb) -> Just vb
(Nothing, Nothing) -> Nothing
f = tlcFull ra ||| tlcFull rb
rNTMinNT :: phi ix' -> p (r ix' -> a)
rNTMinNT idx' = tlcNTMinNT ra idx' ||| tlcNTMinNT rb idx'
rNTMinT tt = tlcNTMinT ra tt ||| tlcNTMinT rb tt
in MkTLCIR es f rNTMinNT rNTMinT
endOfInput = MkTLCIR Nothing endOfInput (const die) (const die)
die = MkTLCIR Nothing die (const die) (const die)
instance (ProductionRule p,
EpsProductionRule p,
RecProductionRule p (LCDomain phi t) (LCValue r t)) =>
EpsProductionRule (TransformLCRule p (LCDomain phi t) (LCValue r t) phi r t) where
epsilon v = MkTLCIR (Just v) (epsilon v) (const die) (const die)
instance (ProductionRule p,
EpsProductionRule p,
RecProductionRule p (LCDomain phi t) (LCValue r t)) =>
LiftableProductionRule (TransformLCRule p (LCDomain phi t) (LCValue r t) phi r t) where
epsilonL v _ = epsilon v
instance (Token t, TokenProductionRule p t, ProductionRule p,
LiftableProductionRule p,
RecProductionRule p (LCDomain phi t) (LCValue r t)) =>
TokenProductionRule (TransformLCRule p unused1 unused2 phi r t) t where
token tt =
let rNTMinT tt' = if tt == tt' then epsilonL id [|id|] else die
in MkTLCIR Nothing (token tt) (const die) rNTMinT
anyToken =
let rNTMinT _ = epsilonL id [|id|]
in MkTLCIR Nothing anyToken (const die) rNTMinT
newtype WrapNTMinNTP p r ix surrIx =
WNTMinNTP { unWNTMinNTP :: p (r surrIx -> r ix) }
instance (ProductionRule p, EqFam phi,
EpsProductionRule p,
RecProductionRule p (LCDomain phi t) (LCValue r t)) =>
RecProductionRule (TransformLCRule p (LCDomain phi t) (LCValue r t) phi r t) phi r where
ref (idx :: phi ix) =
let f = unLCBV $>> ref (LCBase idx)
rNTMinNT :: phi ix' -> p (r ix' -> r ix)
rNTMinNT idxm = unWNTMinNTP $ overrideIdx (\_ -> WNTMinNTP die) idx (WNTMinNTP $ epsilon id) idxm
in MkTLCIR Nothing f rNTMinNT (const die)
newtype WrapNTMinNTPs p r ix surrIx =
WNTMinNTPs { unWNTMinNTPs :: p (r surrIx -> [r ix]) }
instance (EqFam phi,
EpsProductionRule p,
LoopProductionRule p (LCDomain phi t) (LCValue r t)) =>
LoopProductionRule (TransformLCRule p (LCDomain phi t) (LCValue r t) phi r t) phi r where
manyRef (idx :: phi ix) =
let f = map unLCBV $>> manyRef (LCBase idx)
rNTMinNTIdx = flip (:) $>> (map unLCBV $>> manyRef (LCBase idx))
rNTMinNT :: phi ix' -> p (r ix' -> [r ix])
rNTMinNT idxm = unWNTMinNTPs $ overrideIdx (\_ -> WNTMinNTPs die) idx (WNTMinNTPs rNTMinNTIdx) idxm
in MkTLCIR Nothing f rNTMinNT (const die)
many1Ref (idx :: phi ix) =
let f = map unLCBV $>> many1Ref (LCBase idx)
rNTMinNTIdx = flip (:) $>> (map unLCBV $>> manyRef (LCBase idx))
rNTMinNT :: phi ix' -> p (r ix' -> [r ix])
rNTMinNT idxm = unWNTMinNTPs $ overrideIdx (\_ -> WNTMinNTPs die) idx (WNTMinNTPs rNTMinNTIdx) idxm
in MkTLCIR Nothing f rNTMinNT (const die)
transformLeftCorner' ::
forall p phi r t ix.
(Domain phi, Token t, TokenProductionRule p t,
ProductionRule p,
EpsProductionRule p,
RecProductionRule p (LCDomain phi t) (LCValue r t)) =>
(forall ix'. phi ix' ->
TransformLCRule p (LCDomain phi t) (LCValue r t) phi r t (r ix')) ->
(forall ix'. phi ix' -> FirstSet t) ->
LCDomain phi t ix ->
p (LCValue r t ix)
transformLeftCorner' _ cfs (LCBase idx) =
let FS fs _ _ = cfs idx
ruleT tt = flip ($) $>> token tt >>> (unLCNTMinTV $>> ref (LCNTMinT tt idx))
ruleTs = LCBV $>> Set.fold ((|||) . ruleT) die fs
in ruleTs
transformLeftCorner' bgram _ (LCNTMinT tt (idx :: phi ix')) =
let
bMinT :: phi ixB -> p (ConcreteToken t -> r ix')
bMinT idxB = flip (.) $>> tlcNTMinT (bgram idxB) tt >>> (unLCNTMinNTV $>> ref (LCNTMinNT idxB idx))
bMinTs = foldFam ((|||) . bMinT) die
in LCNTMinTV $>> bMinTs
||| LCNTMinTV $>> tlcNTMinT (bgram idx) tt
transformLeftCorner' bgram _ (LCNTMinNT (idxm :: phi ixm) (idx :: phi ix')) =
let
cMinB :: phi ixC -> p (LCValue r t (LCNTMinNTIx ixm ix'))
cMinB idxC = LCNTMinNTV $>> (flip (.) $>> tlcNTMinNT (bgram idxC) idxm >>> follow idxC)
baseFollow :: phi ixC -> p (r ixC -> r ix')
baseFollow idxC = unLCNTMinNTV $>> ref (LCNTMinNT idxC idx)
follow :: phi ixC -> p (r ixC -> r ix')
follow idxC = unWNTMinNTP $ overrideIdx (WNTMinNTP . baseFollow) idx (WNTMinNTP $ baseFollow idx ||| epsilon id) idxC
in
foldFam (flip (|||) . cMinB) die
transformLeftCorner ::
(Domain phi, Token t) =>
ProcessingContextFreeGrammar phi t r ->
ProcessingContextFreeGrammar (LCDomain phi t) t (LCValue r t)
transformLeftCorner gram idx = transformLeftCorner' gram (calcFirst gram) idx
transformLeftCornerE ::
forall phi t r. (Domain phi, Token t) =>
ProcessingExtendedContextFreeGrammar phi t r ->
ProcessingExtendedContextFreeGrammar (LCDomain phi t) t (LCValue r t)
transformLeftCornerE gram idx = transformLeftCorner' gram (calcFirst gram) idx