module GLL.Combinators.BinInterface (
Parser,
parse, parseString,
char, token, Token(..),
epsilon, satisfy,
many,some,optional,
(<::=>),(<:=>),
(<$>),
(<$),
(<*>),
(*>),
(<*),
(<|>),
) where
import Prelude hiding ((<*>), (<*), (<$>), (<$), (*>))
import GLL.Combinators.Options
import GLL.Types.Abstract
import GLL.Types.Grammar hiding (epsilon)
import GLL.Parser (gllSPPF,ParseResult(..))
import qualified Data.Array as A
import qualified Data.IntMap as IM
import qualified Data.Map as M
import qualified Data.Set as S
type Visit1 = Symbol
type Visit2 = M.Map Nt [Alt] -> M.Map Nt [Alt]
type Visit3 a = PCOptions -> A.Array Int Token -> ParseContext -> SPPF
-> Int -> Int -> Int -> S.Set a
type Parser a = (Visit1, Visit2, Visit3 a)
type ParseContext = IM.IntMap (IM.IntMap Nt)
parse' :: PCOptions -> Parser a -> [Token] -> (Grammar, ParseResult, [a])
parse' opts (Nt start,rules,sem) str =
let cfg = Grammar start [] [ Rule x alts
| (x, alts) <- M.assocs (rules M.empty) ]
parse_r = gllSPPF cfg str
sppf = sppf_result parse_r
as = sem opts arr IM.empty sppf 0 m m
m = length str
arr = A.array (0,m) (zip [0..] str)
in (cfg,parse_r,S.toList as)
grammar :: Parser a -> Grammar
grammar p = (\(f,_,_) -> f) (parse' defaultOptions p [])
parse :: Parser a -> [Token] -> [a]
parse = parseWithOptions defaultOptions
parseWithOptions :: PCOptions -> Parser a -> [Token] -> [a]
parseWithOptions opts p str = (\(_,_,t) -> t) (parse' opts p str)
sppf :: Parser a -> [Token] -> ParseResult
sppf p str = (\(_,s,_) -> s) (parse' defaultOptions p str)
parseString :: Parser a -> [Char] -> [a]
parseString p = parse p . charS
parseStringWithOptions :: PCOptions -> Parser a -> [Char] -> [a]
parseStringWithOptions opts p = parseWithOptions opts p . charS
infixl 3 <::=>
(<::=>) :: String -> Parser a -> Parser a
x <::=> _r = let (sym,_r_rules,_r_sem) = _r
alt = Alt x [sym]
rules m = case M.lookup x m of
Nothing -> _r_rules (M.insert x [alt] m)
Just _ -> m
sem opts arr ctx sppf l r m
| (l,r,x) `inContext` ctx = S.empty
| otherwise = let ctx' = (l,r,x) `toContext` ctx
in _r_sem opts arr ctx' sppf l r m
in (Nt x,rules,sem)
infixl 3 <:=>
(<:=>) :: String -> Parser a -> Parser a
x <:=> _r = let (sym,_r_rules,_r_sem) = _r
alt = Alt x [sym]
rules m = case M.lookup x m of
Nothing -> _r_rules (M.insert x [alt] m)
Just _ -> m
in (Nt x,rules,_r_sem)
infixl 5 <$>
(<$>) :: (Ord b, Ord a) => (a -> b) -> Parser a -> Parser b
f <$> _r = let (sym,rules,_r_sem) = _r
sem opts arr ctx sppf l r m = S.map f (_r_sem opts arr ctx sppf l r m)
in (sym,rules,sem)
infixl 6 <*>
(<*>) :: (Ord a, Ord b) => Parser a -> Parser b -> Parser (a,b)
_l <*> _r = (Nt lhs_id,rules,sem)
where l_id = id_ _l
r_id = id_ _r
lhs_id = concat [l_id, "*", r_id]
alt = Alt lhs_id [sym_ _l, sym_ _r]
rules m = case M.lookup lhs_id m of
Nothing -> rules_ _r (rules_ _l (M.insert lhs_id [alt] m))
Just _ -> m
sem opts arr ctx sppf l r m =
let filter = maybe id id $ pivot_select opts in S.fromList
[ (a,b) | k <- filter ks
, a <- S.toList (sem_ _l opts arr ctx sppf l k m)
, b <- S.toList (sem_ _r opts arr ctx sppf k r m) ]
where ks = maybe [] id $ sppf `pNodeLookup` ((alt,2), l, r)
infixl 4 <|>
(<|>) :: (Ord a) => Parser a -> Parser a -> Parser a
_l <|> _r = (Nt lhs_id,rules,sem)
where l_id = id_ _l
r_id = id_ _r
lhs_id = concat [l_id, "|", r_id]
alts = [Alt lhs_id [sym_ _l], Alt lhs_id [sym_ _r]]
rules m = case M.lookup lhs_id m of
Nothing -> rules_ _r (rules_ _l (M.insert lhs_id alts m))
Just _ -> m
sem opts arr ctx sppf l r m =
concatChoice opts (sem_ _l opts arr ctx sppf l r m)
(sem_ _r opts arr ctx sppf l r m)
infixl 6 <*
(<*) :: (Ord a, Ord b) => Parser a -> Parser b -> Parser a
_l <* _r = (\(x,y) -> x) <$> _l <*> _r
infixl 6 *>
(*>) :: (Ord a, Ord b) => Parser a -> Parser b -> Parser b
_l *> _r = (\(x,y) -> y) <$> _l <*> _r
infixl 5 <$
(<$) :: (Ord a, Ord b) => a -> Parser b -> Parser a
f <$ _r = const f <$> _r
raw_parser :: String -> Token -> (Token -> a) -> Parser a
raw_parser str t f = (Nt str, rules, sem)
where alt = Alt str [Term t]
rules = M.insert str [alt]
sem _ arr ctx sppf l r m
| l + 1 == r && l < m && arr A.! l == t = S.singleton (f t)
| otherwise = S.empty
char :: Char -> Parser Char
char c = raw_parser ([c]) (Char c) (\(Char c) -> c)
token :: Token -> Parser Token
token t = raw_parser (show t) t id
epsilon :: Parser ()
epsilon = (Nt x, rules, sem)
where x = "__eps"
alt = Alt x [Term Epsilon]
rules = M.insert x [alt]
sem _ arr ctx sppf l r m | l == r = S.singleton ()
| otherwise = S.empty
satisfy :: (Ord a) => a -> Parser a
satisfy a = a <$ epsilon
sym_ :: Parser a -> Symbol
sym_ (f,_,_) = f
id_ :: Parser a -> Nt
id_ (Nt x,_,_) = x
rules_ :: Parser a -> Visit2
rules_ (_,f,_) = f
sem_ :: Parser a -> Visit3 a
sem_ (_,_,f) = f
mkNt :: String -> Char -> Nt
mkNt x c = concat ["(",x,")",[c]]
inContext :: (Int, Int, Nt) -> ParseContext -> Bool
inContext (l,r,x) = maybe False inner . IM.lookup l
where inner = maybe False ((==) x) . IM.lookup r
toContext :: (Int, Int, Nt) -> ParseContext -> ParseContext
toContext (l,r,x) = IM.insertWith IM.union l (IM.singleton r x)
concatChoice :: (Ord a) => PCOptions -> S.Set a -> S.Set a -> S.Set a
concatChoice opts ls rs = if left_biased_choice opts
then firstRes
else ls `S.union` rs
where firstRes | S.null ls = rs
| otherwise = ls
optional :: (Ord a) => Parser a -> Parser (Maybe a)
optional p@(Nt x,_,_) = (mkNt x '?') <:=> satisfy Nothing <|> Just <$> p
many :: (Ord a) => Parser a -> Parser [a]
many p@(Nt x,_,_) = (mkNt x '^') <::=> satisfy []
<|> uncurry (:) <$> p <*> many p
some :: (Ord a) => Parser a -> Parser [a]
some p@(Nt x,_,_) = let rec = (mkNt x '+') <::=> (:[]) <$> p
<|> uncurry (:) <$> p <*> rec
in rec