module Data.LLVM.BitCode.Match where

import Data.LLVM.BitCode.Bitstream
import Data.LLVM.BitCode.Parse

import Control.Monad (MonadPlus(..),guard)


-- Matching Predicates ---------------------------------------------------------

type Match i a = i -> Maybe a

-- | Run a match in the context of the parsing monad.
match :: Match i a -> i -> Parse a
match :: forall i a. Match i a -> i -> Parse a
match Match i a
p i
i =
  case Match i a
p i
i of
    Just a
a  -> a -> Parse a
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
    Maybe a
Nothing -> String -> Parse a
forall a. String -> Parse a
failWithContext String
"match failed"

-- | The match that always succeeds.
keep :: Match i i
keep :: forall i. Match i i
keep  = i -> Maybe i
forall i. Match i i
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | The match that always fails.
skip :: Match i a
skip :: forall i a. Match i a
skip i
_ = Maybe a
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

infixr 8 |||

-- | Try to apply one match, and fall back on the other if it fails.
(|||) :: Match a b -> Match a b -> Match a b
||| :: forall a b. Match a b -> Match a b -> Match a b
(|||) Match a b
l Match a b
r a
a = Match a b
l a
a Maybe b -> Maybe b -> Maybe b
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Match a b
r a
a

-- | Attempt to apply a match.  This always succeeds, but the result of the
-- match will be a @Maybe@.
tryMatch :: Match a b -> Match a (Maybe b)
tryMatch :: forall a b. Match a b -> Match a (Maybe b)
tryMatch Match a b
m = (b -> Maybe b) -> Maybe b -> Maybe (Maybe b)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Maybe b
forall i. Match i i
Just (Maybe b -> Maybe (Maybe b)) -> Match a b -> a -> Maybe (Maybe b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Match a b
m (a -> Maybe (Maybe b))
-> (a -> Maybe (Maybe b)) -> a -> Maybe (Maybe b)
forall a b. Match a b -> Match a b -> Match a b
||| Maybe (Maybe b) -> a -> Maybe (Maybe b)
forall a b. a -> b -> a
const (Maybe b -> Maybe (Maybe b)
forall i. Match i i
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
forall a. Maybe a
Nothing)

-- | Require that a list has only one element.
oneChild :: Match [a] a
oneChild :: forall a. Match [a] a
oneChild [a
a] = Match a a
forall i. Match i i
keep a
a
oneChild [a]
_   = Maybe a
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

findMatch :: Match a b -> Match [a] (Maybe b)
findMatch :: forall a b. Match a b -> Match [a] (Maybe b)
findMatch Match a b
p (a
a:[a]
as) = (b -> Maybe b
forall i. Match i i
Just (b -> Maybe b) -> Maybe b -> Maybe (Maybe b)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Match a b
p a
a) Maybe (Maybe b) -> Maybe (Maybe b) -> Maybe (Maybe b)
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Match a b -> Match [a] (Maybe b)
forall a b. Match a b -> Match [a] (Maybe b)
findMatch Match a b
p [a]
as
findMatch Match a b
_ []     = Maybe b -> Maybe (Maybe b)
forall i. Match i i
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
forall a. Maybe a
Nothing

-- | Get the nth element of a list.
index :: Int -> Match [a] a
index :: forall a. RecordId -> Match [a] a
index RecordId
n [a]
as = do
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (RecordId
n RecordId -> RecordId -> Bool
forall a. Ord a => a -> a -> Bool
>= RecordId
0 Bool -> Bool -> Bool
&& RecordId
n RecordId -> RecordId -> Bool
forall a. Ord a => a -> a -> Bool
< [a] -> RecordId
forall a. [a] -> RecordId
forall (t :: * -> *) a. Foldable t => t a -> RecordId
length [a]
as)
  a -> Maybe a
forall i. Match i i
forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
as [a] -> RecordId -> a
forall a. HasCallStack => [a] -> RecordId -> a
!! RecordId
n)

-- | Drop elements of a list until a predicate matches.
dropUntil :: Match a b -> Match [a] (b,[a])
dropUntil :: forall a b. Match a b -> Match [a] (b, [a])
dropUntil Match a b
p (a
a:[a]
as) = Maybe (b, [a])
success Maybe (b, [a]) -> Maybe (b, [a]) -> Maybe (b, [a])
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Match a b -> Match [a] (b, [a])
forall a b. Match a b -> Match [a] (b, [a])
dropUntil Match a b
p [a]
as
  where
  success :: Maybe (b, [a])
success = do
    b
b <- Match a b
p a
a
    (b, [a]) -> Maybe (b, [a])
forall i. Match i i
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b,[a]
as)
dropUntil Match a b
_ []     = Maybe (b, [a])
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

-- | Require that an @Entry@ be a @Block@.
block :: Match Entry Block
block :: Match Entry Block
block (EntryBlock Block
b) = Match Block Block
forall i. Match i i
keep Block
b
block Entry
_              = Maybe Block
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

-- | Require that an @Entry@ be an @UnabbrevRecord@.
unabbrev :: Match Entry UnabbrevRecord
unabbrev :: Match Entry UnabbrevRecord
unabbrev (EntryUnabbrevRecord UnabbrevRecord
r) = Match UnabbrevRecord UnabbrevRecord
forall i. Match i i
keep UnabbrevRecord
r
unabbrev Entry
_                       = Maybe UnabbrevRecord
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

-- | Require that an @Entry@ be an @AbbrevRecord@
abbrev :: Match Entry AbbrevRecord
abbrev :: Match Entry AbbrevRecord
abbrev (EntryAbbrevRecord AbbrevRecord
r) = Match AbbrevRecord AbbrevRecord
forall i. Match i i
keep AbbrevRecord
r
abbrev Entry
_                     = Maybe AbbrevRecord
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

-- | Require than an @Entry@ be a @DefineAbbrev@.
abbrevDef :: Match Entry DefineAbbrev
abbrevDef :: Match Entry DefineAbbrev
abbrevDef (EntryDefineAbbrev DefineAbbrev
d) = Match DefineAbbrev DefineAbbrev
forall i. Match i i
keep DefineAbbrev
d
abbrevDef Entry
_                     = Maybe DefineAbbrev
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

-- | Require that the block has the provided block id.
hasBlockId :: BlockId -> Match Block Block
hasBlockId :: BlockId -> Match Block Block
hasBlockId BlockId
bid Block
b | Block -> BlockId
blockId Block
b BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId
bid = Match Block Block
forall i. Match i i
keep Block
b
                 | Bool
otherwise        = Maybe Block
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

-- | Require that the unabbreviated record has the provided record id.
hasUnabbrevCode :: RecordId -> Match UnabbrevRecord UnabbrevRecord
hasUnabbrevCode :: RecordId -> Match UnabbrevRecord UnabbrevRecord
hasUnabbrevCode RecordId
rid UnabbrevRecord
r | UnabbrevRecord -> RecordId
unabbrevCode UnabbrevRecord
r RecordId -> RecordId -> Bool
forall a. Eq a => a -> a -> Bool
== RecordId
rid = Match UnabbrevRecord UnabbrevRecord
forall i. Match i i
keep UnabbrevRecord
r
                      | Bool
otherwise             = Maybe UnabbrevRecord
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero