kangaroo-0.2.0: src/Data/ParserCombinators/Kangaroo/ParseMonad.hs
{-# OPTIONS -Wall #-}
--------------------------------------------------------------------------------
-- |
-- Module : Data.ParserCombinators.Kangaroo.ParseMonad
-- Copyright : (c) Stephen Tetley 2009-2010
-- License : BSD3
--
-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>
-- Stability : highly unstable
-- Portability : to be determined.
--
-- Random access parse monad
--
--------------------------------------------------------------------------------
module Data.ParserCombinators.Kangaroo.ParseMonad
(
GenKangaroo
, ParseErr
, RegionCoda(..) -- re-export
, RegionName -- re-export
, getUserSt
, putUserSt
, modifyUserSt
, throwErr
, liftIOAction
, withSuccess
, runGenKangaroo
, reportError
, substError
-- * Primitive parsers
, word8
, checkWord8
, opt
-- * Query the cursor position
, position
, region
, atEnd
, lengthRemaining
, regionSize
-- * Parse within a region
, intraparse
, advance
, advanceRelative
, restrict
, restrictToPos
-- * Debug
, 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 -- Is Int big enough for index?
type St = ParseStack
type Env = ImageData
-- Kangaroo is not a transformer as IO is always at the
-- \'bottom\' of the effect stack. Like the original Parsec it is
-- parametric on user state (refered to as ust).
--
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
-- I don't think Kangaroo has natural implementations of
-- Alternative or MonadPlus.
-- My 'proposition' is that the sort of parsing that Kangaroo
-- intends to provide you always now want you want hence there
-- is no inbuilt backtracking or support for list-of-successes.
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 $ sz-1)
; 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 (upper-1) 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)
-- Modifying the position lets the parser go beyond the
-- end-of-file.
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)
--------------------------------------------------------------------------------
-- Helpers
--------------------------------------------------------------------------------
--
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
--------------------------------------------------------------------------------
-- Primitive parsers
word8 :: GenKangaroo ust Word8
word8 = do
ix <- getPos
end <- getEnd
when (ix>end) (reportError "word8") -- test emphatically is (>) !
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
-- no 'try' in Kangaroo...
-- opt is the nearest to it, opt backtracks the cursor on failure.
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')
--------------------------------------------------------------------------------
-- Querying position
-- | 'position' : @-> cursor-position@
--
-- Return the current cursor position
--
position :: GenKangaroo ust Int
position = getPos
-- | 'region' : @-> (region-start, cursor-position, region-end)@
--
-- Return the current parse region and the current position of
-- the cursor within it.
--
region :: GenKangaroo ust (Int,Int,Int)
region = liftM3 (,,) getStart getPos getEnd
-- region limits are inclusive so cursor is at the end
-- if the position is greater that the end location.
-- | 'atEnd' - is the cursor at the end of the current region?
--
atEnd :: GenKangaroo ust Bool
atEnd = liftM2 (>) getPos getEnd
-- | 'lengthRemaining' : @-> distance-to-region-end@
--
-- Distance from the current cursor position to the end of the
-- current region
--
lengthRemaining :: GenKangaroo ust Int
lengthRemaining = liftM2 fn getEnd getPos
where
fn a b | a <= b = 0
| otherwise = a - b
-- | 'regionSize' : @-> region-length@
--
-- Size of the current region.
--
regionSize :: GenKangaroo ust Int
regionSize = liftM2 (-) getEnd getStart
--------------------------------------------------------------------------------
-- The important ones parsing within a /region/ ...
-- | 'intraparse' : @name * coda * abs_region_start * region_length * parser -> parser@
--
-- Create a new region within the current one and run the
-- supplied parser. The cursor position is moved to the start
-- of the new region. The value of @coda@ determines where the
-- cursor is positioned after a successful parse.
--
-- 'intraparse' throws a parse error if the supplied
-- absolute-region-start is not located within the current region,
-- or if the right-boundary of the new region
-- (@abs_region_start + region_length@) extends beyond the
-- right-boundary of the current region.
--
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' : @name * coda * abs_region_start * parser -> parser@
--
-- A variation of 'intraparse' - the new region starts at the
-- supplied @abs_region_start@ and continues to the end of the
-- current region.
--
-- 'advance' throws a parse error if the new start position is
-- not within the current region.
--
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' : @name * coda * distance * parser -> parser@
--
-- A variation of 'advance' - the start of the new region is
-- calculated from the @current-cursor-position@ + the supplied
-- @distance@.
--
-- 'advanceRelative' throws a parse error if the new start
-- position is not within the current region.
--
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' : @ name * coda * distance * parser -> parser@
--
-- A variation of 'intraparse' - create a new region as a
-- restriction of the current one and run the supplied parser.
-- The new region starts at the current coursor position, the
-- right-boundary is restricted to the @current-cursor-position@
-- + the supplied @distance@.
--
-- 'restrict' throws a parse error if the right-boundary of the
-- new region extends beyond the current region.
--
restrict :: RegionName -> RegionCoda -> Int
-> GenKangaroo ust a
-> GenKangaroo ust a
restrict name coda len p = getPos >>= \pos ->
intraparse name coda pos len p
-- | 'restrictToPos' : @region-name * coda * abs-end-pos * parser -> parser@
--
-- A variantion of 'restrict' - the new region takes the current
-- cursor position for the left-boundary and the supplied
-- absolute-end-position (@abs-end-pos@) as the right-boundary.
--
-- 'restrictToPos' throws a parse error if the @abs-end-pos@
-- extends beyond the right-boundary of the current region.
--
restrictToPos :: RegionName -> RegionCoda -> Int
-> GenKangaroo ust a
-> GenKangaroo ust a
restrictToPos name coda abs_pos p = getPos >>= \pos ->
intraparse name coda pos (abs_pos-pos) p
--------------------------------------------------------------------------------
-- Debug
printHexAll :: GenKangaroo ust ()
printHexAll = askEnv >>= liftIOAction . slowHexAll
printRegionStack :: GenKangaroo ust ()
printRegionStack = getSt >>= liftIOAction . putStrLn . printParseStack