ampersand-3.0.0: src/lib/DatabaseDesign/Ampersand/Input/ADL1/UU_Parsing.hs
{-# LANGUAGE RankNTypes, ExistentialQuantification, FunctionalDependencies, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
module DatabaseDesign.Ampersand.Input.ADL1.UU_Parsing
(parseIO,parse,getMsgs,evalSteps
, Steps(..),Pair(..)
,Symbol(..),pPacked
,Parser
,pList,pListSep,pList1,pList1Sep,pSym
,opt
,(<??>), (<**>), Sequence((<$>), (<$), (<*>), (<*), (*>), pSucceed )
,Alternative(..)
,IsParser
,Message(..))
-- (
-- 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 Data.Maybe
--import PrelGHC
--import IOExts
import System.IO.Unsafe
import DatabaseDesign.Ampersand.Basics
import Prelude hiding (writeFile,readFile,getContents,putStr,putStrLn)
fatal :: Int -> String -> a
fatal = fatalMsg "Input.ADL1.UU_Parsing"
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 :: (Symbol b, 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 :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a (c -> c -> c) -> a c -> a c
pChainl_ng :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a (c -> c -> c) -> a c -> a c
pChainl_gr :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a (c -> c -> c) -> a c -> a c
pChainr :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a (c -> c -> c) -> a c -> a c
pChainr_ng :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Alternative a, Sequence a) => a (c -> c -> c) -> a c -> a c
pChainr_gr :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a (c -> c -> c) -> a c -> a c
pList1Sep :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a c -> a d -> a [d]
pList1Sep_ng :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a c -> a d -> a [d]
pList1Sep_gr :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a c -> a d -> a [d]
pListSep :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a c -> a d -> a [d]
pListSep_ng :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Alternative a, Sequence a) => a c -> a d -> a [d]
pListSep_gr :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => a c -> a d -> a [d]
pList1 :: (Symbol b, SymParser a b, Sequence a, Show (Exp b), SplitParser a, Alternative a) => a c -> a [c]
pList1_ng :: (Symbol b, SymParser a b, Sequence a, Show (Exp b), SplitParser a, Alternative a) => a c -> a [c]
pList1_gr :: (Symbol b, SymParser a b, Sequence a, Show (Exp b), SplitParser a, Alternative a) => a c -> a [c]
pList :: (Symbol b, SymParser a b, Show (Exp b), SplitParser a, Sequence a, Alternative a) => a c -> a [c]
pList_ng :: (Symbol b, SymParser a b, Show (Exp b), SplitParser a, Sequence a, Alternative a) => a c -> a [c]
pList_gr :: (Symbol b, SymParser a b, Show (Exp b), SplitParser a, Sequence a, Alternative a) => a c -> a [c]
list_alg :: (a -> [a] -> [a],[b])
pFoldr1Sep :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => (c -> d -> d,d) -> a e -> a c -> a d
pFoldr1Sep_ng :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => (c -> d -> d,d) -> a e -> a c -> a d
pFoldr1Sep_gr :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => (c -> d -> d,d) -> a e -> a c -> a d
pFoldrSep :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => (c -> d -> d,d) -> a e -> a c -> a d
pFoldrSep_ng :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Alternative a, Sequence a) => (c -> d -> d,d) -> a e -> a c -> a d
pFoldrSep_gr :: (Symbol b, SplitParser a, SymParser a b, Show (Exp b), Sequence a, Alternative a) => (c -> d -> d,d) -> a e -> a c -> a d
pFoldr1 :: (Symbol b, SymParser a b, Sequence a, Show (Exp b), SplitParser a, Alternative a) => (c -> d -> d,d) -> a c -> a d
pFoldr1_ng :: (Symbol b, SymParser a b, Sequence a, Show (Exp b), SplitParser a, Alternative a) => (c -> d -> d,d) -> a c -> a d
pFoldr1_gr :: (Symbol b, SymParser a b, Sequence a, Show (Exp b), SplitParser a, Alternative a) => (c -> d -> d,d) -> a c -> a d
pFoldr :: (Symbol b, SymParser a b, Show (Exp b), SplitParser a, Sequence a, Alternative a) => (c -> d -> d,d) -> a c -> a d
pFoldr_gr :: (Symbol b, SymParser a b, Show (Exp b), SplitParser a, Sequence a, Alternative a) => (c -> d -> d,d) -> a c -> a d
pFoldr_ng :: (Symbol b, 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 -> String -> a c
(<??>) :: (Symbol b, 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 :: (Symbol b, 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 :: (Symbol b, 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 :: String -> String -> a
usererror :: String -> 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 a, 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 :: String
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, _))
= rp Pair handleEof
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)
= parsebasic (pars pp)
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)
infixl 2 <?>
infixl 3 <|>
infixl 4 <*>, <$> , <+>
infixl 4 ~*~, ~$~
infixl 4 <$, <*, *>, <**>, <??>
infixl 2 `opt`
infixl 5 <..>
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
{-# INLINE splitStateE #-}
{-# INLINE splitState #-}
instance OutputState Pair where
acceptR = Pair
nextR acc f ~(Pair a r) = acc (f a) r
dollarR acc f v = acc (f v)
{-# INLINE acceptR #-}
{-# INLINE nextR #-}
{-# INLINE dollarR #-}
instance (Symbol s, InputState state s, OutputState result) => Sequence (AnaParser state result s) where
(<*>) = anaSeq libDollar libSeq ($)
(<* ) = anaSeq libDollarL libSeqL const
( *>) = anaSeq libDollarR libSeqR (flip const)
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 = anaDynE
pDynL = anaDynL
pDynN = anaDynN
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
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'
class (Ord s, Show s) => Symbol s where
deleteCost :: s -> Int{-I-}
symBefore :: s -> s
symAfter :: s -> s
deleteCost b = 5{-I-}
symBefore = fatal 398 "You should have made your token type an instance of the Class Symbol. eg by defining symBefore = pred"
symAfter = fatal 399 "You should have made your token type an instance of the Class Symbol. eg by defining symAfter = succ"
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
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 (accf . k))
, 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"))
)
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 (fatal 519 (show msg)) -- was: do putStr (show msg) -- b.joosten
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
deriving Eq
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))
= "\n" ++ position ++
"\nExpecting " ++ show expecting ++
"\nTry " ++ action ++ "\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) = concatMap show seq
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
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)
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, k `notElem` 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 })
mapOnePars fp fl ~(OneDescr l fi t) = OneDescr (fl l) fi [ (k, TableEntry (fp p) (fp.corr))
| (k, TableEntry p corr ) <- t
]
mkParser zd ~descr@(OneDescr _ firsts tab) -- pattern matching should be lazy for lazy computation of length for empty parsers
= let parstab = if null tab then fatal 726 "parstab undefined" else
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 = if null tab then fatal 739 "insertsyms undefined" else
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
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)
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
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)
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]
usererror m = fatal 917 $ "Your grammar contains a problem:\n" ++ m
systemerror modname m
= fatal 919 $ "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"
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 = p2p (pSucceed ())
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
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
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
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
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 = pFoldr_gr
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 = pFoldr1_gr
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 = pFoldrSep_gr
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 = pFoldr1Sep_gr
list_alg = ((:), [])
pList_gr = pFoldr_gr list_alg
pList_ng = pFoldr_ng list_alg
pList = pList_gr
pList1_gr = pFoldr1_gr list_alg
pList1_ng = pFoldr1_ng list_alg
pList1 = pList1_gr
pListSep_gr = pFoldrSep_gr list_alg
pListSep_ng = pFoldrSep_ng list_alg
pListSep = pListSep_gr
pList1Sep_gr = pFoldr1Sep_gr list_alg
pList1Sep_ng = pFoldr1Sep_ng list_alg
pList1Sep = pList1Sep_gr
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 = pChainr_gr
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 = pChainl_gr
pAny f l = if null l then usererror "pAny: argument may not be empty list" else foldr1 (<|>) (map f l)
pAnySym = pAny pSym -- used to be called pAnySym
(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 = usealg list_alg
pToks [] = pSucceed []
pToks (a:as) = (:) <$> pSym a <*> pToks as
pLocate = pAny pToks
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)
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