{- Fast, Error Correcting Parser Combinators;See version history in same directory.
- Copyright: S. Doaitse Swierstra
Department of Computer Science
Utrecht University
P.O. Box 80.089
3508 TB UTRECHT
the Netherlands
swierstra@cs.uu.nl -}
module UU_Parsing
(
Result,
mapOnePars,
libSucceed,
InputState(..),
OutputState(..),
Sequence(..),
Alternative(..),
Symbol(..),
SymParser(..),
SplitParser(..),
IsParser,
RealParser(..),
RealRecogn(..),
Either'(..),
ParsRec(..),
Message(..),
AnaParser,
Parser,
Steps(..),
Pair(..),
Exp(..),
pLocate,
pToks,
list_of ,
usealg ,
pMerged,
pLength,
(<||>) ,
pAnySym,
pAny ,
pChainl,
pChainl_ng,
pChainl_gr,
pChainr,
pChainr_ng,
pChainr_gr,
pList1Sep,
pList1Sep_ng,
pList1Sep_gr,
pListSep,
pListSep_ng,
pListSep_gr,
pList1,
pList1_ng,
pList1_gr,
pList,
pList_ng,
pList_gr,
list_alg,
pFoldr1Sep,
pFoldr1Sep_ng,
pFoldr1Sep_gr,
pFoldrSep,
pFoldrSep_ng,
pFoldrSep_gr,
pFoldr1,
pFoldr1_ng,
pFoldr1_gr,
pFoldr,
pFoldr_gr,
pFoldr_ng,
pPacked,
(<?>),
(<??>),
(<$$>),
(<**>),
(*>),
(<*),
(<$),
(<+>),
asOpt,
asList1,
asList,
opt ,
pExcept,
(<..>) ,
mnz,
acceptsepsilon,
p2p,pPermsSep,pPerms,add,(~$~),(~*~),
systemerror,
usererror,
handleEof,
pDynL,
pDynE,
-- getErrors,
getMsgs,
parse ,parsebasic,parseIO,
evalSteps,evalStepsIO,getMsgs,
pCostRange,
pCostSym,
pSym,
pRange,
getfirsts,
setfirsts,
(<*>),
pSucceed,
pLow,
(<$>),
(<|>),
pFail,
pMap,
pWrap,
val
)
where
import Maybe
--import PrelGHC
import IOExts
btLookup :: BinSearchTree (a -> Ordering) (Maybe b) -> a -> Maybe b
tab2tree :: Ord a => [(SymbolR a,b)] -> BinSearchTree (a -> Ordering) b
pLocate :: (Alternative a, SymParser a b, Sequence a) => [[b]] -> a [b]
pToks :: (Sequence a, SymParser a b) => [b] -> a [b]
list_of :: Sequence a => a b -> ([c],a ([b] -> [b]),d -> d)
usealg :: Sequence a => (b -> c,d) -> a b -> (d,a c,e -> e)
pMerged :: (Sequence a, Alternative a, Show (Exp b), SymParser a b, SplitParser a) => c -> (d,a (d -> d),c -> d -> e) -> a e
(<||>) :: (Sequence a, Alternative a) => (b,a (c -> c),d -> e -> f) -> (g,a (h -> h),f -> i -> j) -> ((b,g),a ((c,h) -> (c,h)),d -> (e,i) -> j)
pAnySym :: (Alternative a, SymParser a b) => [b] -> a b
pAny :: Alternative a => (b -> a c) -> [b] -> a c
pChainl :: (SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a (c -> c -> c) -> a c -> a c
pChainl_ng :: (SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a (c -> c -> c) -> a c -> a c
pChainl_gr :: (SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a (c -> c -> c) -> a c -> a c
pChainr :: (SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a (c -> c -> c) -> a c -> a c
pChainr_ng :: (SplitParser a, SymParser a b, Show (Exp b), Alternative a, Sequence a) => a (c -> c -> c) -> a c -> a c
pChainr_gr :: (SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a (c -> c -> c) -> a c -> a c
pList1Sep :: (SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a c -> a d -> a [d]
pList1Sep_ng :: (SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a c -> a d -> a [d]
pList1Sep_gr :: (SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a c -> a d -> a [d]
pListSep :: (SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a c -> a d -> a [d]
pListSep_ng :: (SplitParser a, SymParser a b, Show (Exp b), Alternative a, Sequence a) => a c -> a d -> a [d]
pListSep_gr :: (SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a c -> a d -> a [d]
pList1 :: (SymParser a b, Sequence a, Show (Exp b), SplitParser a, Alternative a) => a c -> a [c]
pList1_ng :: (SymParser a b, Sequence a, Show (Exp b), SplitParser a, Alternative a) => a c -> a [c]
pList1_gr :: (SymParser a b, Sequence a, Show (Exp b), SplitParser a, Alternative a) => a c -> a [c]
pList :: (SymParser a b, Show (Exp b), SplitParser a, Sequence a, Alternative a) => a c -> a [c]
pList_ng :: (SymParser a b, Show (Exp b), SplitParser a, Sequence a, Alternative a) => a c -> a [c]
pList_gr :: (SymParser a b, Show (Exp b), SplitParser a, Sequence a, Alternative a) => a c -> a [c]
list_alg :: (a -> [a] -> [a],[b])
pFoldr1Sep :: (SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => (c -> d -> d,d) -> a e -> a c -> a d
pFoldr1Sep_ng :: (SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => (c -> d -> d,d) -> a e -> a c -> a d
pFoldr1Sep_gr :: (SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => (c -> d -> d,d) -> a e -> a c -> a d
pFoldrSep :: (SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => (c -> d -> d,d) -> a e -> a c -> a d
pFoldrSep_ng :: (SplitParser a, SymParser a b, Show (Exp b), Alternative a, Sequence a) => (c -> d -> d,d) -> a e -> a c -> a d
pFoldrSep_gr :: (SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => (c -> d -> d,d) -> a e -> a c -> a d
pFoldr1 :: (SymParser a b, Sequence a, Show (Exp b), SplitParser a, Alternative a) => (c -> d -> d,d) -> a c -> a d
pFoldr1_ng :: (SymParser a b, Sequence a, Show (Exp b), SplitParser a, Alternative a) => (c -> d -> d,d) -> a c -> a d
pFoldr1_gr :: (SymParser a b, Sequence a, Show (Exp b), SplitParser a, Alternative a) => (c -> d -> d,d) -> a c -> a d
pFoldr :: (SymParser a b, Show (Exp b), SplitParser a, Sequence a, Alternative a) => (c -> d -> d,d) -> a c -> a d
pFoldr_gr :: (SymParser a b, Show (Exp b), SplitParser a, Sequence a, Alternative a) => (c -> d -> d,d) -> a c -> a d
pFoldr_ng :: (SymParser a b, Show (Exp b), SplitParser a, Sequence a, Alternative a) => (c -> d -> d,d) -> a c -> a d
pPacked :: Sequence a => a b -> a c -> a d -> a d
(<?>) :: SymParser a b => a c -> [Char] -> a c
(<??>) :: (Sequence a, Alternative a, Show (Exp b), SymParser a b, SplitParser a) => a c -> a (c -> c) -> a c
(<$$>) :: Sequence a => (b -> c -> d) -> a c -> a (b -> d)
(<**>) :: Sequence a => a b -> a (b -> c) -> a c
(<+>) :: Sequence a => a b -> a c -> a (b,c)
asOpt :: SymParser a b => Exp b -> a c -> a c
asList1 :: SymParser a b => Exp b -> a c -> a c
asList :: SymParser a b => Exp b -> a c -> a c
opt :: (SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a c -> c -> a c
pExcept :: (Alternative a, SymParser a b, Eq (SymbolR b), Symbol b) => (b,b,b) -> [b] -> a b
(<..>) :: SymParser a b => b -> b -> a b
mnz :: (SplitParser a, SymParser a b, Show (Exp b)) => a c -> d -> d
acceptsepsilon :: SplitParser a => a b -> Bool
p2p :: (Alternative a, Sequence a) => a b -> a c -> Perms a d -> a d
pPermsSep :: (Alternative a, Sequence a) => a b -> Perms a c -> a c
pPerms :: (Alternative a, Sequence a) => Perms a b -> a b
add :: Sequence a => Perms a (b -> c) -> (Maybe (a b),Maybe (a b)) -> Perms a c
(~$~) :: (Sequence a, SplitParser a) => (b -> c) -> a b -> Perms a c
(~*~) :: (Sequence a, SplitParser a) => Perms a (b -> c) -> a b -> Perms a c
systemerror :: [Char] -> [Char] -> a
usererror :: [Char] -> a
except :: Symbol a => SymbolR a -> [a] -> [SymbolR a]
symRS :: Ord a => SymbolR a -> a -> Ordering
symInRange :: Ord a => SymbolR a -> a -> Bool
mk_range :: Ord a => a -> a -> SymbolR a
mergeTables :: (Symbol a, Ord b) => [(SymbolR a,ParsRec c d b e)] -> [(SymbolR a,ParsRec c d b e)] -> [(SymbolR a,ParsRec c d b e)]
nat_add :: Nat -> Nat -> Nat
nat_min :: Nat -> Nat -> (Nat,(a,a) -> (a,a))
nat_le :: Nat -> Nat -> Bool
lib_correct :: Ord a => (b -> c -> Steps d a) -> (b -> c -> Steps d a) -> b -> c -> Steps d a
mkParser :: InputState a b => Maybe (Bool,Either c (ParsRec a d b c)) -> OneDescr a d b c -> AnaParser a d b c
mapOnePars :: (ParsRec a b c d -> ParsRec e f c g) -> (Nat -> Nat) -> OneDescr a b c d -> OneDescr e f c g
anaSetFirsts :: InputState a b => Exp b -> AnaParser a c b d -> AnaParser a c b d
anaGetFirsts :: AnaParser a b c d -> Exp c
pLength :: AnaParser a b c d -> Nat
anaCostSym :: SymParser a b => Int{-I-} -> b -> b -> a b
anaCostRange :: InputState a b => Int{-I-} -> b -> SymbolR b -> AnaParser a c b b
orOneOneDescr :: (Ord (Exp a), Eq (SymbolR a)) => OneDescr b c a d -> OneDescr b c a d -> Bool -> OneDescr b c a d
seqZeroZero :: Maybe (Bool,Either a b) -> Maybe (Bool,Either c (ParsRec d e f c)) -> (a -> ParsRec d e f c -> g) -> (b -> ParsRec d e f c -> g) -> (a -> c -> h) -> Maybe (Bool,Either h g)
anaSeq :: (Ord (Exp a), Eq (SymbolR a), InputState b a) => (c -> ParsRec d e a f -> ParsRec b g a h) -> (ParsRec i j a c -> ParsRec d e a f -> ParsRec b g a h) -> (c -> f -> h) -> AnaParser i j a c -> AnaParser d e a f -> AnaParser b g a h
anaOr :: (InputState a b, Ord (Exp b), Eq (SymbolR b), Show (Exp b)) => AnaParser a c b d -> AnaParser a c b d -> AnaParser a c b d
anaDynN :: InputState a b => Exp b -> Nat -> SymbolR b -> TableEntry a c b d -> AnaParser a c b d
anaDynL :: ParsRec a b c d -> AnaParser a b c d
anaDynE :: ParsRec a b c d -> AnaParser a b c d
anaLow :: a -> AnaParser b c d a
anaSucceed :: a -> AnaParser b c d a
pEmpty :: ParsRec a b c d -> (Bool,Either d (ParsRec a b c d)) -> AnaParser a b c d
noOneParser :: OneDescr a b c d
anaFail :: AnaParser a b c d
traverse :: Pairs -> Pairs -> Steps a b -> Int{-I-} -> Pairs
libCorrect :: Ord a => Steps b a -> Steps c a -> (b -> d) -> (c -> d) -> Steps d a
libBest' :: Ord a => Steps b a -> Steps c a -> (b -> d) -> (c -> d) -> Steps d a
libBest :: Ord a => Steps b a -> Steps b a -> Steps b a
eor :: Ord (Exp a) => Exp a -> Exp a -> Exp a
addexpecting :: Ord a => Exp a -> Steps b a -> Steps b a
marks :: [Char]
addToMessage :: Ord (Exp a) => Message a -> Exp a -> Message a
getStart :: Message a -> Exp a
getMsgs :: Steps a b -> [Message b]
evalStepsIO :: Symbol a => Steps b a -> IO b
evalSteps :: Steps a b -> a
hasSuccess :: Steps a b -> Bool
starting :: Steps a b -> Exp b
libFail :: ParsRec a b c d
libOr :: Ord a => ParsRec b c a d -> ParsRec b c a d -> ParsRec b c a d
libSeqR :: ParsRec a b c d -> ParsRec a e c f -> ParsRec a e c f
libSeqL :: ParsRec a b c d -> ParsRec a e c f -> ParsRec a b c d
libDollarR :: a -> ParsRec b c d e -> ParsRec b c d e
libDollarL :: a -> ParsRec b c d e -> ParsRec b f d a
libDollar :: OutputState a => (b -> c) -> ParsRec d a e b -> ParsRec d a e c
libSeq :: OutputState a => ParsRec b a c (d -> e) -> ParsRec b f c d -> ParsRec b f c e
libSucceed :: a -> ParsRec b c d a
libInsert :: InputState a b => Int{-I-} -> b -> Exp b -> ParsRec a c b b
libAccept :: InputState a b => ParsRec a c b b
unR :: RealRecogn a b -> (a b -> Result c b) -> a b -> Result c b
unP :: RealParser a b c d -> (d -> b e f -> g) -> (a c -> Result (b e f) c) -> a c -> Result g c
pDynN :: InputState a b => Exp b -> Nat -> SymbolR b -> TableEntry a c b d -> AnaParser a c b d
pDynL :: ParsRec a b c d -> AnaParser a b c d
pDynE :: ParsRec a b c d -> AnaParser a b c d
handleEof :: InputState a b => a b -> Steps (Pair (a b) c) b
parse :: InputState a b => AnaParser a Pair b c -> a b -> Steps (Pair c (Pair (a b) d)) b
parseIO :: InputState a b => AnaParser a Pair b c -> a b -> IO c
parsebasic :: InputState a b => ParsRec a Pair b c -> a b -> Steps (Pair c (Pair (a b) d)) b
parsebasic (PR ( P rp, _)) inp
= (rp Pair handleEof inp)
parseIO (pp) inp
= do (Pair v final) <- evalStepsIO (parsebasic (pars pp) inp)
final `seq` return v -- in order to force the trailing error messages to be printed
parse (pp) inp
= parsebasic (pars pp) inp
handleEof input = case splitStateE input
of Left' s ss -> StRepair (deleteCost s) (Msg ("deleting symbol " ++ show s
, "in unused part of input"
, (EStr "eof")
)) (handleEof ss)
Right' final -> NoMoreSteps (Pair final undefined)
-- =======================================================================================
-- ===== PRIORITIES ======================================================================
-- =======================================================================================
infixl 2 <?>
infixl 3 <|>
infixl 4 <*>, <$> , <+>
infixl 4 ~*~, ~$~
infixl 4 <$, <*, *>, <**>, <??>
infixl 2 `opt`
infixl 5 <..>
-- =======================================================================================
-- ===== ANAPARSER INSTANCES =============================================================
-- =======================================================================================
type Parser = AnaParser [] Pair
data Pair a r = Pair a r
data Either' state s = Left' s (state s)
| Right' (state s)
instance Symbol s => InputState [] s where
splitStateE [] = Right' []
splitStateE (s:ss) = Left' s ss
splitState (s:ss) = ({-L-} s, ss{-R-})
firstState [] = Nothing
firstState (s:ss) = Just s
getPosition [] = "unexpected end of input"
getPosition (s:ss) = "before " ++ show s
instance OutputState Pair where
acceptR = Pair
nextR acc = \ f ~(Pair a r) -> acc (f a) r
dollarR acc f = \ v r -> acc (f v) r
instance (Symbol s, InputState state s, OutputState result) => Sequence (AnaParser state result s) where
(<*>) p q = anaSeq libDollar libSeq ($) p q
(<* ) p q = anaSeq libDollarL libSeqL const p q
( *>) p q = anaSeq libDollarR libSeqR (flip const) p q
pSucceed = anaSucceed
pLow = anaLow
instance (Symbol s, InputState state s, OutputState result) => Alternative (AnaParser state result s) where
(<|>) = anaOr
pFail = anaFail
instance (Symbol s, InputState state s, OutputState result) => SymParser (AnaParser state result s) s where
pCostRange = anaCostRange
pCostSym = anaCostSym
getfirsts = anaGetFirsts
setfirsts = anaSetFirsts
instance (InputState state s, OutputState result, Symbol s) => SplitParser (AnaParser state result s) where
getzerop p = case zerop p of
Nothing -> Nothing
Just (b,e) -> Just p {pars=libSucceed `either` id $ e
,onep=noOneParser
}
getonep p = let tab = table (onep p)
in if null tab then Nothing else Just (mkParser Nothing (onep p))
pDynE v = anaDynE v
pDynL v = anaDynL v
pDynN v = anaDynN v
-- =======================================================================================
-- ===== PARSER CLASSES ==================================================================
-- =======================================================================================
class (Sequence p, Alternative p, SymParser p s, SplitParser p, Show s) => IsParser p s | p -> s
instance (Sequence p, Alternative p, SymParser p s, SplitParser p, Show s) => IsParser p s
class Sequence p where
(<*>) :: p (a->b) -> p a -> p b
(<* ) :: p a -> p b -> p a
( *>) :: p a -> p b -> p b
(<$>) :: (a->b) -> p a -> p b
(<$ ) :: f -> p a -> p f
pSucceed :: a -> p a
pLow :: a -> p a
f <$> p = pSucceed f <*> p
f <$ q = pSucceed f <* q
p <* q = pSucceed const <*> p <*> q
p *> q = pSucceed (flip const) <*> p <*> q
class Alternative p where
(<|>) :: p a -> p a -> p a
pFail :: p a
class SymParser p s | p -> s where
pCostRange :: Int{-I-} -> s -> SymbolR s -> p s
pCostSym :: Int{-I-} -> s -> s -> p s
pSym :: s -> p s
pRange :: s -> SymbolR s -> p s
getfirsts :: p v -> Exp s
setfirsts :: Exp s -> p v -> p v
pSym a = pCostSym 5{-I-} a a
pRange = pCostRange 5{-I-}
class SplitParser p where
getzerop :: p v -> Maybe (p v)
getonep :: p v -> Maybe (p v)
class Symbol s => InputState state s where
splitStateE :: state s -> Either' state s
splitState :: state s -> ({-L-} s, state s {-R-})
firstState :: state s -> (Maybe s)
getPosition :: state s -> String
{-# INLINE splitStateE #-}
{-# INLINE splitState #-}
class OutputState r where
acceptR :: v -> rest -> r v rest
nextR :: (a -> rest -> rest') -> (b -> a) -> (r b rest) -> rest'
dollarR :: (a -> r c rest -> rest') -> (b -> a) -> b -> (r c rest) -> rest'
{-# INLINE acceptR #-}
{-# INLINE nextR #-}
{-# INLINE dollarR #-}
class (Ord s, Show s) => Symbol s where
deleteCost :: s -> Int{-I-}
symBefore :: s -> s
symAfter :: s -> s
deleteCost b = 5{-I-}
symBefore = error "You should have made your token type an instance of the Class Symbol. eg by defining symBefore = pred"
symAfter = error "You should have made your token type an instance of the Class Symbol. eg by defining symAfter = succ"
-- ==========================================================================================
-- ===== BASIC PARSER TYPE =================================================================
-- =======================================================================================
type Result val s = Steps val s
newtype RealParser state result s a = P(forall r r' b. (a -> result b r -> r') ->
(state s -> Result (result b r) s) -> state s -> Result r' s)
newtype RealRecogn state s = R(forall r . (state s -> Result r s) -> state s -> Result r s)
newtype ParsRec state result s a = PR ( RealParser state result s a
, RealRecogn state s
)
{-# INLINE unP #-}
{-# INLINE unR #-}
unP (P p) = p
unR (R p) = p
-- =======================================================================================
-- ===== CORE PARSERS ====================================================================
-- =======================================================================================
libAccept = PR (P (\ acc k state ->
case splitState state of
({-L-} s, ss {-R-}) -> OkVal (acc s) (k ss))
,R (\ k state ->
case splitState state of
({-L-} s, ss {-R-}) -> Ok (k ss))
)
libInsert c sym firsts = PR ( P (\acc k state -> StRepair c (Msg ("inserting symbol " ++ show sym
, getPosition state
, firsts
)) (val (acc sym) (k state)))
, R (\ k state -> StRepair c (Msg ("inserting symbol " ++ show sym
, getPosition state
, firsts
)) (k state))
)
{-# INLINE libSeq #-}
{-# INLINE libSeqL #-}
{-# INLINE libSeqR #-}
{-# INLINE libDollar #-}
{-# INLINE libDollarL #-}
{-# INLINE libDollarR #-}
{-# INLINE libSucceed #-}
libSucceed v = PR ( P (\ acc -> let accv = val (acc v) in \ k state -> accv (k state))
, R id
)
libSeq (PR (P pp, R pr)) ~(PR (P qp, R qr)) = PR ( P (\ acc -> pp (nextR acc).qp acceptR)
, R (pr.qr)
)
libDollar f (PR (P qp, R qr)) = PR ( P (\ acc -> qp (dollarR acc f))
, R qr
)
libDollarL f (PR (P qp, R qr)) = PR ( P (\ acc -> let accf = val (acc f) in \ k -> qr (\ state -> accf ( k state)))
, R qr
)
libDollarR f (PR (P qp, R qr)) = PR (P qp, R qr)
libSeqL (PR (P pp, R pr)) ~(PR (P qp, R qr)) = PR ( P (\acc -> pp acc.qr)
, R(pr.qr)
)
libSeqR (PR (P pp, R pr)) ~(PR (P qp, R qr)) = PR ( P (\acc -> pr.qp acc )
, R(pr.qr)
)
libOr (PR (P pp, R pr)) (PR (P qp, R qr)) = PR ( P (\ acc -> let p = pp acc
q = qp acc
in \ k state -> p k state `libBest` q k state)
, R (\ k state -> pr k state `libBest` qr k state)
)
libFail = PR ( P (\ _ _ _ -> (usererror "calling an always failing parser" ))
, R (\ _ _ -> (usererror "calling an always failing recogniser"))
)
-- =======================================================================================
-- ===== STEPS ===========================================================================
-- =======================================================================================
data Steps val s
= forall a . OkVal (a -> val) (Steps a s)
| Ok { rest :: Steps val s}
| Cost {costing::Int{-I-} , rest :: Steps val s}
| StRepair {costing::Int{-I-}, m :: Message s , rest :: Steps val s}
| forall v w.Best (Steps v s) (Steps val s) (Exp s) ( Steps w s)
| NoMoreSteps val
val f (OkVal a rest) = OkVal (f.a) rest
val f (Ok rest) = OkVal f rest
val f (Cost i rest) = Cost i (val f rest)
val f (StRepair c m r) = StRepair c m (val f r)
val f (Best l s e r) = Best l (val f s) e r
val f (NoMoreSteps v) = NoMoreSteps (f v)
starting (StRepair _ m _ ) = getStart m
starting (Best _ _ s _ ) = s
starting _ = systemerror "UU_Parsing" "starting"
hasSuccess (OkVal _ _ ) = True
hasSuccess (Ok _ ) = True
hasSuccess (NoMoreSteps _) = True
hasSuccess (Cost i _ ) = True
hasSuccess _ = False
evalSteps (OkVal v rest ) = v (evalSteps rest)
evalSteps (Ok rest ) = evalSteps rest
evalSteps (Cost _ rest ) = evalSteps rest
evalSteps (StRepair _ msg rest ) = evalSteps rest
evalSteps (Best _ rest _ _) = evalSteps rest
evalSteps (NoMoreSteps v ) = v
evalStepsIO (OkVal v rest ) = do arg <- unsafeInterleaveIO (evalStepsIO rest)
return (v arg)
evalStepsIO (Ok rest ) = evalStepsIO rest
evalStepsIO (Cost _ rest ) = evalStepsIO rest
evalStepsIO (StRepair _ msg rest ) = do putStr (show msg)
evalStepsIO rest
evalStepsIO (Best _ rest _ _) = evalStepsIO rest
evalStepsIO (NoMoreSteps v ) = return v
getMsgs (OkVal _ rest) = getMsgs rest
getMsgs (Ok rest) = getMsgs rest
getMsgs (Cost _ rest) = getMsgs rest
getMsgs (StRepair _ m rest) = m:getMsgs rest
getMsgs (Best _ m _ _) = getMsgs m
getMsgs (NoMoreSteps _ ) = []
newtype Message s = Msg (String, String, Exp s) -- action, position, expecting
getStart (Msg (_,_,st)) = st
addToMessage (Msg (act, pos, exp)) more = Msg (act, pos, more `eor` exp)
marks = '\n':take 60 qmarks
where qmarks = '?':qmarks
instance Symbol s => Show (Message s) where
show (Msg (action, position, expecting))
= marks ++
"\n?? Error : " ++ position ++
"\n?? Expecting : " ++ show expecting ++
"\n?? Repaired by: " ++ action ++
marks ++"\n"
addexpecting more (StRepair cost msg rest) = StRepair cost (addToMessage msg more) rest
addexpecting more (Best l sel starting r) = Best l (addexpecting more sel) starting r
addexpecting more (OkVal v rest ) = systemerror "UU_Parsing" ("addexpecting: OkVal")
addexpecting more (Ok _ ) = systemerror "UU_Parsing" ("addexpecting: Ok")
addexpecting more (Cost _ _ ) = systemerror "UU_Parsing" ("addexpecting: Cost")
addexpecting more _ = systemerror "UU_Parsing" ("addexpecting: other")
data Exp s = ESym (SymbolR s)
| EStr String
| EOr [Exp s]
| ESeq [Exp s]
deriving (Ord, Eq)
eor p q = EOr (merge (tolist p) (tolist q))
where merge x@(l:ll) y@(r:rr) = case compare l r of
LT -> l:( ll `merge` y)
GT -> r:( x `merge` rr)
EQ -> l:( ll `merge` rr)
merge l [] = l
merge [] r = r
tolist (EOr l) = l
tolist x = [x]
instance Symbol s => Show (Exp s) where
show (ESym s) = show s
show (EStr str) = str
show (EOr []) = "Nothing expected "
show (EOr [e]) = show e
show (EOr (e:ee)) = show e ++ " or " ++ show (EOr ee)
show (ESeq seq) = concat (map show seq)
-- =======================================================================================
-- ===== SELECTING THE BEST RESULT ======================================================
-- =======================================================================================
-- INV: the first argument should be the shorter insertion
libBest ls rs = libBest' ls rs id id
libBest' (OkVal v ls) (OkVal w rs) lf rf = Ok (libBest' ls rs (lf.v) (rf.w))
libBest' (OkVal v ls) (Ok rs) lf rf = Ok (libBest' ls rs (lf.v) rf )
libBest' (Ok ls) (OkVal w rs) lf rf = Ok (libBest' ls rs lf (rf.w))
libBest' (Ok ls) (Ok rs) lf rf = Ok (libBest' ls rs lf rf )
libBest' (OkVal v ls) _ lf rf = OkVal (lf.v) ls
libBest' _ (OkVal w rs) lf rf = OkVal (rf.w) rs
libBest' (Ok ls) _ lf rf = OkVal lf ls
libBest' _ (Ok rs) lf rf = OkVal rf rs
libBest' l@(Cost i ls ) r@(Cost j rs ) lf rf
| i =={-I-} j = Cost i (libBest' ls rs lf rf)
| i <{-I-} j = Cost i (val lf ls)
| i >{-I-} j = Cost j (val rf rs)
libBest' l@(Cost i ls) _ lf rf = Cost i (val lf ls)
libBest' _ r@(Cost j rs) lf rf = Cost j (val rf rs)
libBest' l@(NoMoreSteps v) _ lf rf = NoMoreSteps (lf v)
libBest' _ r@(NoMoreSteps w) lf rf = NoMoreSteps (rf w)
libBest' l r lf rf = libCorrect l r lf rf
libCorrect ls rs lf rf
= let (Pairs _ select) = traverse (traverse (Pairs 999{-I-} fst) (Pairs 0{-I-} fst) ls 4{-I-}) (Pairs 0{-I-} snd) rs 4{-I-}
leftstart = starting ls
rightstart = starting rs
in Best ls
(select (val lf (addexpecting rightstart ls), val rf (addexpecting leftstart rs)))
(leftstart `eor` rightstart)
rs
data Pairs = Pairs Int{-I-} (forall a. (a,a) -> a)
traverse b@(Pairs bv br) t@(Pairs tv tr) _ 0{-I-} = if bv <{-I-} tv then b else t
traverse b@(Pairs bv br) t@(Pairs tv tr) (Ok l) n = traverse b t l (n -{-I-} 1{-I-})
traverse b@(Pairs bv br) t@(Pairs tv tr) (OkVal v l) n = traverse b t l (n -{-I-} 1{-I-})
traverse b@(Pairs bv br) t@(Pairs tv tr) (Cost i l) n = if i +{-I-} tv >={-I-} bv then b else traverse b (Pairs (i +{-I-} tv) tr) l (n -{-I-} 1{-I-})
traverse b@(Pairs bv br) t@(Pairs tv tr) (Best l _ _ r) n = traverse (traverse b t l n) t r n
traverse b@(Pairs bv br) t@(Pairs tv tr) (StRepair i msgs r) n = if i +{-I-} tv >={-I-} bv then b else traverse b (Pairs (i +{-I-} tv) tr) r (n -{-I-} 1{-I-})
traverse b@(Pairs bv br) t@(Pairs tv tr) (NoMoreSteps _) n = if bv <{-I-} tv then b else t
-- =======================================================================================
-- ===== DESCRIPTORS =====================================================================
-- =======================================================================================
data AnaParser state result s a
= AnaParser { pars :: ParsRec state result s a
, zerop :: Maybe (Bool, Either a (ParsRec state result s a))
, onep :: OneDescr state result s a
} -- deriving Show
data OneDescr state result s a
= OneDescr { leng :: Nat
, firsts :: Exp s
, table :: [(SymbolR s, TableEntry state result s a)]
} -- deriving Show
data TableEntry state result s a = TableEntry (ParsRec state result s a) (Exp s -> ParsRec state result s a)
-- =======================================================================================
-- ===== ANALYSING COMBINATORS ===========================================================
-- =======================================================================================
anaFail = AnaParser { pars = libFail
, zerop = Nothing
, onep = noOneParser
}
noOneParser = OneDescr Infinite (EOr []) []
pEmpty p zp = AnaParser { pars = p
, zerop = Just zp
, onep = noOneParser
}
anaSucceed v = pEmpty (libSucceed v) (False, Left v)
anaLow v = pEmpty (libSucceed v) (True, Left v)
anaDynE p = pEmpty p (False, Right p)
anaDynL p = pEmpty p (True , Right p)
anaDynN fi len range p = mkParser Nothing (OneDescr len fi [(range, p)])
anaOr ld@(AnaParser _ zl ol) rd@(AnaParser _ zr or)
= mkParser newZeroDescr newOneDescr
where newZeroDescr = case zl of {Nothing -> zr
;_ -> case zr of {Nothing -> zl
;_ -> usererror ("Two empty alternatives, where expecting"++show (firsts newOneDescr))
} }
newOneDescr = orOneOneDescr ol or False
{-# INLINE anaSeq #-}
anaSeq libdollar libseq comb (AnaParser pl zl ol) ~rd@(AnaParser pr zr or)
= case zl of
Just (b, zp ) -> let newZeroDescr = seqZeroZero zl zr libdollar libseq comb
newOneDescr = let newOneOne = mapOnePars ( `libseq` pr) (const Infinite) ol
newZeroOne = case zp of
Left f -> mapOnePars (f `libdollar` ) id or
Right p -> mapOnePars (p `libseq` ) id or
in orOneOneDescr newZeroOne newOneOne b -- left one is shortest
in mkParser newZeroDescr newOneDescr
_ -> AnaParser (pl `libseq` pr) Nothing (mapOnePars (`libseq` pr) (`nat_add` (pLength rd)) ol)
seqZeroZero Nothing _ _ _ _ = Nothing
seqZeroZero _ Nothing _ _ _ = Nothing
seqZeroZero (Just (llow, left)) (Just (rlow, right)) libdollar libseq comb
= Just ( llow || rlow
, case left of
Left lv -> case right of
Left rv -> Left (comb lv rv)
Right rp -> Right (lv `libdollar` rp)
Right lp -> case right of
Left rv -> Right (lp `libseq` libSucceed rv)
Right rp -> Right (lp `libseq` rp)
)
orOneOneDescr ~(OneDescr ll fl tl) ~(OneDescr lr fr tr) b
= let newfirsts = (fl `eor` fr)
(newlength, maybeswap) = ll `nat_min` lr
(tla, tra) = if b then (tl, tr) else maybeswap (tl, tr)
keystr = map fst tra
lefttab = if b then [r | r@(k,_) <- tla, not (k `elem` keystr)] else tla
in OneDescr newlength (fl `eor` fr) (lefttab ++ tra)
anaCostRange _ _ EmptyR = anaFail
anaCostRange ins_cost ins_sym range
= mkParser Nothing ( OneDescr (Succ Zero) (ESym range) [(range, TableEntry libAccept
(libInsert ins_cost ins_sym)
)])
anaCostSym i ins sym = pCostRange i ins (Range sym sym)
pLength (AnaParser _ (Just _) _ ) = Zero
pLength (AnaParser _ Nothing od) = leng od
anaGetFirsts (AnaParser p z od) = firsts od
anaSetFirsts newexp (AnaParser _ zd od)
= mkParser zd (od{firsts = newexp })
-- =======================================================================================
-- ===== UTILITIES ========================================================================
-- =======================================================================================
mapOnePars fp fl ~(OneDescr l fi t) = OneDescr (fl l) fi [ (k, TableEntry (fp p) (fp.corr))
| (k, TableEntry p corr ) <- t
]
-- =======================================================================================
-- ===== MKPARSER ========================================================================
-- =======================================================================================
mkParser zd ~descr@(OneDescr _ (firsts) tab) -- pattern matching should be lazy for lazy computation of length for empty parsers
= let parstab = foldr1 mergeTables [[(k, p)]| (k, TableEntry p _) <- tab]
mkactualparser getp
= let find = case parstab of
[(ran, pp)] -> let comp = symInRange ran
pars = Just (getp pp)
in \ s -> if comp s then pars else Nothing
_ -> btLookup.tab2tree $ [(k,Just (getp pr) )| (k, pr) <- parstab]
zerop = getp (case zd of
Nothing -> libFail
Just (_, Left v) -> libSucceed v
Just (_, Right p) -> p
)
insertsyms = foldr1 lib_correct [ getp (pr firsts)| (_ , TableEntry _ pr) <- tab ]
correct k inp
= case splitState inp of
({-L-} s, ss {-R-}) -> libCorrect (StRepair(deleteCost s) (Msg ("deleting symbol " ++ show s
, getPosition inp
, firsts
) ) (result k ss))
(insertsyms k inp) id id
result = if null tab then zerop
else case zd of
Nothing ->(\k inp -> case splitStateE inp of
Left' s ss -> case find s of
Just p -> p k inp
Nothing -> correct k inp
Right' _ -> insertsyms k inp)
Just (True, _) ->(\k inp -> case splitStateE inp of
Left' s ss -> case find s of
Just p -> p k inp
Nothing -> let r = zerop k inp
in if hasSuccess r then r else libCorrect r (correct k inp) id id
Right' _ -> zerop k inp)
Just (False, _) ->(\k inp -> case splitStateE inp of
Left' s ss -> case find s of
Just p -> p k inp `libBest` zerop k inp
Nothing -> let r = zerop k inp
in if hasSuccess r then r else libCorrect r (correct k inp) id id
Right' _ -> zerop k inp)
in result
res = PR (P ( \ acc -> mkactualparser (\ (PR (P p, _)) -> p acc))
,R ( mkactualparser (\ (PR (_, R p)) -> p ))
)
in AnaParser res zd descr
lib_correct p q = \k inp -> libCorrect (p k inp) ( q k inp) id id
-- =======================================================================================
-- ===== MINIMAL LENGTHS (lazily formulated) =============================================
-- =======================================================================================
data Nat = Zero
| Succ Nat
| Infinite
deriving (Eq, Show)
nat_le Zero _ = True
nat_le _ Zero = False
nat_le Infinite _ = False
nat_le _ Infinite = True
nat_le (Succ l) (Succ r) = nat_le l r
nat_min Infinite r = (r, swap) where swap (a,b) = (b,a)
nat_min l Infinite = (l, id)
nat_min Zero _ = (Zero, id)
nat_min _ Zero = (Zero, swap) where swap (a,b) = (b,a)
nat_min (Succ ll) (Succ rr) = let (v, fl) = ll `nat_min` rr in (Succ v, fl)
nat_add Infinite _ = Infinite
nat_add Zero r = r
nat_add (Succ l) r = Succ (nat_add l r)
-- =======================================================================================
-- ===== CHOICE STRUCTURES =============================================================
-- =======================================================================================
mergeTables l [] = l
mergeTables [] r = r
mergeTables lss@(l@(le@(Range a b),ct ):ls) rss@(r@(re@(Range c d),ct'):rs)
= let ct'' = ct `libOr` ct'
in if c<a then mergeTables rss lss -- swap
else if b<c then l:mergeTables ls rss -- disjoint case
else if a<c then (Range a (symBefore c),ct) :mergeTables ((Range c b,ct):ls) rss
else if b<d then (Range a b,ct'') :mergeTables ((Range (symAfter b) d,ct'):rs) ls
else if b>d then mergeTables rss lss
else (le,ct'') : mergeTables ls rs-- equals
-- =======================================================================================
-- ===== WRAPPING AND MAPPING ==============================================================
-- =======================================================================================
libMap :: (forall r r'' . (b -> r -> r'') -> state s -> Result (a, r) s -> ( state s, Result r'' s))
-> (forall r . state s -> Result ( r) s -> ( state s, Result r s))
-> ParsRec state result s a -> ParsRec state result s b
libMap f f' (PR (P p, R r)) = PR ( P(\acc -> let pp = p (,)
facc = f acc
in \ k instate -> let inresult = pp k outstate
(outstate, outresult) = facc instate inresult
in outresult
)
, R(\ k instate -> let inresult = r k outstate
(outstate, outresult) = f' instate inresult
in outresult)
)
pMap :: OutputState result =>
(forall r r'' . (b -> r -> r'') -> state s -> Result (a, r) s -> ( state s, Result r'' s))
-> (forall r . state s -> Result ( r) s -> ( state s, Result r s))
-> AnaParser state result s a -> AnaParser state result s b
pMap f f' (AnaParser p z o) = AnaParser (libMap f f' p)
(case z of
Nothing -> Nothing
Just (b, v) -> Just (b, case v of
Left w -> Right (libMap f f' (libSucceed w))
Right pp -> Right (libMap f f' pp)))
(mapOnePars (libMap f f') id o)
libWrap :: (forall r r'' . (b -> r -> r'')
-> state s
-> Result (a, r) s
-> (state s -> Result r s)
-> (state s, Result r'' s, state s -> Result r s))
-> (forall r . state s
-> Result r s
-> (state s -> Result r s)
-> (state s, Result r s, state s -> Result r s))
-> ParsRec state result s a -> ParsRec state result s b
libWrap f f' (PR (P p, R r)) = PR ( P(\ acc -> let pp = p (,)
facc = f acc
in \ k instate -> let (stl, ar, str2rr) = facc instate rl k
rl = pp str2rr stl
in ar
)
, R(\ k instate -> let (stl, ar, str2rr) = f' instate rl k
rl = r str2rr stl
in ar)
)
pWrap :: OutputState result
=> (forall r r''. (b -> r -> r'')
-> state s
-> Result (a, r) s
-> (state s -> Result r s)
-> (state s, Result r'' s, state s -> Result r s))
-> (forall r . state s
-> Result r s
-> (state s -> Result r s)
-> (state s, Result r s, state s -> Result r s))
-> AnaParser state result s a -> AnaParser state result s b
pWrap f f' (AnaParser p z o) = AnaParser (libWrap f f' p)
(case z of
Nothing -> Nothing
Just (b, v) -> Just (b, case v of
Left w -> Right (libWrap f f' (libSucceed w))
Right pp -> Right (libWrap f f' pp)))
(mapOnePars (libWrap f f') id o)
-- =======================================================================================
-- ===== SYMBOLS and RANGES ==============================================================
-- =======================================================================================
data SymbolR s = Range s s | EmptyR deriving (Eq,Ord)
instance Symbol s => Show (SymbolR s) where
show EmptyR = "the empty range"
show (Range a b) = if a == b then show a else show a ++ ".." ++ show b
mk_range l r = if l > r then EmptyR else Range l r
symInRange (Range l r) = if l == r then (l==)
else (\ s -> not (s < l || r < s ))
symRS (Range l r)
= if l == r then (compare l)
else (\ s -> if s < l then GT
else if s > r then LT
else EQ)
range `except` elems
= foldr removeelem [range] elems
where removeelem elem ranges = [r | ran <- ranges, r <- ran `minus` elem]
EmptyR `minus` _ = []
ran@(Range l r) `minus` elem = if symInRange ran elem
then [mk_range l (symBefore elem), mk_range (symAfter elem) r]
else [ran]
-- =======================================================================================
-- ===== TRACING and ERRORS and MISC ===================================================
-- =======================================================================================
usererror m = error ("Your grammar contains a problem:\n" ++ m)
systemerror modname m
= error ("I apologise: I made a mistake in my design. This should not have happened.\n"
++
" Please report: " ++ modname ++": " ++ m ++ " to doaitse@cs.uu.nl\n")
-- =======================================================================================
-- ===== PERMUTATIONS ================================================================
-- =======================================================================================
newtype Perms p a = Perms (Maybe (p a), [Br p a])
data Br p a = forall b. Br (Perms p (b -> a)) (p b)
perms ~*~ p = perms `add` (getzerop p, getonep p)
f ~$~ p = Perms (Just (pLow f), []) ~*~ p
add b2a@(Perms (eb2a, nb2a)) bp@(eb, nb)
= let changing :: Sequence a => (b -> c) -> Perms a b -> Perms a c
f `changing` Perms (ep, np) = Perms (fmap (f <$>) ep, [Br ((f.) `changing` pp) p | Br pp p <- np])
in Perms
( do { f <- eb2a
; x <- eb
; return (f <*> x)
}
, (case nb of
Nothing -> id
Just pb -> (Br b2a pb:)
)[ Br ((flip `changing` c) `add` bp) d | Br c d <- nb2a]
)
pPerms (Perms (empty,nonempty))
= foldl (<|>) (fromMaybe pFail empty) [ (flip ($)) <$> p <*> pPerms pp
| Br pp p <- nonempty
]
pPermsSep sep perm = p2p (pSucceed ()) sep perm
p2p fsep sep (Perms (mbempty, nonempties)) = foldr (<|>) empty (map pars nonempties)
where empty = fromMaybe pFail mbempty
pars (Br t p) = flip ($) <$ fsep <*> p <*> p2p sep sep t
-- =======================================================================================
-- ===== CHECKING ========================================================================
-- =======================================================================================
acceptsepsilon p = case getzerop p of {Nothing -> False; _ -> True}
mnz p v
= if( acceptsepsilon p)
then usererror ("You are calling a list based derived combinator with a parser that accepts the empty string.\n"
++
"We cannot handle the resulting left recursive formulation (and it is ambiguous too).\n"++
(case getfirsts p of
ESeq [] -> "There are no other alternatives for this parser"
d -> "The other alternatives of this parser may start with:\n"++ show d
))
else v
-- =======================================================================================
-- ===== START OF ELUDE DEFINITIONS ========== =========================================
-- =======================================================================================
a <..> b = pRange a (Range a b)
(l,r,err) `pExcept` elems = let ranges = filter (/= EmptyR) (Range l r `except` elems)
in if null ranges then pFail
else foldr (<|>) pFail (map (pRange err) ranges)
p `opt` v = mnz p (p <|> pLow v) -- note that opt is greedy, if you do not want this
-- use "... <|> pSucceed v" instead
-- p should not recognise the empty string
-- =======================================================================================
-- ===== Special sequential compositions =========================================
-- =======================================================================================
asList exp = setfirsts (ESeq [EStr "(", exp, EStr " ...)*"])
asList1 exp = setfirsts (ESeq [EStr "(", exp, EStr " ...)+"])
asOpt exp = setfirsts (ESeq [EStr "( ", exp, EStr " ...)?"])
pa <+> pb = (,) <$> pa <*> pb
p <**> q = (\ x f -> f x) <$> p <*> q
f <$$> p = pSucceed (flip f) <*> p
p <??> q = p <**> (q `opt` id)
p <?> str = setfirsts (EStr str) p
pPacked l r x = l *> x <* r
-- =======================================================================================
-- ===== Iterating ps ===============================================================
-- =======================================================================================
pFoldr_ng alg@(op,e) p = mnz p (asList (getfirsts p) pfm)
where pfm = (op <$> p <*> pfm) <|> pSucceed e
pFoldr_gr alg@(op,e) p = mnz p (asList (getfirsts p) pfm)
where pfm = (op <$> p <*> pfm) `opt` e
pFoldr alg p = pFoldr_gr alg p
pFoldr1_gr alg@(op,e) p = asList1 (getfirsts p) (op <$> p <*> pFoldr_gr alg p)
pFoldr1_ng alg@(op,e) p = asList1 (getfirsts p) (op <$> p <*> pFoldr_ng alg p)
pFoldr1 alg p = pFoldr1_gr alg p
pFoldrSep_gr alg@(op,e) sep p = mnz p (asList (getfirsts p)((op <$> p <*> pFoldr_gr alg (sep *> p)) `opt` e ))
pFoldrSep_ng alg@(op,e) sep p = mnz p (asList (getfirsts p)((op <$> p <*> pFoldr_ng alg (sep *> p)) <|> pSucceed e))
pFoldrSep alg sep p = pFoldrSep_gr alg sep p
pFoldr1Sep_gr alg@(op,e) sep p = if acceptsepsilon sep then mnz p pfm else pfm
where pfm = op <$> p <*> pFoldr_gr alg (sep *> p)
pFoldr1Sep_ng alg@(op,e) sep p = if acceptsepsilon sep then mnz p pfm else pfm
where pfm = op <$> p <*> pFoldr_ng alg (sep *> p)
pFoldr1Sep alg sep p = pFoldr1Sep_gr alg sep p
list_alg = ((:), [])
pList_gr p = pFoldr_gr list_alg p
pList_ng p = pFoldr_ng list_alg p
pList p = pList_gr p
pList1_gr p = pFoldr1_gr list_alg p
pList1_ng p = pFoldr1_ng list_alg p
pList1 p = pList1_gr p
pListSep_gr s p = pFoldrSep_gr list_alg s p
pListSep_ng s p = pFoldrSep_ng list_alg s p
pListSep s p = pListSep_gr s p
pList1Sep_gr s p = pFoldr1Sep_gr list_alg s p
pList1Sep_ng s p = pFoldr1Sep_ng list_alg s p
pList1Sep s p = pList1Sep_gr s p
pChainr_gr op x = if acceptsepsilon op then mnz x r else r
where r = x <??> (flip <$> op <*> r)
pChainr_ng op x = if acceptsepsilon op then mnz x r else r
where r = x <**> ((flip <$> op <*> r) <|> pSucceed id)
pChainr op x = pChainr_gr op x
pChainl_gr op x = if acceptsepsilon op then mnz x r else r
where
r = (f <$> x <*> pList_gr (flip <$> op <*> x) )
f x [] = x
f x (func:rest) = f (func x) rest
pChainl_ng op x = if acceptsepsilon op then mnz x r else r
where
r = (f <$> x <*> pList_ng (flip <$> op <*> x) )
f x [] = x
f x (func:rest) = f (func x) rest
pChainl op x = pChainl_gr op x
pAny f l = if null l then usererror "pAny: argument may not be empty list" else foldr1 (<|>) (map f l)
pAnySym l = pAny pSym l -- used to be called pAnySym
-- ==== merging
-- e.g. chars_digs = cat3 `pMerged` (list_of pDig <||> list_of pL <||> list_of pU)
-- parsing "12abCD1aV" now returns "121abaCDV", so the sequence of
-- recognised elements is stored in three lists, which are then passed to cat3
(pe, pp, punp) <||> (qe, qp, qunp)
=( (pe, qe)
, (\f (pv, qv) -> (f pv, qv)) <$> pp
<|>
(\f (pv, qv) -> (pv, f qv)) <$> qp
, \f (x, y) -> qunp (punp f x) y
)
sem `pMerged` (units, alts, unp)
= let pres = alts <*> pres `opt` units
in unp sem <$> pres
usealg (op, e) p = (e, op <$> p, id)
list_of p = usealg list_alg p
pToks [] = pSucceed []
pToks (a:as) = (:) <$> pSym a <*> pToks as
pLocate list = pAny pToks list
-- =======================================================================================
-- ===== BINARY SEARCH TREES =============================================================
-- =======================================================================================
data BinSearchTree a b
= Node (BinSearchTree a b) (a, b) (BinSearchTree a b)
| Nil
tab2tree tab = tree
where
(tree,[]) = sl2bst (length tab) [ (symRS k, v) | (k, v) <- tab]
sl2bst 0 list = (Nil , list)
sl2bst n list
= let
ll = (n - 1) `div` 2 ; rl = n - 1 - ll
(lt,a:list1) = sl2bst ll list
(rt, list2) = sl2bst rl list1
in (Node lt a rt, list2)
-- remember we compare the key value with the lookup value
btLookup
= find_in
where find_in Nil = \i -> Nothing
find_in (Node Nil (k,v) Nil)
= (\i -> case k i of { LT -> Nothing
; EQ -> v
; GT -> Nothing
})
find_in (Node Nil (k,v) right)
= (\i -> case k i of { LT -> findright i
; EQ -> v
; GT -> Nothing
})
where findright = find_in right
find_in (Node left (k,v) Nil)
= (\i -> case k i of { LT -> Nothing
; EQ -> v
; GT -> findleft i
})
where findleft = find_in left
find_in (Node left (k,v) right)
= (\i -> case k i of { LT -> findright i
; EQ -> v
; GT -> findleft i
})
where findleft = find_in left
findright = find_in right
-- =======================================================================================
-- ===== NON-USED CODE === ============================================================
-- =======================================================================================
{-
data OC = RO | CL | LO
deriving (Eq,Ord, Show)
type Point s = (s,OC)
instance (Ord s, Show s) => Symbol (Point s) where
symBefore (v,CL) = (v,RO)
symBefore (v,LO) = (v,CL)
symBefore (v,RO) = systemerror "UU_Parsing_Library" ("before RO")
symAfter (v,CL) = (v,LO)
symAfter (v,RO) = (v,CL)
symAfter (v,LO) = systemerror "UU_Parsing_Library" ("after LO")
symInRange ran = (EQ==).symRS ran
symRS (Range (l,lb) (r,rb))
= if l == r && lb == CL && rb == CL then compare l
else \s -> case compare l s of
LT -> case compare r s of
EQ -> compare rb CL
LT -> LT
GT -> EQ
EQ -> compare lb CL
GT -> GT
instance (Symbol s) => Show (SymbolR (Point s)) where
show (Range (a, CL) (b,CL)) = if a==b then "["++show a++"]"
else "["++show a++ ".." ++ show b ++ "]"
show (Range (a, ab) (b, bb)) = (if ab == LO then "(" else "[")
++ show a ++ ".." ++ show b ++
(if ab == RO then ")" else "]")
show EmptyR = " [] "
-}
{-
-- ==========================================================================================
-- ===== ACCEPTING VALUES =================================================================
-- =======================================================================================
data Accept result a r s = Accept { this :: a -> r -> s
, next :: (forall b. Accept (b -> a) (result b r) s)
}
accept = Accept {this = acceptR , next =
Accept {this = \ b2a ( Pair b r) -> acceptR ( b2a b) r, next =
Accept {this = \ c2b2a ( Pair c (Pair b r)) -> acceptR ( c2b2a c b) r, next =
Accept {this = \ d2c2b2a (Pair d (Pair c (Pair b r))) -> acceptR (d2c2b2a d c b) r, next = mapfourargs accept
}}}}
--mapthreeargs :: Accept a r s -> Accept (d -> c -> b -> a) ((d,(c,(b, r)))) (s)
mapfourargs (Accept this next)
= Accept (fourargs this) (mapfourargs next)
fourargs f = \ e2d2c2b2a (Pair e (Pair d (Pair c (Pair b r)))) -> (f (e2d2c2b2a e d c b) r)
fourargs :: OutputState r => (a -> b -> c) -> (x -> d -> e -> f -> a) -> r x (r d (r e (r f b))) -> c
-- mapfourargs :: Accept a b c -> Accept (x -> d -> e -> f -> a) (x,(d,(e,(f,b)))) c
-- accept :: Accept a b (a,b)
-}