kangaroo 0.1.0 → 0.2.0

raw patch · 18 files changed

+1244/−378 lines, 18 filesdep ~arrayPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: array

API changes (from Hackage documentation)

Files

• demo/MidiRead.hs +13/−27
• demo/MidiText.hs +82/−105
• demo/PrintMidi.hs +1/−0
• kangaroo.cabal +22/−8
• src/Data/ParserCombinators/Kangaroo.hs +2/−5
• src/Data/ParserCombinators/Kangaroo/Debug.hs +32/−0
• src/Data/ParserCombinators/Kangaroo/ParseMonad.hs +226/−208
• src/Data/ParserCombinators/Kangaroo/Region.hs +193/−0
• src/Data/ParserCombinators/Kangaroo/Utils.hs +27/−2
• src/Data/ParserCombinators/KangarooRWS.hs +5/−7
• src/Data/ParserCombinators/KangarooReader.hs +2/−3
• src/Data/ParserCombinators/KangarooState.hs +4/−6
• src/Data/ParserCombinators/KangarooWriter.hs +1/−3
• src/Text/PrettyPrint/JoinPrint.hs +25/−0
• src/Text/PrettyPrint/JoinPrint/Core.hs +247/−0
• src/Text/PrettyPrint/JoinPrint/HexDump.hs +156/−0
• src/Text/PrettyPrint/JoinPrint/JoinString.hs +195/−0
• test/Picklers.hs +11/−4

@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  MidiRead--- Copyright   :  (c) Stephen Tetley 2009+-- Copyright   :  (c) Stephen Tetley 2009-2010 -- License     :  BSD3 -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>@@ -23,7 +23,9 @@ import MidiDatatypes  import Data.ParserCombinators.KangarooWriter+import Data.ParserCombinators.Kangaroo.Utils + import Control.Applicative import Control.Monad import Data.Bits@@ -40,41 +42,26 @@    putStrLn w    either error return a     -{- -logMsg :: String -> MidiParser ()-logMsg = tell . ("\n" ++)--logPos :: String -> MidiParser a -> MidiParser a-logPos s p = do -  p1 <- position-  ans <- p-  p2 <- position-  logMsg $ unwords [show p1, s, show p2]-  return ans--logBound :: String -> MidiParser a -> MidiParser a-logBound s p = do -  b <- upperBound-  logMsg $ unwords [ s, "region boundary", show b ]-  p---}- -------------------------------------------------------------------------------- --  -+-- Not sure about this ... +(-*-) :: MidiParser a -> String -> MidiParser a+(-*-) = substError      midiFile :: MidiParser MidiFile  -midiFile = mprogress MidiFile trackCount header (countS `flip` track)+midiFile = printHexAll >> mprogress MidiFile trackCount header (countS `flip` track)   where     trackCount :: Header -> Int      trackCount (Header _ n _) = fromIntegral n  header :: MidiParser Header  -header = Header <$> (assertString "MThd"  *> assertWord32 (6::Int) *> format)-                <*> word16be             <*> timeDivision +header = Header <$> (assertString "MThd"                -*- "header"+                 *> assertWord32 (6::Int)               -*- "length"+                 *> format                              -*- "format")+                <*> word16be                            -*- "num tracks"+                <*> timeDivision                        -*- "time division"  countS :: Int -> MidiParser a -> MidiParser (Seq a) countS = genericCount (<|) S.empty @@ -87,8 +74,7 @@ trackHeader = assertString "MTrk" >> word32be  getMessages :: Word32 -> MidiParser (Seq Message)--getMessages i = alfineRelative 0 (fromIntegral i) messages+getMessages i = restrict "messages" Alfermata (fromIntegral i) messages   where         messages = genericRunOn (<|) S.empty message 

@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  MidiText--- Copyright   :  (c) Stephen Tetley 2009+-- Copyright   :  (c) Stephen Tetley 2009-2010 -- License     :  BSD3 -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>@@ -16,54 +16,35 @@   module MidiText (-    -- * Print a readable text representation-    printMidi, ppMidiFile,-    -    ppHeader, ppMessage,-  +    -- * Print a midi file to stdout+    printMidi+   ) where   import MidiDatatypes--import qualified Data.Foldable as F-import Numeric-import Text.PrettyPrint.HughesPJ+import Text.PrettyPrint.JoinPrint hiding ( length )  -printMidi :: MidiFile -> IO ()-printMidi = putStrLn . render . ppMidiFile -+import qualified Data.Foldable as F+import Data.Word +void :: Monad m => m a -> m ()+void mf = mf >> return ()  -integral :: Integral a => a -> Doc-integral = integer . fromIntegral--infixl 6 `hyph`, `dblhyph`--hyph :: Doc -> Doc -> Doc-x `hyph` y         = x <> text " - " <> y--dblhyph :: Doc -> Doc -> Doc-x `dblhyph` y         = x <> text " -- " <> y--ppHex :: Integral a => a -> Doc-ppHex i = text $ showHex i []-+printMidi :: MidiFile -> IO ()+printMidi (MidiFile hdr tracks)  = do +   header hdr +   void $ F.foldlM (\i t -> track i t >> return (i+1)) 0 tracks  -ppMidiFile :: MidiFile -> Doc-ppMidiFile (MidiFile header tracks)  = ppHeader header $$ tdoc $$ empty-  where-    tdoc = fst $ F.foldl fn (empty,0) tracks-    fn (d,i) t = (d $$ prettyTrack t i, i+1)-      -ppHeader :: Header -> Doc-ppHeader (Header hformat ntrks td) = -    text "[Header]" <+> ppHFormat hformat -                    `hyph` (integral ntrks <+> text "tracks") -                    `hyph` ppTimeDivision td+header :: Header -> IO () +header (Header hformat ntrks td) = renderIO $ +    punctuate (text " - ") [ text "[Header]" <+> ppHFormat hformat+                           , integral ntrks <+> text "tracks"+                           , ppTimeDivision td+                           ]    ppHFormat :: HFormat -> Doc ppHFormat MF0  = text "Type 0"@@ -74,87 +55,83 @@ ppTimeDivision (FPS i)   = text "fps"   <+> integral i ppTimeDivision (TPB i)   = text "ticks" <+> integral i -prettyTrack :: Track -> Int -> Doc-prettyTrack (Track se) i = -    brackets (text "Track" <+> int i) $$ (snd $ F.foldl fn (0,empty) se)+track :: Int -> Track -> IO ()+track i (Track se) = do +    renderIO $ brackets (text "Track" <+> int i) +    void $ F.foldlM fn 0 se   where-    fn (gt,doc) msg@(dt,_)  = -      (gt+dt, doc $$ (padshow 8 (gt+dt) `hyph` ppMessage msg))    +    fn gt (dt,evt)  = let (name,d) =  event evt in+                      do { renderIO $ mkEvent gt dt name d +                         ; return (gt+dt)+                         }  -ppMessage :: Message -> Doc-ppMessage (dt,evt) = padshow 5 dt `hyph` ppEvent evt      +mkEvent :: Word32 -> DeltaTime -> String -> Doc -> Doc+mkEvent ot dt name rest = let s = text " - " in+    punctuate s [ padl 10 ' ' (integral ot)+                , padl 6  ' ' (integral dt)+                , padr 20 ' ' (text name)+                , rest] +type EventDescr = (String,Doc) -ppEvent :: Event -> Doc-ppEvent (VoiceEvent e)   = ppVoiceEvent e-ppEvent (SystemEvent e)  = text "sys"  `dblhyph` ppSystemEvent e-ppEvent (MetaEvent e)    = text "meta" `dblhyph` ppMetaEvent e -padshow :: Show a => Int -> a -> Doc-padshow pad a = let s = show a ; dif = pad - length s in-    text $ replicate dif ' ' ++ s -                  +event :: Event -> EventDescr+event (VoiceEvent e)   = voiceEvent e+event (SystemEvent e)  = let (s,d) = systemEvent e in ("sys " ++s, d)+event (MetaEvent e)    = let (s,d) = metaEvent e in ("meta " ++ s, d)   fli :: (Integral a, Show a) => a -> Doc-fli = padshow 3+fli = padl 3 ' ' . integral -ppVoiceEvent :: VoiceEvent -> Doc-ppVoiceEvent (NoteOff ch nt vel)        = -    text "note-off" `hyph` fli ch `hyph` fli nt `hyph` fli vel- -ppVoiceEvent (NoteOn ch nt vel)         =-    text "note-on " `hyph` fli ch `hyph` fli nt `hyph` fli vel-    -ppVoiceEvent (NoteAftertouch ch nt val) = -    text "note-after-touch" `hyph` fli ch `hyph` fli nt `hyph` fli val-    -ppVoiceEvent (Controller ch ty val)     = -    text "ctlr" `hyph` fli ch `hyph` fli ty `hyph` fli val-    -ppVoiceEvent (ProgramChange ch num)     = -    text "pc" `hyph` fli ch `hyph` fli num-    -ppVoiceEvent (ChanAftertouch ch val)    = -    text "chan-after-touch" `hyph` fli ch `hyph` fli val-      -ppVoiceEvent (PitchBend ch val)         = -    text "pitch-bend" `hyph` fli ch `hyph` fli val+voiceEvent :: VoiceEvent -> EventDescr+voiceEvent (NoteOff ch nt vel)        = ("note-off",    dashInts [ch,nt,vel])+voiceEvent (NoteOn ch nt vel)         = ("note-on",     dashInts [ch,nt,vel])+voiceEvent (NoteAftertouch ch nt val) = ("note-after-touch", dashInts [ch,nt,val])+voiceEvent (Controller ch ty val)     = ("ctlr",        dashInts [ch,ty,val])+voiceEvent (ProgramChange ch num)     = ("pc",          dashInts [ch,num])+voiceEvent (ChanAftertouch ch val)    = ("chan-after-touch", dashInts [ch,val])+voiceEvent (PitchBend ch val)         = ("pitch-bend",  dashInts [fromIntegral ch,val])     -ppSystemEvent :: SystemEvent -> Doc-ppSystemEvent (SysEx _ _)    = text "sysex"   -- system exclusive event - length x data-ppSystemEvent (DataEvent i)  = text "data" <+> ppHex i+systemEvent :: SystemEvent -> EventDescr+systemEvent (SysEx _ _)    = ("sysex", empty)   +systemEvent (DataEvent i)  = ("data",  oxhex2 i) -ppMetaEvent :: MetaEvent -> Doc-ppMetaEvent (TextEvent ty s)     = ppTextType ty `hyph` doubleQuotes (text s)-ppMetaEvent (SequenceNumber i)   = text "sequence-number" `hyph` integral i-ppMetaEvent (ChannelPrefix ch)   = text "channel-prefix"  `hyph` integral ch-ppMetaEvent (EndOfTrack)         = text "end-of-track"-ppMetaEvent (SetTempo mspqn)     = text "set-tempo" `hyph` integral mspqn  -- microseconds per quarter-note-ppMetaEvent (SMPTEOffset h m s f sf) = -    text "smpte" `hyph` fli h `hyph` fli m `hyph` fli s `hyph` fli f `hyph` fli sf-    -ppMetaEvent (TimeSignature n d m ns) = -    text "time-sig" `hyph` fli n `hyph` fli d `hyph` fli m `hyph` fli ns-    -ppMetaEvent (KeySignature i sc)  = -    text "key-sig" `hyph` integral i `hyph` ppScaleType sc-       -ppMetaEvent (SSME i _)           = text "ssme" `hyph` ppHex i <+> text "..."+metaEvent :: MetaEvent -> EventDescr+metaEvent (TextEvent ty s)          = (textType ty, dquotes $ text s)+metaEvent (SequenceNumber i)        = ("sequence-number", integral i)+metaEvent (ChannelPrefix ch)        = ("channel-prefix",  integral ch)+metaEvent (EndOfTrack)              = ("end-of-track", empty)+metaEvent (SetTempo mspqn)          = ("set-tempo", integral mspqn)+metaEvent (SMPTEOffset h m s f sf)  = ("smpte",     dashInts [h,m,s,f,sf])+metaEvent (TimeSignature n d m ns)  = ("time-sig",  dashInts [n,d,m,ns])+metaEvent (KeySignature i sc)       = ("key-sig", integral i `hyph` st) +     where st = text $ scaleType sc+metaEvent (SSME i _)                = ("ssme",    oxhex8 i <+> text "...") -ppScaleType :: ScaleType -> Doc-ppScaleType MAJOR  = text "major"-ppScaleType MINOR  = text "minor"+dashInts :: Integral a => [a] -> Doc+dashInts = punctuate (text " - ") . map fli+++scaleType :: ScaleType -> String+scaleType MAJOR  = "major"+scaleType MINOR  = "minor"   -ppTextType :: TextType -> Doc-ppTextType GENERIC_TEXT         = text "generic-text" -ppTextType COPYRIGHT_NOTICE     = text "copyright-notice"  -ppTextType SEQUENCE_NAME        = text "sequence-name"-ppTextType INSTRUMENT_NAME      = text "instrument-name"-ppTextType LYRICS               = text "lyrics"-ppTextType MARKER               = text "marker"-ppTextType CUE_POINT            = text "cue-point"+textType :: TextType -> String+textType GENERIC_TEXT         =  "generic-text" +textType COPYRIGHT_NOTICE     =  "copyright-notice"  +textType SEQUENCE_NAME        =  "sequence-name"+textType INSTRUMENT_NAME      =  "instrument-name"+textType LYRICS               =  "lyrics"+textType MARKER               =  "marker"+textType CUE_POINT            =  "cue-point"   ++infixl 6 `hyph`++hyph :: Doc -> Doc -> Doc+x `hyph` y         = x <> text " - " <> y+

@@ -9,6 +9,7 @@  module Main where + import MidiRead import MidiText 

@@ -1,12 +1,12 @@ name:             kangaroo-version:          0.1.0+version:          0.2.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com> maintainer:       Stephen Tetley <stephen.tetley@gmail.com> homepage:         http://code.google.com/p/copperbox/ category:         Parsing-synopsis:         Random access binary combinator parser.+synopsis:         Binary parsing with random access. description:   Binary parsing with random access. The target file to be    parsed is loaded into memory at the start (represented as@@ -24,10 +24,18 @@   Hackage because I'm now using it with Hurdle which was already    on Hackage.   .+  Currently kangaroo is twinned with its own library of formatting+  combinators, at some point this is likely to be put into its +  own package+  .   Changelog:+  .+  0.2.0 Changes to ParseMonad - parsing within a region simplified, +  temporarily added JoinPrint.   . -  0.1.0 First version-  +  0.1.0 First version.+  .+ build-type:         Simple stability:          half baked cabal-version:      >= 1.2@@ -43,7 +51,7 @@ library   hs-source-dirs:     src   build-depends:      base < 5,-                      array >= 0.3.0.0 && < 0.4+                      array >= 0.2.0.0 && < 0.4       exposed-modules:@@ -52,13 +60,19 @@     Data.ParserCombinators.KangarooRWS,     Data.ParserCombinators.KangarooState,     Data.ParserCombinators.KangarooWriter,+    Text.PrettyPrint.JoinPrint++  other-modules:     Data.ParserCombinators.Kangaroo.Combinators,+    Data.ParserCombinators.Kangaroo.Debug,     Data.ParserCombinators.Kangaroo.IEEEFloat,     Data.ParserCombinators.Kangaroo.ParseMonad,     Data.ParserCombinators.Kangaroo.Prim,-    Data.ParserCombinators.Kangaroo.Utils--  other-modules:+    Data.ParserCombinators.Kangaroo.Region,+    Data.ParserCombinators.Kangaroo.Utils,+    Text.PrettyPrint.JoinPrint.Core,+    Text.PrettyPrint.JoinPrint.HexDump,+    Text.PrettyPrint.JoinPrint.JoinString          extensions:     

@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Data.ParserCombinators.Kangaroo--- Copyright   :  (c) Stephen Tetley 2009+-- Copyright   :  (c) Stephen Tetley 2009, 2010 -- License     :  BSD3 -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>@@ -19,17 +19,14 @@     module Data.ParserCombinators.Kangaroo.Combinators   , module Data.ParserCombinators.Kangaroo.ParseMonad   , module Data.ParserCombinators.Kangaroo.Prim-  , module Data.ParserCombinators.Kangaroo.Utils   , Kangaroo   , runKangaroo   , parse   ) where  import Data.ParserCombinators.Kangaroo.Combinators-import Data.ParserCombinators.Kangaroo.ParseMonad hiding (-    getSt, putSt, modifySt ) -- TO SORT...+import Data.ParserCombinators.Kangaroo.ParseMonad import Data.ParserCombinators.Kangaroo.Prim-import Data.ParserCombinators.Kangaroo.Utils hiding ( (<:>), oo, ooo, oooo )   type Kangaroo a = GenKangaroo () a

@@ -0,0 +1,32 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Data.ParserCombinators.Kangaroo.Debug+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  to be determined.+--+-- Debug helpers+--+--------------------------------------------------------------------------------++module Data.ParserCombinators.Kangaroo.Debug+  (+    slowHexAll+  +  ) where+++import Text.PrettyPrint.JoinPrint++import Data.Array.IO+import Data.Word++slowHexAll :: IOUArray Int Word8 -> IO ()+slowHexAll arr = getElems arr  >>= \xs    -> +                 getBounds arr >>= \(s,e) -> putStrLn $ render $ hexdump s e xs+

@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Data.ParserCombinators.Kangaroo.ParseMonad--- Copyright   :  (c) Stephen Tetley 2009+-- Copyright   :  (c) Stephen Tetley 2009-2010 -- License     :  BSD3 -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>@@ -18,47 +18,50 @@   (     GenKangaroo   , ParseErr-  -  , getSt-  , putSt-  , modifySt-  +  , RegionCoda(..)      -- re-export+  , RegionName          -- re-export+       , getUserSt   , putUserSt   , modifyUserSt -  , askEnv   , throwErr+  , liftIOAction+  , withSuccess   , runGenKangaroo    , reportError   , substError++  -- * Primitive parsers   , word8   , checkWord8   , opt ++  -- * Query the cursor position   , position-  , regionEnd+  , region   , atEnd   , lengthRemaining--  -- * Parse within a /region/.-  , dalpunto-  , dalpuntoRelative-  , advanceDalpunto-  , advanceDalpuntoAbsolute--  , alfine-  , alfineRelative-  , restrictAlfine+  , regionSize -  , alfermata-  , alfermataRelative-  , advanceAlfermata-  , advanceAlfermataAbsolute-  , restrictAlfermata +  -- * 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@@ -70,13 +73,11 @@  type ImageData = IOUArray Int Word8   -- Is Int big enough for index? -data ArrIx = ArrIx { arr_ix_ptr :: !Int, arr_ix_end :: !Int }-  deriving (Eq,Show)  -type St    = ArrIx-type Env   = ImageData-  +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).@@ -134,16 +135,50 @@ -- is no inbuilt backtracking or support for list-of-successes.  -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) -modifySt :: (St -> St) -> GenKangaroo ust ()-modifySt f = GenKangaroo $ \_ st ust -> return (Right (), f st, ust)+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) @@ -154,59 +189,54 @@ modifyUserSt f = GenKangaroo $ \_ st ust -> return (Right (), st, f ust)  +-- Modifying the position lets the parser go beyond the +-- end-of-file. -askEnv :: GenKangaroo ust Env-askEnv = GenKangaroo $ \env st ust -> return (Right env, st, ust)+advancePos1 :: GenKangaroo ust ()+advancePos1 = modifyPos (+1)  +modifyPos :: (Pos -> Pos) -> GenKangaroo ust ()+modifyPos f = GenKangaroo $ \_ st ust -> return (Right (), move f st, ust) -throwErr :: String -> GenKangaroo ust a-throwErr msg = GenKangaroo $ \_ st ust -> return (Left msg, st, ust) -liftIOAction :: IO a -> GenKangaroo ust a-liftIOAction ma = GenKangaroo $ \_ st ust -> -    ma >>= \a -> return (Right a, 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)  -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,_,ust) <- runP p rsz arr-         ; return (ans,ust)   -         }-  where -    runP (GenKangaroo x) upper arr = x arr (ArrIx 0 (upper-1)) user_state+liftIOAction :: IO a -> GenKangaroo ust a+liftIOAction ma = GenKangaroo $ \_ st ust -> +    ma >>= \a -> return (Right a, st, ust)     -------------------------------------------------------------------------------- -- Helpers -modifyIx :: (Int -> Int) -> GenKangaroo ust ()-modifyIx f = modifySt $ \(ArrIx ix end) -> ArrIx (f ix) end- -------------------------------------------------------------------------------- --    reportError :: ParseErr -> GenKangaroo ust a reportError s = do -    posn <- getSt+    posn <- getPos     throwErr $ s ++ posStr posn   where-    posStr (ArrIx pos end) = concat [ " absolute position "-                                    , show pos-                                    , " (0x" -                                    , showHex pos []-                                    , "), region length "-                                    , show end-                                    ]+    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 -> @@ -214,205 +244,193 @@         (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-    (ArrIx ix end)   <- getSt+    ix               <- getPos+    end              <- getEnd     when (ix>end)    (reportError "word8")   -- test emphatically is (>) !     arr              <- askEnv     a                <- liftIOAction $ readArray arr ix-    putSt $ ArrIx (ix+1) end+    advancePos1     return a - checkWord8 :: (Word8 -> Bool) -> GenKangaroo ust (Maybe Word8) checkWord8 check = word8 >>= \ans ->     if check ans then return $ Just ans-                 else modifyIx (subtract 1) >> return Nothing+                 else modifyPos (`subtract` 1) >> return Nothing   ++ -- no 'try' in Kangaroo... --- opt is the nearest to it, opt backtracks the cursor onm failure.+-- 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') -position :: GenKangaroo ust Int-position = liftM arr_ix_ptr getSt -regionEnd :: GenKangaroo ust Int-regionEnd = liftM arr_ix_end getSt----atEnd :: GenKangaroo ust Bool-atEnd = getSt >>= \(ArrIx ix end) -> return $ ix >= end--lengthRemaining :: GenKangaroo ust Int-lengthRemaining = getSt >>= \(ArrIx ix end) -> -   let rest = end - ix in if rest < 0 then return 0 else return rest- ----------------------------------------------------------------------------------- The important ones parsing within a /region/ ...+-- Querying position --- Three useful final positions ------ 1. dalpunto  - 'from the point'      --- - Run the parser within a region and return to where you came---   from.------ 2. alfine    - 'to the end'     --- - Run the parser within a region and jump to the right-end of ---   the region after the parse.+-- | 'position' : @-> cursor-position@ ----- 3. alfermata - 'to the stop'    --- - Run the parser within a region, the cursor remains wherever ---   the parse finished.+-- Return the current cursor position ----+position :: GenKangaroo ust Int+position = getPos  -assertSubsetRegion :: String -> Int -> Int -> GenKangaroo ust ()-assertSubsetRegion fun_name start end = -    getSt >>= \(ArrIx pos endpos) -> step pos endpos -  where-    step pos endpos | start < pos   = reportError $ -                                        backtrackErr start pos fun_name-                    | end > endpos  = reportError $ -                                        tooFarErr end endpos fun_name-                    | otherwise     = return ()+-- | '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. -backtrackErr :: Int -> Int -> String -> String  -backtrackErr new_pos old_pos fun_name = concat-    [ "Kangaroo.ParseMonad."-    , fun_name-    , " - cannot backtrack, " -    , show new_pos -    , " is before current position " -    , show old_pos-    ]+-- | 'atEnd' - is the cursor at the end of the current region?+--+atEnd :: GenKangaroo ust Bool+atEnd = liftM2 (>) getPos getEnd -tooFarErr :: Int -> Int -> String -> String-tooFarErr new_end old_end fun_name = concat-    [ "Kangaroo.ParseMonad."-    , fun_name -    , " - new end point " -    , show new_end -    , " extends beyond the end of the current region "-    , show old_end-    ]+-- | '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  --- Parser inside the supplied region, afterwards restore the--- end of the /outer/ region and return to the initial position.+-- | 'regionSize' : @-> region-length@ ---dalpuntoP :: String -> Int -> Int -                 -> GenKangaroo ust a -                 -> GenKangaroo ust a-dalpuntoP fun_name start end p = do-    st <- getSt -    assertSubsetRegion fun_name start end-    putSt $ ArrIx start end-    ans <- p-    putSt st-    return ans-    +-- Size of the current region.+--+regionSize :: GenKangaroo ust Int+regionSize = liftM2 (-) getEnd getStart  --- | return to the start position - start x length-dalpunto :: Int -> Int -> GenKangaroo ust a -> GenKangaroo ust a-dalpunto = dalpuntoP "dalpunto"+--------------------------------------------------------------------------------+-- The important ones parsing within a /region/ ...  --- | return to the start position - displacement x length-dalpuntoRelative :: Int -> Int -> GenKangaroo ust a -> GenKangaroo ust a-dalpuntoRelative disp len p = getSt >>= \(ArrIx pos _) ->-    dalpuntoP "dalpuntoRelative" (pos+disp) (pos+disp+len-1) p --- | Advance the current position by the supplied distance.-advanceDalpunto :: Int -> GenKangaroo ust p -> GenKangaroo ust p-advanceDalpunto i p = getSt >>= \(ArrIx pos end) -> -    dalpuntoP "advanceDalpunto" (pos+i) end p---- | Advance the current position to the supplied (absolute) --- position.-advanceDalpuntoAbsolute :: Int -> GenKangaroo ust p -> GenKangaroo ust p-advanceDalpuntoAbsolute i p = getSt >>= \(ArrIx _ end) -> -    dalpuntoP "advanceDalpuntoAbsolute" i end p+-- | '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+              --- Parse inside the supplied region, afterwards go to the end of--- the supplied region and restore the end of the /outer/ region.+-- | '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. ---alfineP :: String -> Int -> Int -> GenKangaroo ust a -> GenKangaroo ust a-alfineP fun_name start end p = do-    ArrIx _ prev_end <- getSt -    assertSubsetRegion fun_name start end-    putSt $ ArrIx start end-    ans <- p-    putSt $ ArrIx (end+1) prev_end-    return ans+-- '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  --- | alfine - parse to the end-alfine :: Int -> Int -> GenKangaroo ust a -> GenKangaroo ust a-alfine = alfineP "alfine"+-- | '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.+-- --- | finish at the right of the region - displacement x length-alfineRelative :: Int -> Int -> GenKangaroo ust a -> GenKangaroo ust a-alfineRelative disp len p = getSt >>= \(ArrIx pos _) ->-    alfineP "alfineRelative" (pos+disp) (pos+disp+len-1) 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  -restrictAlfine :: Int -> GenKangaroo ust p -> GenKangaroo ust p-restrictAlfine dist_to_end p = getSt >>= \(ArrIx pos _) -> -    alfineP "restrictAlfine" pos (pos + dist_to_end) 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  --- Parser inside the supplied region, afterwards restore the end --- of the /outer/region but keep the cursor in at the current --- position.+-- | 'restrictToPos' : @region-name * coda * abs-end-pos * parser -> parser@ ---alfermataP :: String -> Int -> Int -> GenKangaroo ust a -> GenKangaroo ust a-alfermataP fun_name start end p = do-    ArrIx _ prev_end    <- getSt -    assertSubsetRegion fun_name start end-    putSt $ ArrIx start end-    ans <- p-    ArrIx curr_pos _    <- getSt-    putSt $ ArrIx curr_pos prev_end -    return ans- --- | alfermata - parse to the /sign/ i.e. wherever the supplied --- parser stops within the supplied region. At the end of the--- parse restore the outer region.+-- 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.  ---alfermata :: Int -> Int -> GenKangaroo ust a -> GenKangaroo ust a-alfermata = alfermataP "alfermata"+-- '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  -alfermataRelative :: Int -> Int -> GenKangaroo ust a -> GenKangaroo ust a-alfermataRelative disp len p = getSt >>= \(ArrIx pos _) ->-    alfermataP "alfermataRel" (pos+disp) (pos+disp+len-1) p +--------------------------------------------------------------------------------+-- Debug --- | Advance the current position by the supplied distance.-advanceAlfermata :: Int -> GenKangaroo ust p -> GenKangaroo ust p-advanceAlfermata i p = getSt >>= \(ArrIx pos end) -> -    alfermataP "advanceAlfermata" (pos+i) end p+printHexAll         :: GenKangaroo ust ()+printHexAll         = askEnv >>= liftIOAction . slowHexAll --- | Advance the current position to the supplied (absolute) --- position.-advanceAlfermataAbsolute :: Int -> GenKangaroo ust p -> GenKangaroo ust p-advanceAlfermataAbsolute i p = getSt >>= \(ArrIx _ end) -> -    alfermataP "advanceAlfermataAbsolute" i end p+printRegionStack    :: GenKangaroo ust ()+printRegionStack    = getSt >>= liftIOAction . putStrLn . printParseStack -restrictAlfermata :: Int -> GenKangaroo ust p -> GenKangaroo ust p-restrictAlfermata dist_to_end p = getSt >>= \(ArrIx pos _) ->-    alfermataP "restrictAlfermata" pos (pos + dist_to_end) p+                

@@ -0,0 +1,193 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Data.ParserCombinators.Kangaroo.Region+-- Copyright   :  (c) Stephen Tetley 2009-2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  to be determined.+--+-- Data types to manage parse regions+--+--------------------------------------------------------------------------------++module Data.ParserCombinators.Kangaroo.Region+  (+  -- * Types+    RegionCoda(..)+  , RegionStart+  , RegionEnd+  , RegionName+  , Pos+  , RegionInfo+  , ParseStack+  , RegionError(..)++  -- * Operations+  , newStack+  , newRegion++  , regionStart+  , regionEnd+  , push+  , pop+  , move1+  , move+  , location++  , printParseStack+  +  ) where+++import Text.PrettyPrint.JoinPrint  hiding ( length )+++-- | 'RegionCoda' - represents three useful final positions:+--+-- 1. dalpunto  - 'from the point'      +-- - Run the parser within a region and return to where you came+--   from.+--+-- 2. alfermata - 'to the stop'    +-- - Run the parser within a region, the cursor remains wherever +--   the parse finished.+--+-- 3. alfine    - 'to the end'     +-- - Run the parser within a region and jump to the right-end of +--   the region after the parse.+--+data RegionCoda = Dalpunto | Alfermata | Alfine+  deriving (Enum,Eq,Show)+++type RegionStart = Int+type RegionEnd   = Int+type RegionName  = String++type Pos         = Int++-- | 'RegionInfo' contains the (inclusive) bounds of a region +-- and the \'coda action\' to take after parsing has finished.+--++data RegionInfo  = RegionInfo +        { region_start_incl   :: !RegionStart+        , region_end_incl     :: !RegionEnd+        , region_coda         :: !RegionCoda+        , region_name         :: !String+        }+  deriving (Eq,Show)++++-- | 'ParseStack' is a non empty list of RegionInfo structures.+--+data ParseStack = P0 Pos RegionInfo | Pn Pos RegionInfo ParseStack+  deriving (Eq,Show)++-- These two might change...++newtype RegionError = RegionError { getRegionError :: String }+  deriving (Eq,Show)++++--------------------------------------------------------------------------------++mapTop :: (RegionInfo -> a) -> ParseStack -> a+mapTop f (P0 _ info)   = f info+mapTop f (Pn _ info _) = f info++modifyPos :: (Pos -> Pos) -> ParseStack -> ParseStack+modifyPos f (P0 p info)     = P0 (f p) info+modifyPos f (Pn p info stk) = Pn (f p) info stk++validBounds :: RegionStart -> RegionEnd -> ParseStack -> Bool+validBounds s e stk = s >= regionStart stk && e <= regionEnd stk++infos :: ParseStack -> [RegionInfo]+infos (P0 _ info)     = [info]+infos (Pn _ info stk) = info : infos stk++regionError :: RegionName -> RegionStart -> RegionEnd -> ParseStack +            -> RegionError+regionError nm s e stk = step (regionStart stk) (regionEnd stk) +  where+    step rs re | s < rs && e > re = mkMsg nm "past the bounds" (s,e) (rs,re)+               | s < rs           = mkMsg nm "past the left"   (s,e) (rs,re)+               | e > re           = mkMsg nm "past the right"  (s,e) (rs,re)+               | otherwise        = RegionError $ +                                      "regionError called on invalid data."++mkMsg :: RegionName -> String -> (Int,Int) -> (Int,Int) -> RegionError+mkMsg name descr new old  = RegionError $ +    unwords [ "The new region"+            , ('\'' : name ++ "'")+            , show new+            , "extends"+            , descr+            , "of the old region"+            , show old+            ]++--------------------------------------------------------------------------------+-- Exported operations++regionStart     :: ParseStack -> Int+regionStart     = mapTop region_start_incl++regionEnd       :: ParseStack -> Int+regionEnd       = mapTop region_end_incl+++newStack :: RegionStart -> RegionEnd -> RegionCoda -> RegionName -> ParseStack+newStack s e coda name = P0 0 (RegionInfo s e coda name)++newRegion :: RegionStart -> Int -> RegionCoda -> RegionName -> RegionInfo+newRegion s len coda name = RegionInfo s (s+len-1) coda name+++push :: RegionInfo -> ParseStack -> Either RegionError ParseStack+push info@(RegionInfo s e _ name) stk +    | validBounds s e stk = Right $ Pn s info stk+    | otherwise           = Left  $ regionError name s e stk+++pop :: ParseStack -> ParseStack+pop (P0 p info)      = P0 p info+pop (Pn p info stk)  = case region_coda info of+    Dalpunto  -> stk+    Alfermata -> modifyPos (const p) stk+    Alfine    -> modifyPos (const $ region_end_incl info) stk++-- Moving will always succeed, so it is possible to move beyond +-- the end-of-file.+                         +move1 :: ParseStack -> ParseStack+move1 = modifyPos (+1)++move :: (Pos -> Pos) -> ParseStack -> ParseStack+move = modifyPos++location :: ParseStack -> Int+location (P0 p _)   = p+location (Pn p _ _) = p++printParseStack :: ParseStack -> String+printParseStack pstack = unlines $ map (render . fn) stk+  where+    stk             = infos pstack+    (w1,w4)         = onSnd (length . show) $ foldr phi (0,0) stk+    phi info (a,b)  = (max a (length $ region_name info), max b $ region_end_incl info)+    onSnd f (a,b)   = (a, f b)++    fn        :: RegionInfo -> Doc+    fn rgn    =  padl w1 ' ' (text $ region_name rgn)+             <+> padl w4 ' ' (int  $ region_start_incl rgn)+             <+> padl w4 ' ' (int  $ region_end_incl rgn)+    +

@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Data.ParserCombinators.Kangaroo.Utils--- Copyright   :  (c) Stephen Tetley 2009+-- Copyright   :  (c) Stephen Tetley 2009-2010 -- License     :  BSD3 -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>@@ -19,7 +19,12 @@     (<:>)   , pairA   , mprogress+  , bracketM+  , bracketM_ +  , unfoldrM ++   -- * Specs   , oo   , ooo@@ -57,7 +62,7 @@   import Control.Applicative-+import Control.Monad  import Data.Bits import Data.Int import Data.Word@@ -78,6 +83,26 @@ -- needs renaming... mprogress :: Monad m => (a -> c -> d) -> (a -> b) -> m a -> (b -> m c) -> m d mprogress comb f ma mb = ma >>= \a -> mb (f a) >>= \b -> return $ comb a b++++bracketM :: Monad m => m a -> (a -> m b) -> (a -> m c) -> m c+bracketM pre post mf = do +    a   <- pre+    ans <- mf a+    _   <- post a+    return ans++bracketM_ :: Monad m => m a -> m b -> m c -> m c+bracketM_ pre post mf = pre >> mf >>= \ans -> post >> return ans++++unfoldrM      :: Monad m => (b -> m (Maybe (a, b))) -> b -> m [a]+unfoldrM mf b  = mf b >>= maybe (return []) sk+  where+    sk (a,st)  = liftM (a:) $ unfoldrM mf st+  -- specs - defined in my package data-aviary but defined here to  -- avoid a dependency

@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Data.ParserCombinators.KangarooRWS--- Copyright   :  (c) Stephen Tetley 2009+-- Copyright   :  (c) Stephen Tetley 2009, 2010 -- License     :  BSD3 -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>@@ -19,7 +19,6 @@     module Data.ParserCombinators.Kangaroo.Combinators   , module Data.ParserCombinators.Kangaroo.ParseMonad   , module Data.ParserCombinators.Kangaroo.Prim-  , module Data.ParserCombinators.Kangaroo.Utils   , Kangaroo   , parse   , runKangaroo@@ -37,8 +36,7 @@ import Data.ParserCombinators.Kangaroo.Combinators import Data.ParserCombinators.Kangaroo.ParseMonad import Data.ParserCombinators.Kangaroo.Prim-import Data.ParserCombinators.Kangaroo.Utils hiding ( (<:>), oo, ooo, oooo )-import qualified Data.ParserCombinators.Kangaroo.Utils as Specs+import Data.ParserCombinators.Kangaroo.Utils  import Control.Monad import Data.Monoid@@ -62,7 +60,7 @@       -> st        -> FilePath        -> IO (Either ParseErr a)-parse = liftM fst `Specs.oooo` evalKangaroo +parse = liftM fst `oooo` evalKangaroo   runKangaroo :: Monoid w              => Kangaroo r w st a @@ -80,7 +78,7 @@              -> st               -> FilePath               -> IO (Either ParseErr a,w)-evalKangaroo = liftM fn `Specs.oooo` runKangaroo where+evalKangaroo = liftM fn `oooo` runKangaroo where     fn (a,w,_) = (a,w)  -- state, no answer@@ -90,7 +88,7 @@              -> st               -> FilePath               -> IO st-execKangaroo = liftM state3 `Specs.oooo` runKangaroo +execKangaroo = liftM state3 `oooo` runKangaroo     put :: st -> Kangaroo r w st ()

@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Data.ParserCombinators.KangarooReader--- Copyright   :  (c) Stephen Tetley 2009+-- Copyright   :  (c) Stephen Tetley 2009, 2010 -- License     :  BSD3 -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>@@ -19,7 +19,6 @@     module Data.ParserCombinators.Kangaroo.Combinators   , module Data.ParserCombinators.Kangaroo.ParseMonad   , module Data.ParserCombinators.Kangaroo.Prim-  , module Data.ParserCombinators.Kangaroo.Utils   , Kangaroo   , parse   , runKangaroo@@ -30,7 +29,7 @@ import Data.ParserCombinators.Kangaroo.Combinators import Data.ParserCombinators.Kangaroo.ParseMonad import Data.ParserCombinators.Kangaroo.Prim-import Data.ParserCombinators.Kangaroo.Utils hiding ( (<:>), oo, ooo, oooo )+import Data.ParserCombinators.Kangaroo.Utils  import Control.Monad ( liftM ) 

@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Data.ParserCombinators.KangarooState--- Copyright   :  (c) Stephen Tetley 2009+-- Copyright   :  (c) Stephen Tetley 2009, 2010 -- License     :  BSD3 -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>@@ -19,7 +19,6 @@     module Data.ParserCombinators.Kangaroo.Combinators   , module Data.ParserCombinators.Kangaroo.ParseMonad   , module Data.ParserCombinators.Kangaroo.Prim-  , module Data.ParserCombinators.Kangaroo.Utils   , Kangaroo   , parse   , runKangaroo@@ -35,8 +34,7 @@ import Data.ParserCombinators.Kangaroo.Combinators import Data.ParserCombinators.Kangaroo.ParseMonad import Data.ParserCombinators.Kangaroo.Prim-import Data.ParserCombinators.Kangaroo.Utils hiding ( (<:>), oo, ooo, oooo )-import qualified Data.ParserCombinators.Kangaroo.Utils as Specs+import Data.ParserCombinators.Kangaroo.Utils  import Control.Monad @@ -50,11 +48,11 @@  -- answer, no state evalKangaroo :: Kangaroo st a -> st -> FilePath -> IO (Either ParseErr a)-evalKangaroo = liftM fst `Specs.ooo` runKangaroo+evalKangaroo = liftM fst `ooo` runKangaroo  -- state, no answer execKangaroo :: Kangaroo st a -> st -> FilePath -> IO st-execKangaroo = liftM snd `Specs.ooo` runKangaroo+execKangaroo = liftM snd `ooo` runKangaroo   put :: st -> Kangaroo st ()

@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Data.ParserCombinators.KangarooWriter--- Copyright   :  (c) Stephen Tetley 2009+-- Copyright   :  (c) Stephen Tetley 2009, 2010 -- License     :  BSD3 -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>@@ -19,7 +19,6 @@     module Data.ParserCombinators.Kangaroo.Combinators   , module Data.ParserCombinators.Kangaroo.ParseMonad   , module Data.ParserCombinators.Kangaroo.Prim-  , module Data.ParserCombinators.Kangaroo.Utils   , Kangaroo   , parse   , runKangaroo@@ -30,7 +29,6 @@ import Data.ParserCombinators.Kangaroo.Combinators import Data.ParserCombinators.Kangaroo.ParseMonad import Data.ParserCombinators.Kangaroo.Prim-import Data.ParserCombinators.Kangaroo.Utils hiding ( (<:>), oo, ooo, oooo )  import Data.Monoid 

@@ -0,0 +1,25 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Text.PrettyPrint.JoinPrint+-- Copyright   :  (c) Stephen Tetley 2009+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  to be determined.+--+-- Printing with /join-strings/.+--+--------------------------------------------------------------------------------++module Text.PrettyPrint.JoinPrint+  ( +    module Text.PrettyPrint.JoinPrint.Core+  , module Text.PrettyPrint.JoinPrint.HexDump  +  ) where++import Text.PrettyPrint.JoinPrint.Core+import Text.PrettyPrint.JoinPrint.HexDump+

@@ -0,0 +1,247 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Text.PrettyPrint.JoinPrint.Core+-- Copyright   :  (c) Stephen Tetley 2009-2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  to be determined.+--+-- Printing with /join-strings/.+--+--------------------------------------------------------------------------------++module Text.PrettyPrint.JoinPrint.Core+  ( +    Doc+  , empty+  , null+  , length++  , (<>)+  , (<+>)+  , (<%>)+  , vcat+  , hcat+  , hsep++  , text+  , char+  , int+  , integer+  , integral++  , sglspace+  , dblspace+  , comma+  , semicolon+++  , punctuate+  , enclose+  , squotes+  , dquotes+  , parens+  , brackets+  , braces+  , angles++  , lparen+  , rparen+  , lbracket+  , rbracket+  , lbrace+  , rbrace+  , langle+  , rangle+++  , replicateChar+  , spacer+++  , padl+  , padr+  , truncl +  , truncr+  +  , render+  , renderIO+  +  ) where+++import Text.PrettyPrint.JoinPrint.JoinString ( JoinString, (++) )+import qualified Text.PrettyPrint.JoinPrint.JoinString as JS++import Prelude hiding ( (++), null, length )++newtype Doc = Doc { getDoc :: JoinString }++instance Show Doc where+  show = render+        +infixr 5 <%>+infixr 6 <>, <+>+++empty :: Doc+empty = Doc $ JS.empty++null :: Doc -> Bool+null = JS.null . getDoc +++-- | length on a Doc is O(1).+length :: Doc -> Int+length = JS.length . getDoc+++(<>) :: Doc -> Doc -> Doc+Doc a <> Doc b = Doc $ a ++ b++(<+>) :: Doc -> Doc -> Doc+Doc a <+> Doc b = Doc (a ++ JS.cons1 ' ' b)++(<%>) :: Doc -> Doc -> Doc+Doc a <%> Doc b = Doc (a ++ JS.cons1 '\n' b)++vcat :: [Doc] -> Doc+vcat = foldr (<%>) empty++hcat :: [Doc] -> Doc+hcat = foldr (<>) empty++hsep :: [Doc] -> Doc+hsep = foldr (<+>) empty++++text :: String -> Doc+text = Doc . (JS.text)++char :: Char -> Doc+char = Doc . (JS.text) . return++int :: Int -> Doc+int  = text . show++integer :: Integer -> Doc+integer = text . show++integral :: Integral a => a -> Doc+integral = integer . fromIntegral++sglspace :: Doc+sglspace = char ' '++dblspace :: Doc+dblspace = text "  "++comma :: Doc+comma = char ','++semicolon :: Doc+semicolon = char ';'+++--------------------------------------------------------------------------------++punctuate :: Doc -> [Doc] -> Doc+punctuate _ []     = empty+punctuate _ [x]    = x+punctuate s (x:xs) = x <> s <> punctuate s xs+++enclose :: Doc -> Doc -> Doc -> Doc+enclose l r d = l <> d <> r++squotes :: Doc -> Doc+squotes = enclose (char '\'') (char '\'')++dquotes :: Doc -> Doc+dquotes = enclose (char '"') (char '"')+++parens :: Doc -> Doc+parens = enclose lparen rparen++brackets :: Doc -> Doc+brackets = enclose lbracket rbracket++braces :: Doc -> Doc+braces = enclose lbrace rbrace++angles :: Doc -> Doc+angles = enclose langle rangle++++lparen :: Doc+lparen = char '('++rparen :: Doc+rparen = char ')'++lbracket :: Doc+lbracket = char '['++rbracket :: Doc+rbracket = char ']'++lbrace :: Doc+lbrace = char '{'++rbrace :: Doc+rbrace = char '}'++langle :: Doc+langle = char '<'++rangle :: Doc+rangle = char '>'+++--------------------------------------------------------------------------------++replicateChar :: Int -> Char -> Doc+replicateChar i = Doc . (JS.text) . replicate i++spacer :: Int -> Doc+spacer = replicateChar `flip` ' '+++padl :: Int -> Char -> Doc -> Doc+padl i c d = step (length d) where+  step dl | dl >= i   = d+          | otherwise = replicateChar (i-dl) c <> d ++padr :: Int -> Char -> Doc -> Doc+padr i c d = step (length d) where+  step dl | dl >= i   = d+          | otherwise = d <> replicateChar (i-dl) c+++truncl :: Int -> Doc -> Doc+truncl i d = step (length d) where+    step dl | dl > i    = Doc $ JS.dropLeft i (getDoc d)+            | otherwise = d++truncr :: Int -> Doc -> Doc+truncr i d = step (length d) where+    step dl | dl > i    = Doc $ JS.dropRight i (getDoc d)+            | otherwise = d+++-- | Rendering is simple because there is no notion of fitting.+--+render :: Doc -> String+render = JS.toString . getDoc++++renderIO :: Doc -> IO ()+renderIO = putStrLn . JS.toString . getDoc

@@ -0,0 +1,156 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Text.PrettyPrint.JoinPrint.HexDump+-- Copyright   :  (c) Stephen Tetley 2009-2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  to be determined.+--+-- Hex dumps+--+--------------------------------------------------------------------------------++module Text.PrettyPrint.JoinPrint.HexDump+  ( +    hex+  , hex2+  , hex4+  , hex8+  +  , oxhex+  , oxhex2+  , oxhex4+  , oxhex8++  , hexdump+++  ) where+++import Text.PrettyPrint.JoinPrint.Core++import Data.Char+import Data.List ( unfoldr )+import Data.Word+import Numeric++import Prelude hiding ( length )+import qualified Prelude as Pre+++asterix :: String -> Doc+asterix = text . map (const '*')+++++-- | 'hex' : @i -> Doc@+-- +-- Print @i@ as hexadecimal, no zero padding. +--+-- Negative numbers are printed as a string of asterisks.+-- +hex :: Integral a => a -> Doc+hex i | i >= 0    = text $ showHex i []+      | otherwise = asterix $ showHex (abs i) []+++++hex2 :: Word8 -> Doc+hex2 = padl 2 '0' . text . ($ []) . showHex++hex4 :: Word16 -> Doc+hex4 = padl 4 '0' . text . ($ []) . showHex++hex8 :: Word32 -> Doc+hex8 = padl 8 '0' . text . ($ []) . showHex++-- | 'oxhex' : @pad-length * i -> Doc@+--+-- Print @i@ in hexadecimal, padding with \'0\' to the supplied +-- @pad-length@ and prefixing with \"0x\".+--+-- Negative numbers are printed as a string of asterisks.+-- +oxhex  :: Integral a => Int -> a -> Doc+oxhex plen i +    | i >= 0    = text "0x" <> padl plen '0' (text $ showHex i [])+    | otherwise = text "0x" <> padl plen '*' (asterix $ showHex (abs i) [])++oxhex2 :: Word8 -> Doc+oxhex2 = (text "0x" <>) . hex2++oxhex4 :: Word16 -> Doc+oxhex4 = (text "0x" <>) . hex4++oxhex8 :: Word32 -> Doc+oxhex8 = (text "0x" <>) . hex8++--------------------------------------------------------------------------------++-- This would be better if it didn't need a list in the first +-- place (i.e. it could use an array directly)...++hexdump :: Int -> Int -> [Word8] -> Doc+hexdump start end bs = +    vcat $ aZipWith (hexLine True c1_width, hexLine False c1_width) +                    index_nums+                    segs+  where+    segs       = segment16 (16 - (start `mod` 16)) bs+    c1_width   = 2 +  (Pre.length $ showHex end "")+    index_nums = lineNumbers start end++aZipWith :: (a -> b -> c, a -> b -> c) -> [a] -> [b] -> [c]+aZipWith (f,g) (x:xs) (y:ys) = f x y : zipWith g xs ys+aZipWith _     _      _      = []++++--------------------------------------------------------------------------------++type Width   = Int+type LineNum = Int ++hexLine :: Bool -> Width -> LineNum -> [Word8] -> Doc +hexLine is_initial c1_max n xs = c1 <+> empty <+> c2 <+> c3+  where+    c1  = padl c1_max ' ' (hex n)+    c2  = columnPad is_initial (16*3)   $ hsep $ map hex2 xs+    c3  = columnPad is_initial 16       $ text $ map printable xs+++-- Default is to pad to the right...+--+columnPad :: Bool -> Width -> Doc -> Doc+columnPad pad_left w d = step $ length d where+    step l | l < w = if pad_left then padl w ' ' d else padr w ' ' d+    step _         = d       +                   ++lineNumbers :: Int -> Int -> [Int]+lineNumbers s e = unfoldr phi $ s `div` 16 where+   phi n | n > e     = Nothing+         | otherwise = Just (n,n+16) ++++-- Show 16 bytes per line...+segment16 :: Int -> [a] -> [[a]]+segment16 initial ls = let (top,rest) = splitAt initial ls+                       in top : unfoldr phi rest+  where+    phi [] = Nothing+    phi cs = let (xs,rest) = splitAt 16 cs in Just (xs,rest)+++printable :: Word8 -> Char+printable = fn . chr . fromIntegral where +  fn c | isPrint c = c+       | otherwise = '.'

@@ -0,0 +1,195 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Text.PrettyPrint.JoinPrint.JoinString+-- Copyright   :  (c) Stephen Tetley 2009, 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  to be determined.+--+-- Strings represented as /join lists/ for efficient append.+--+--------------------------------------------------------------------------------++module Text.PrettyPrint.JoinPrint.JoinString+  ( +    JoinString++  , toString+  , empty+  , text +  , cons+  , snoc+  , cons1+  , (++)+  , length  +  , null+  , foldr+  , foldl+  , takeLeft  +  , takeRight+  , dropLeft+  , dropRight++  ) where+++import Data.Monoid+++import qualified Prelude as Pre+import Prelude hiding ( (++), foldl, foldr, length, null )+++data JoinString = Empty +                | Leaf Int String +                | Tree Int JoinString JoinString+  deriving (Eq,Show)++--------------------------------------------------------------------------------++instance Monoid JoinString where+  mempty  = Empty+  mappend = (++)+++empty :: JoinString+empty = Empty++-- | Build a JoinString from a string+--+text :: String -> JoinString+text [] = Empty+text s  = Leaf (Pre.length s) s++cons :: String -> JoinString -> JoinString+cons s xs = text s ++ xs++snoc :: JoinString -> String -> JoinString+snoc xs s = xs ++ text s++-- | Character cons (potentially) efficient if the join string+-- is a leaf.+-- +cons1 :: Char -> JoinString -> JoinString+cons1 c Empty        = Leaf 1 [c]+cons1 c (Leaf i s)   = Leaf (i+1) (c:s)+cons1 c (Tree i t u) = Tree (i+1) (cons1 c t) u+++-- | Concatenate two join strings. Unlike (++) on regular lists, +-- concatenation on join strings is (relatively) cheap hence the +-- name /join list/.+--+(++) :: JoinString -> JoinString -> JoinString+Empty ++ ys    = ys+xs    ++ Empty = xs+xs    ++ ys    = Tree (length xs + length ys)  xs ys+++length :: JoinString -> Int+length Empty        = 0+length (Leaf i _)   = i+length (Tree i _ _) = i++null :: JoinString -> Bool+null Empty = True+null _     = False+++toString :: JoinString -> String+toString = foldr (flip (Pre.++)) ""+++-- | Right-associative fold of a JoinString.+--+foldr :: (String -> b -> b) -> b -> JoinString -> b+foldr _ e Empty         = e+foldr f e (Leaf _ xs)   = f xs e+foldr f e (Tree _ t u)  = foldr f (foldr f e t) u+++-- | Left-associative fold of a JoinString.+--+foldl :: (b -> String -> b) -> b -> JoinString -> b+foldl _ e Empty         = e+foldl f e (Leaf _ xs)   = f e xs+foldl f e (Tree _ t u)  = foldl f (foldl f e u) t++-- | 'takeLeft'  flattens the join-string.+--+takeLeft :: Int -> JoinString -> JoinString+takeLeft = build `oo` step where+    build (i,xs) | i <= 0           = Empty+                 | otherwise        = Leaf i xs++    step :: Int -> JoinString -> (Int,String)+    step _ Empty                    = (0,"")+    step n (Leaf i xs)  | n >= i    = (i,xs) +                        | otherwise = (n,Pre.take n xs)+    step n (Tree _ t u)             = let (i,ls) = step n t in+                                      if i<n then let (j,rs) = step (n-i) u in +                                                  (i+j,ls Pre.++ rs)+                                             else (i,ls)+ +-- | 'takeRight'  flattens the join-string.+--+takeRight :: Int -> JoinString -> JoinString+takeRight = build `oo` step where+    build (i,xs) | i <= 0           = Empty+                 | otherwise        = Leaf i xs++    step :: Int -> JoinString -> (Int,String)+    step _ Empty                    = (0,"")+    step n (Leaf i xs)  | n >= i    = (i,xs) +                        | otherwise = (n,ltr n xs)+    step n (Tree _ t u)             = let (i,rs) = step n u in+                                      if i<n then let (j,ls) = step (n-i) t in +                                                  (i+j,ls Pre.++ rs)+                                             else (i,rs)+ + +++ltr :: Int -> [a] -> [a]+ltr n = ($ []) . snd . Pre.foldr fn (0,id) where+  fn e (i,f) | i < n      = (i+1, (e:) . f)+             | otherwise  = (i,f)++++dropLeft :: Int -> JoinString -> JoinString+dropLeft = snd `oo` step where+    step n Empty                    = (n,Empty)+    step n (Leaf a xs)  | n >= a    = (n-a,Empty)       -- drop all+                        | otherwise = (0,Leaf (a-n) (drop n xs))+    step n (Tree a t u) | n >= a    = (n-a,Empty)+                        | otherwise = let (n',t') = step n t in +                                      if n' > 0 then step n' u+                                                else (0,mkTree (a-n) t' u)+    mkTree _ Empty u    = u+    mkTree n t     u    = Tree n t u+++dropRight :: Int -> JoinString -> JoinString +dropRight = snd `oo` step where+    step n Empty                    = (n,Empty)+    step n (Leaf a xs)  | n >= a    = (n-a,Empty)       -- drop all+                        | otherwise = (0,Leaf (a-n) (take (a-n) xs))+    step n (Tree a t u) | n >= a    = (n-a,Empty)+                        | otherwise = let (n',u') = step n u in+                                      if n' > 0 then step n' t+                                                else (0, mkTree (a-n) t u')+    +    mkTree _ t Empty    = t+    mkTree n t u        = Tree n t u +++--------------------------------------------------------------------------------+-- ++oo :: (c -> d) -> (a -> b -> c) -> a -> b -> d+oo f g r s = f (g r s)

@@ -17,7 +17,7 @@ module Picklers where  -import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString as BS import Data.Char import Data.List ( foldl' ) import Data.Word@@ -36,15 +36,22 @@   where rpkl = BS.reverse $ getRevBS pkl   -cons :: Char -> Pickle -> Pickle+cons :: Word8 -> Pickle -> Pickle cons c = RevBS . BS.cons c . getRevBS   putCString :: String -> Pickle -> Pickle-putCString s pkl = putWord8 0 $ foldl' (flip cons) pkl s+putCString s pkl = putWord8 0 $ foldl' (flip putChar8) pkl s  putWord8 :: Word8 -> Pickle -> Pickle-putWord8 w = cons (chr $ fromIntegral w)+putWord8 = cons  +putChar8 :: Char -> Pickle -> Pickle+putChar8 ch = cons (fromIntegral $ ord ch)+ -- TODO  cstring :: String -> Pickle cstring = putCString `flip` empty +++string :: String -> Pickle+string = foldl' (flip putChar8) empty