1 -- this is adapted from ghc/syslib-hbc
    2 
    3 
    4 module Parse(
    5         Parser, (+.+), (..+), (+..), (|||), (>>>), (||!), (|!!), (.>),
    6         into, lit, litp, many, many1, succeed, sepBy, count, sepBy1, testp, token, recover,
    7         ParseResult, parse, sParse, simpleParse,
    8         act, failP
    9         ) where
   10 
   11 
   12 
   13 
   14 
   15 infixr 8 +.+ , ..+ , +..
   16 infix  6 `act` , >>>, `into` , .>
   17 infixr 4 ||| , ||! , |!!
   18 
   19 type ErrMsg = String
   20 
   21 {-
   22 data FailAt a
   23         = FailAt !Int [ErrMsg] a                  -- token pos, list of acceptable tokens, rest of tokens
   24         deriving (Show)
   25 data ParseResult a b
   26         = Many [(b, Int, a)] (FailAt a)                          -- parse succeeded with many (>1) parses)
   27         | One b !Int a !(FailAt a)     -- parse succeeded with one parse
   28         | None !Bool !(FailAt a)             -- parse failed. The Bool indicates hard fail
   29         deriving (Show)
   30 -}
   31 
   32 data FailAt a
   33         = FailAt Int [ErrMsg] a                     -- token pos, list of acceptable tokens, rest of tokens
   34         deriving (Show)
   35 data ParseResult a b
   36         = Many [(b, Int, a)] (FailAt a)                          -- parse succeeded with many (>1) parses)
   37         | One b Int a (FailAt a)       -- parse succeeded with one parse
   38         | None Bool (FailAt a)         -- parse failed. The Bool indicates hard fail
   39         deriving (Show)
   40 
   41 
   42 type Parser a b = a -> Int -> ParseResult a b
   43 
   44 noFail = FailAt (-1) [] (error "noFail")               -- indicates no failure yet
   45 
   46 updFail f (None w f')     = None w (bestFailAt f f') 
   47 updFail f (One c n as f') = One c n as (bestFailAt f f')
   48 updFail f (Many cas f')   = let r = bestFailAt f f' in seq r (Many cas r)
   49 
   50 bestFailAt f@(FailAt i a t) f'@(FailAt j a' _) =
   51         if i > j then 
   52             f 
   53         else if j > i then 
   54             f' 
   55         else if i == -1 then 
   56             noFail --FailAt (-1) [] [] 
   57         else 
   58             FailAt i (a ++ a') t
   59 
   60 -- Alternative
   61 (|||) :: Parser a b -> Parser a b -> Parser a b
   62 p ||| q = \as n ->
   63     case (p as n, q as n) of
   64         (pr@(None True  _), _                ) -> pr
   65         (pr@(None _     f), qr               ) -> updFail f qr
   66         (    One b k as f , qr               ) -> Many ((b,k,as) : l') (bestFailAt f f') where (l',f') = lf qr
   67         (    Many  l f    , qr               ) -> Many (        l++l') (bestFailAt f f') where (l',f') = lf qr
   68     where lf (Many l f)     = (l,          f)
   69           lf (One b k as f) = ([(b,k,as)], f)
   70           lf (None _   f)   = ([],         f)
   71 
   72 -- Alternative, but with committed choice
   73 (||!) :: Parser a b -> Parser a b -> Parser a b 
   74 p ||! q = \as n -> 
   75     case (p as n, q as n) of
   76         (pr@(None True  _), _                ) -> pr
   77         (    None _     f , qr               ) -> updFail f qr
   78         (pr               , _                ) -> pr
   79 
   80 process f [] [] = seq f (None False f)
   81 process f [(b,k,as)]  [] = seq f (One b k as f)
   82 process f rs [] = seq f (Many rs f)
   83 process f rs (w@(None True _):_) = seq f w
   84 process f rs (None False f':rws) = process (bestFailAt f f') rs rws
   85 process f rs (One b k as f':rws) = process (bestFailAt f f') (rs++[(b,k,as)]) rws
   86 process f rs (Many rs' f'  :rws) = process (bestFailAt f f') (rs++rs') rws
   87 
   88 doMany g cas f = Many [ (g c, n, as) | (c,n,as) <- cas] f
   89 
   90 -- Sequence
   91 (+.+) :: Parser a b -> Parser a c -> Parser a (b,c)
   92 p +.+ q = 
   93     \as n-> 
   94     case p as n of
   95         None w f -> None w f
   96         One b n' as' f ->
   97             case q as' n' of
   98                 None w f'         -> None w (bestFailAt f f') 
   99                 One c n'' as'' f' -> One (b,c) n'' as'' (bestFailAt f f')
  100                 Many cas f'       -> doMany (\x->(b,x)) cas (bestFailAt f f')
  101         Many bas f ->
  102             let rss = [ case q as' n' of { None w f -> None w f;
  103                                            One c n'' as'' f' -> One (b,c) n'' as'' f';
  104                                            Many cas f' -> doMany (\x->(b,x)) cas f'  }
  105                         | (b,n',as') <- bas ]
  106             in  process f [] rss
  107 
  108 -- Sequence, throw away first part
  109 (..+) :: Parser a b -> Parser a c -> Parser a c
  110 p ..+ q = -- p +.+ q `act` snd
  111     \as n-> 
  112     case p as n of
  113         None w f       -> None w f
  114         One _ n' as' f -> updFail f (q as' n')
  115         Many bas f     -> process f [] [ q as' n' | (_,n',as') <- bas ]
  116 
  117 -- Sequence, throw away second part
  118 (+..) :: Parser a b -> Parser a c -> Parser a b
  119 p +.. q = -- p +.+ q `act` fst
  120     \as n-> 
  121     case p as n of
  122         None w f -> None w f
  123         One b n' as' f ->
  124             case q as' n' of
  125                 None w f'         -> None w (bestFailAt f f')
  126                 One _ n'' as'' f' -> One b n'' as'' (bestFailAt f f')
  127                 Many cas f'       -> doMany (const b) cas (bestFailAt f f')
  128         Many bas f ->
  129             let rss = [ case q as' n' of { None w f -> None w f; 
  130                                            One _ n'' as'' f' -> One b n'' as'' f';
  131                                            Many cas f' -> doMany (const b) cas f' }
  132                         | (b,n',as') <- bas ]
  133             in  process f [] rss
  134 
  135 -- Return a fixed value
  136 (.>) :: Parser a b -> c -> Parser a c
  137 p .> v =
  138     \as n-> 
  139     case p as n of
  140       None w f        -> None w f
  141       One _ n' as' f' -> One v n' as' f'
  142       Many bas f      -> doMany (const v) bas f
  143 
  144 -- Action
  145 act :: Parser a b -> (b->c) -> Parser a c
  146 p `act` f = \as n-> 
  147     case p as n of
  148         None w f       -> None w f
  149         One b n as' ff -> One (f b) n as' ff
  150         Many bas ff    -> doMany f bas ff
  151 
  152 -- Action on two items
  153 (>>>) :: Parser a (b,c) -> (b->c->d) -> Parser a d
  154 p >>> f = \as n-> 
  155     case p as n of
  156         None w ff          -> None w ff
  157         One (b,c) n as' ff -> One (f b c) n as' ff
  158         Many bas ff        -> doMany (\ (x,y)->f x y) bas ff
  159 
  160 -- Use value
  161 into :: Parser a b -> (b -> Parser a c) -> Parser a c
  162 p `into` fq = \as n -> 
  163     case p as n of
  164         None w f       -> None w f
  165         One b n' as' f -> updFail f (fq b as' n')
  166         Many bas f     -> process f [] [ fq b as' n' | (b,n',as') <- bas ]
  167 
  168 -- Succeeds with a value
  169 succeed :: b -> Parser a b
  170 succeed v = \as n -> One v n as noFail
  171 
  172 -- Always fails.
  173 failP :: ErrMsg -> Parser a b
  174 failP s = \as n -> None False (FailAt n [s] as)
  175 
  176 -- Fail completely if parsing proceeds a bit and then fails
  177 mustAll :: Parser a b -> Parser a b
  178 mustAll p = \as n->
  179         case p as n of
  180         None False f@(FailAt x _ _) | x/=n -> None True f
  181         r -> r 
  182 
  183 -- If first alternative gives partial parse it's a failure
  184 p |!! q = mustAll p ||! q
  185 
  186 -- Kleene star
  187 many :: Parser a b -> Parser a [b]
  188 many p = p `into` (\v-> many p `act` (v:))
  189      ||! succeed []
  190 
  191 many1 :: Parser a b -> Parser a [b]
  192 many1 p = p `into` (\v-> many p `act` (v:))
  193 
  194 -- Parse an exact number of items
  195 count :: Parser a b -> Int -> Parser a [b]
  196 count p 0 = succeed []
  197 count p k = p +.+ count p (k-1) >>> (:)
  198 
  199 -- Non-empty sequence of items separated by something
  200 sepBy1 :: Parser a b -> Parser a c -> Parser a [b]
  201 p `sepBy1` q = p `into` (\v-> many (q ..+ p) `act` (v:))        -- p +.+ many (q ..+ p) >>> (:)    is slower
  202 
  203 -- Sequence of items separated by something
  204 sepBy :: Parser a b -> Parser a c -> Parser a [b]
  205 p `sepBy` q = p `sepBy1` q
  206           ||! succeed []
  207 
  208 -- Recognize a literal token
  209 lit :: (Eq a, Show a) => a -> Parser [a] a
  210 lit x = \as n ->
  211         case as of
  212         a:as' | a==x -> One a (n+1) as' noFail
  213         _ -> None False (FailAt n [show x] as)
  214 
  215 -- Recognize a token with a predicate
  216 litp :: ErrMsg -> (a->Bool) -> Parser [a] a
  217 litp s p = \as n->
  218         case as of
  219         a:as' | p a -> One a (n+1) as' noFail
  220         _ -> None False (FailAt n [s] as)
  221 
  222 -- Generic token recognizer
  223 token :: (a -> Either ErrMsg (b,a)) -> Parser a b
  224 token f = \as n->
  225         case f as of
  226             Left s -> None False (FailAt n [s] as)
  227             Right (b, as') -> One b (n+1) as' noFail
  228 
  229 -- Test a semantic value
  230 testp :: String -> (b->Bool) -> Parser a b -> Parser a b
  231 testp s tst p = \ as n ->
  232     case p as n of
  233       None w f -> None w f
  234       o@(One b _ _ _) -> if tst b then o else None False (FailAt n [s] as)
  235       Many bas f ->
  236         case [ r | r@(b, _, _) <- bas, tst b] of
  237             [] -> None False (FailAt n [s] as)
  238             [(x,y,z)] -> One x y z f
  239             rs -> Many rs f
  240 
  241 -- Try error recovery.
  242 recover :: Parser a b -> ([ErrMsg] -> a -> Maybe (a, b)) -> Parser a b
  243 recover p f = \ as n ->
  244         case p as n of
  245             r@(None _ fa@(FailAt n ss ts)) ->
  246                 case f ss ts of
  247                     Nothing -> r
  248                     Just (a, b) -> One b (n+1) a fa
  249             r -> r
  250 
  251 -- Parse, and check if it was ok.
  252 parse :: Parser a b -> a -> Either ([ErrMsg],a) [(b, a)]
  253 parse p as =
  254         case p as 0 of
  255             None w (FailAt _ ss ts) -> Left (ss,ts)
  256             One b _ ts _            -> Right [(b,ts)]
  257             Many bas _              -> Right [(b,ts) | (b,_,ts) <- bas ]
  258 
  259 sParse :: (Show a) => Parser [a] b -> [a] -> Either String b
  260 sParse p as =
  261         case parse p as of
  262             Left (ss,ts)     -> Left ("Parse failed at token "++pshow ts++", expected "++unwords ss++"\n")
  263                                   where pshow [] = "<EOF>"
  264                                         pshow (t:_) = show t
  265             Right ((b,[]):_)  -> Right b
  266             Right ((_,t:_):_) -> Left ("Parse failed at token "++show t++", expected <EOF>\n")
  267 
  268 simpleParse :: (Show a) => Parser [a] b -> [a] -> b
  269 simpleParse p as =
  270         case sParse p as of
  271         Left msg -> error msg
  272         Right x -> x