module Data.LLVM.BitCode.Match where
import Data.LLVM.BitCode.Bitstream
import Data.LLVM.BitCode.Parse
import Control.Monad (MonadPlus(..),guard)
type Match i a = i -> Maybe a
match :: Match i a -> i -> Parse a
match p i =
case p i of
Just a -> return a
Nothing -> failWithContext "match failed"
keep :: Match i i
keep = return
skip :: Match i a
skip _ = mzero
infixr 8 |||
(|||) :: Match a b -> Match a b -> Match a b
(|||) l r a = l a `mplus` r a
tryMatch :: Match a b -> Match a (Maybe b)
tryMatch m = fmap Just . m ||| const (return Nothing)
oneChild :: Match [a] a
oneChild [a] = keep a
oneChild _ = mzero
findMatch :: Match a b -> Match [a] (Maybe b)
findMatch p (a:as) = (Just `fmap` p a) `mplus` findMatch p as
findMatch _ [] = return Nothing
index :: Int -> Match [a] a
index n as = do
guard (n >= 0 && n < length as)
return (as !! n)
dropUntil :: Match a b -> Match [a] (b,[a])
dropUntil p (a:as) = success `mplus` dropUntil p as
where
success = do
b <- p a
return (b,as)
dropUntil _ [] = mzero
block :: Match Entry Block
block (EntryBlock b) = keep b
block _ = mzero
unabbrev :: Match Entry UnabbrevRecord
unabbrev (EntryUnabbrevRecord r) = keep r
unabbrev _ = mzero
abbrev :: Match Entry AbbrevRecord
abbrev (EntryAbbrevRecord r) = keep r
abbrev _ = mzero
abbrevDef :: Match Entry DefineAbbrev
abbrevDef (EntryDefineAbbrev d) = keep d
abbrevDef _ = mzero
hasBlockId :: BlockId -> Match Block Block
hasBlockId bid b | blockId b == bid = keep b
| otherwise = mzero
hasUnabbrevCode :: RecordId -> Match UnabbrevRecord UnabbrevRecord
hasUnabbrevCode rid r | unabbrevCode r == rid = keep r
| otherwise = mzero