module Data.ParserCombinators.Kangaroo.ParseMonad
(
GenKangaroo
, ParseErr
, RegionCoda(..)
, RegionName
, getUserSt
, putUserSt
, modifyUserSt
, throwErr
, liftIOAction
, withSuccess
, runGenKangaroo
, reportError
, substError
, word8
, checkWord8
, opt
, position
, region
, atEnd
, lengthRemaining
, regionSize
, intraparse
, advance
, advanceRelative
, restrict
, restrictToPos
, printHexAll
, printRegionStack
) where
import Data.ParserCombinators.Kangaroo.Debug
import Data.ParserCombinators.Kangaroo.Region
import Data.ParserCombinators.Kangaroo.Utils
import Control.Applicative
import Control.Monad
import Data.Array.IO
import Data.Word
import Numeric
import System.IO
type ParseErr = String
type ImageData = IOUArray Int Word8
type St = ParseStack
type Env = ImageData
newtype GenKangaroo ust a = GenKangaroo {
getGenKangaroo :: Env -> St -> ust -> IO (Either ParseErr a, St, ust) }
fmapKang :: (a -> b) -> GenKangaroo ust a -> GenKangaroo ust b
fmapKang f (GenKangaroo x) = GenKangaroo $ \env st ust ->
x env st ust `bindIO` \(a,st',ust') -> return (fmap f a, st', ust')
instance Functor (GenKangaroo ust) where
fmap = fmapKang
returnIO :: a -> IO a
returnIO = return
infixl 1 `bindIO`
bindIO :: IO a -> (a -> IO b) -> IO b
bindIO = (>>=)
returnKang :: a -> GenKangaroo st a
returnKang a = GenKangaroo $ \_ st ust -> returnIO (Right a, st, ust)
infixl 1 `bindKang`
bindKang :: GenKangaroo ust a -> (a -> GenKangaroo ust b) -> GenKangaroo ust b
(GenKangaroo x) `bindKang` f = GenKangaroo $ \env st ust ->
x env st ust `bindIO` \(ans, st', ust') ->
case ans of Left err -> returnIO (Left err,st',ust')
Right a -> getGenKangaroo (f a) env st' ust'
instance Monad (GenKangaroo ust) where
return = returnKang
(>>=) = bindKang
instance Applicative (GenKangaroo ust) where
pure = return
(<*>) = ap
runGenKangaroo :: GenKangaroo ust a -> ust -> FilePath -> IO (Either ParseErr a,ust)
runGenKangaroo p user_state filename =
withBinaryFile filename ReadMode $ \ handle ->
do { sz <- hFileSize handle
; arr <- newArray_ (0,fromIntegral $ sz1)
; rsz <- hGetArray handle arr (fromIntegral sz)
; (ans,stk,ust) <- runP p rsz arr
; return (answer ans stk,ust)
}
where
runP (GenKangaroo x) upper arr = x arr st0 user_state
where
st0 = newStack 0 (upper1) Alfine " -- file -- "
answer (Left err) stk = Left $ err
++ ('\n':'\n':printParseStack stk)
answer (Right ans) _ = Right ans
throwErr :: ParseErr -> GenKangaroo ust a
throwErr msg = GenKangaroo $ \_ st ust -> return (Left msg, st, ust)
askEnv :: GenKangaroo ust Env
askEnv = GenKangaroo $ \env st ust -> return (Right env, st, ust)
getSt :: GenKangaroo ust St
getSt = GenKangaroo $ \_ st ust -> return (Right st, st, ust)
putSt :: St -> GenKangaroo ust ()
putSt st = GenKangaroo $ \_ _ ust -> return (Right (), st, ust)
getPos :: GenKangaroo ust Pos
getPos = liftM location getSt
getEnd :: GenKangaroo ust RegionEnd
getEnd = liftM regionEnd getSt
getStart :: GenKangaroo ust RegionStart
getStart = liftM regionStart getSt
getUserSt :: GenKangaroo ust ust
getUserSt = GenKangaroo $ \_ st ust -> return (Right ust, st, ust)
putUserSt :: ust -> GenKangaroo ust ()
putUserSt ust = GenKangaroo $ \_ st _ -> return (Right (), st, ust)
modifyUserSt :: (ust -> ust) -> GenKangaroo ust ()
modifyUserSt f = GenKangaroo $ \_ st ust -> return (Right (), st, f ust)
advancePos1 :: GenKangaroo ust ()
advancePos1 = modifyPos (+1)
modifyPos :: (Pos -> Pos) -> GenKangaroo ust ()
modifyPos f = GenKangaroo $ \_ st ust -> return (Right (), move f st, ust)
bracketRegion :: RegionInfo -> GenKangaroo ust a -> GenKangaroo ust a
bracketRegion i = bracketM_ pushM popM
where
pushM = getSt >>= \st -> case push i st of
Left err -> throwErr $ getRegionError err
Right stk -> putSt stk
popM = getSt >>= \st -> putSt (pop st)
liftIOAction :: IO a -> GenKangaroo ust a
liftIOAction ma = GenKangaroo $ \_ st ust ->
ma >>= \a -> return (Right a, st, ust)
reportError :: ParseErr -> GenKangaroo ust a
reportError s = do
posn <- getPos
throwErr $ s ++ posStr posn
where
posStr pos = concat [ " absolute position "
, show pos
, " (0x"
, showHex pos []
, ")"
]
substError :: GenKangaroo ust a -> ParseErr -> GenKangaroo ust a
substError p msg = GenKangaroo $ \env st ust ->
(getGenKangaroo p) env st ust >>= \ ans ->
case ans of
(Left _, st', ust') -> return (Left msg, st', ust')
okay -> return okay
withSuccess :: Bool -> ParseErr -> GenKangaroo ust a -> GenKangaroo ust a
withSuccess False msg _ = throwErr msg
withSuccess True _ mf = mf
word8 :: GenKangaroo ust Word8
word8 = do
ix <- getPos
end <- getEnd
when (ix>end) (reportError "word8")
arr <- askEnv
a <- liftIOAction $ readArray arr ix
advancePos1
return a
checkWord8 :: (Word8 -> Bool) -> GenKangaroo ust (Maybe Word8)
checkWord8 check = word8 >>= \ans ->
if check ans then return $ Just ans
else modifyPos (`subtract` 1) >> return Nothing
opt :: GenKangaroo ust a -> GenKangaroo ust (Maybe a)
opt p = GenKangaroo $ \env st ust -> (getGenKangaroo p) env st ust >>= \ ans ->
case ans of
(Left _, _, ust') -> return (Right Nothing, st, ust')
(Right a, st', ust') -> return (Right $ Just a, st', ust')
position :: GenKangaroo ust Int
position = getPos
region :: GenKangaroo ust (Int,Int,Int)
region = liftM3 (,,) getStart getPos getEnd
atEnd :: GenKangaroo ust Bool
atEnd = liftM2 (>) getPos getEnd
lengthRemaining :: GenKangaroo ust Int
lengthRemaining = liftM2 fn getEnd getPos
where
fn a b | a <= b = 0
| otherwise = a b
regionSize :: GenKangaroo ust Int
regionSize = liftM2 () getEnd getStart
intraparse :: RegionName -> RegionCoda -> RegionStart -> Int
-> GenKangaroo ust a
-> GenKangaroo ust a
intraparse name coda intra_start len p =
bracketRegion (newRegion intra_start len coda name) p
advance :: RegionName -> RegionCoda -> Int
-> GenKangaroo ust a
-> GenKangaroo ust a
advance name coda intra_start p = getEnd >>= \end ->
intraparse name coda intra_start (end intra_start) p
advanceRelative :: RegionName -> RegionCoda -> Int
-> GenKangaroo ust a
-> GenKangaroo ust a
advanceRelative name coda dist p = getPos >>= \pos ->
intraparse name coda (pos+dist) dist p
restrict :: RegionName -> RegionCoda -> Int
-> GenKangaroo ust a
-> GenKangaroo ust a
restrict name coda len p = getPos >>= \pos ->
intraparse name coda pos len p
restrictToPos :: RegionName -> RegionCoda -> Int
-> GenKangaroo ust a
-> GenKangaroo ust a
restrictToPos name coda abs_pos p = getPos >>= \pos ->
intraparse name coda pos (abs_pospos) p
printHexAll :: GenKangaroo ust ()
printHexAll = askEnv >>= liftIOAction . slowHexAll
printRegionStack :: GenKangaroo ust ()
printRegionStack = getSt >>= liftIOAction . putStrLn . printParseStack