ghc/lib/hbc/Parse.hs

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