kangaroo 0.3.0 → 0.4.0

raw patch · 17 files changed

+691/−761 lines, 17 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• demo/AR.hs +208/−0
• demo/MidiDatatypes.hs +0/−252
• demo/MidiRead.hs +0/−216
• demo/MidiText.hs +0/−137
• demo/PrintMidi.hs +0/−39
• kangaroo.cabal +17/−13
• src/Data/ParserCombinators/Kangaroo.hs +3/−1
• src/Data/ParserCombinators/Kangaroo/Debug.hs +9/−5
• src/Data/ParserCombinators/Kangaroo/ParseMonad.hs +18/−2
• src/Data/ParserCombinators/KangarooRWS.hs +23/−0
• src/Data/ParserCombinators/KangarooReader.hs +27/−7
• src/Data/ParserCombinators/KangarooState.hs +46/−4
• src/Data/ParserCombinators/KangarooWriter.hs +2/−0
• src/Text/PrettyPrint/JoinPrint.hs +5/−0
• src/Text/PrettyPrint/JoinPrint/Core.hs +261/−18
• src/Text/PrettyPrint/JoinPrint/HexDump.hs +72/−10
• test/Picklers.hs +0/−57

@@ -0,0 +1,208 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  AR+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  volatile+-- Portability :  to be determined.+--+-- AR archive files. +--+--------------------------------------------------------------------------------++module AR where++import Data.ParserCombinators.KangarooWriter+import qualified Text.PrettyPrint.JoinPrint as PP+++import Control.Exception+import Control.Monad+import Data.Char+import Prelude hiding ( catch )+import System.Environment+import System.Exit+++type Parser a = Kangaroo String a    ++main :: IO ()+main = do +  args <- getArgs+  case args of+    [path] -> process path+    _ ->  putStrLn "Usage: AR <filename>"++process :: FilePath -> IO ()+process filename = do+    ans <- catch (readAR filename) exitHandle+    printArchive ans+  where+    exitHandle :: IOException -> IO a +    exitHandle e = putStrLn (show e) >> exitFailure+++readAR :: FilePath -> IO ArArchive+readAR filename = do +   (a,w) <- runKangaroo arArchive filename+   putStrLn w+   either error return a+++data ArArchive = ArArchive +      { ar_magic                    :: String+      , ar_objects                  :: [ArchiveObject]+      }+  deriving Show+++data ArchiveObject = ArchiveObject+     { ar_header                    :: ArHeader+     , ar_body                      :: (Int,Int)+     }++data ArHeader = ArHeader +      { arh_name                    :: String+      , arh_date                    :: String+      , arh_user_id                 :: Int+      , arh_group_id                :: Int+      , arh_mode                    :: String+      , arh_size                    :: Int+      , arh_trailer                 :: String+      }  +  deriving Show++++instance Show ArchiveObject where+  show (ArchiveObject h _) = "ArchiveObject " ++ show h++++++++arArchive :: Parser ArArchive+arArchive = do+    magic    <- arMagicString+    objects  <- runOn archiveObject+    return $ ArArchive +                { ar_magic        = magic+                , ar_objects      = objects+                }+++arMagicString :: Parser String+arMagicString = text 8 +++archiveObject :: Parser ArchiveObject+archiveObject = do +    header  <- arHeader+    let sz  = arh_size header+    pos     <- position+    skip sz+    end_pos     <- position+    when (end_pos `mod` 2 /= 0) (anyChar >> return ())   -- should be a newline +    +    -- ... silly debug (show off hexdump)+    printHexRange $ limit (pos,pos+sz)+    liftIOAction  $ putStrLn ""+    -- ... end silly++    return $ ArchiveObject +                { ar_header         = header+                , ar_body           = (pos,sz)+                }+  where+    limit (x,y) = (x, min y (x+200))+++paddedNumber :: (Read a, Integral a) => Int -> Parser a+paddedNumber i = liftM fn $ count i anyChar+  where+    fn = read . takeWhile isDigit+++arHeader :: Parser ArHeader+arHeader = do +    name    <- text 16+    date    <- text 12+    uid     <- paddedNumber 6+    gid     <- paddedNumber 6+    mode    <- text 8+    size    <- paddedNumber 10+    trailer <- text 2+    return $ ArHeader +                { arh_name            = name+                , arh_date            = date+                , arh_user_id         = uid+                , arh_group_id        = gid+                , arh_mode            = mode+                , arh_size            = size+                , arh_trailer         = trailer+                }  +++--------------------------------------------------------------------------------+-- pretty print++printArchive :: ArArchive -> IO ()+printArchive = putStr . archiveText++++archiveText :: ArArchive -> String+archiveText = show . ppArchive++ppArchive :: ArArchive -> PP.VDoc+ppArchive a = mgc `PP.vcons` body+  where+    mgc  = PP.text $ ar_magic a+    body = PP.vconcatSep $ map ppArchiveObject $ ar_objects a++++ppArchiveObject :: ArchiveObject -> PP.VDoc+ppArchiveObject = ppArHeader . ar_header++ppArHeader :: ArHeader -> PP.VDoc+ppArHeader a = PP.vcat $ column_headings : column_sep : sequence fields a+  where+    ppf    = ppField 4 14+    fields = +       [ ppf 16 "name"                  (PP.text . arh_name)+       , ppf 12 "date"                  (PP.text . arh_date)+       , ppf 6  "user id"               (PP.int  . arh_user_id)+       , ppf 6  "group id"              (PP.int  . arh_group_id)+       , ppf 8  "mode"                  (PP.text . arh_mode)+       , ppf 10 "size"                  (PP.int  . arh_size)+       , ppf 2  "trailer"               (tup2    . arh_trailer)+       ]+    tup2 (x:y:xs)   = PP.hsep [ hexpp x, hexpp y, PP.text xs]+    tup2 xs         = PP.text xs++    hexpp           = PP.hex2 . fromIntegral . ord++    column_headings = PP.hsep [ PP.text "size"+                              , PP.padl 14 ' ' (PP.text "field") +                              , PP.padr 16 ' ' (PP.text "value")+                              ]++    column_sep      = PP.replicateChar 60 '-' ++--------------------------------------------------------------------------------+-- Helpers++ppField :: Int -> Int -> Int -> String -> (a -> PP.Doc) -> a -> PP.Doc+ppField n1 n2 sz field_name f a = PP.hsep [sz', field_name', f a]+  where+    sz'         = PP.padl n1 ' ' (PP.text $ show sz)+    field_name' = PP.padl n2 ' ' (PP.text field_name)++

@@ -1,252 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  MidiDatatypes--- Copyright   :  (c) Stephen Tetley 2009--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  volatile--- Portability :  to be determined.------ Syntax tree for MIDI files.---------------------------------------------------------------------------------------module MidiDatatypes (-    -- * MidiFile representation-    MidiFile(..),-    -- * File header with basic information-    Header(..),-    -- * Track - a series of events-    Track(..),-    -- * Header format-    HFormat(..),-    -    DeltaTime,--    -- * A midi event paired with the delta time of its onset-    Message, -    -- * A control or meta event-    Event(..),-    -    VoiceEvent(..),-    SystemEvent(..),-    MetaEvent(..),-    -    -- * Representation of delta times as a division of quarter notes-    TimeDivision(..),-    -- * Type of a text meta-event-    TextType(..),-    -    -- * Scale type - used for setting key signature-    ScaleType(..),-    -    -- * Two helpers-    varlenSplit, hexStr-    -  ) where--import Data.Bits-import Data.Int-import Data.Sequence-import Data.Word-import Numeric (showHex)----data MidiFile = MidiFile Header (Seq Track)-  deriving (Eq,Show)---- | @'Header' fmt nt td@ ------ @fmt@ - file format - see @'HFormat'@, --- @nt@  - number of tracks,--- @td@  - @'TimeDivision'@, often 384 or 480 ticks per beat.--- The header is the start of a MIDI file, it is indicated by the --- marker \'@MThd@\'.   -data Header = Header HFormat Word16 TimeDivision-  deriving (Eq,Show)---- | @'Track' xs@ ------ @xs@ - list of @'Message'@. In MIDI files, the start of a track is--- indicated by the marker \'@MTrk@\'.  -newtype Track = Track { getTrack :: Seq Message }-  deriving (Eq,Show)---- | @'HFormat'@ ------ The file format - in a MIDI file this is a big-endian word16 with 0,1 or 2--- being the only valid values. -data HFormat -    -- | Format 0 file - single multi-channel track.-    = MF0 -    -- | Format 1 file - 1 or more tracks, played simultaneously.-    | MF1-    -- | Format 2 file - 1 or more independent tracks.-    | MF2-  deriving (Eq, Enum, Show) ---- | @'TimeDivision'@ ------ Defines the default unit of time in the MIDI file.-data TimeDivision -    -- | frames per second.-    = FPS Word16-    -- | ticks per beat, i.e. the number of units for a quater note.-    | TPB Word16    -  deriving (Eq,Show)-                                             --- | @'TextType'@ ------ Signal the type of a text meta event.-data TextType -    = GENERIC_TEXT -    | COPYRIGHT_NOTICE -    | SEQUENCE_NAME -    | INSTRUMENT_NAME-    | LYRICS -    | MARKER -    | CUE_POINT -  deriving (Eq,Enum,Ord,Show) ---- | @'DeltaTime'@ ------ All time values in a MIDI track are represented as a \delta\ from the --- previous event rather than an absolute time. --- Although DeltaTime is a type synonym for Word32, in MIDI files it is --- represented as a @varlen@ to save space. -type DeltaTime = Word32---- | @'Message'@ ------ MIDI messages are pairs of @'DeltaTime'@ and @'Event'@ wrapped in a newtype. --- Sequential messages with delta time 0 will be played simultaneously.  -type Message = (DeltaTime, Event)----- Note, the Ord instance for pairs is very useful for rendering.--- When we have have a NoteOn and a NoteOff on the same channel at the --- same time we want the NoteOff played first. An ordinary sort will --- give us this.--     ----- | @'Event'@ ------ MIDI has three types of event.-data Event -    -- | Meta events - usually interpretable (e.g. @end-of-track@, @set-tempo@).-    = MetaEvent         MetaEvent-    -- | SysEx - system exclusive - events. Usually synthesizer specific.-    | SystemEvent       SystemEvent-    -- | Voice events (e.g @note-on@, @note-off@) are relayed to specific-    -- channels.-    | VoiceEvent        VoiceEvent    -  deriving (Eq,Show,Ord)---- | @'VoiceEvent'@ ------ Voice events control the output of the synthesizer.--- Note - these are not in the the same order as there byte values--- Controller and ProgramChange are higher than they /naturally/--- occur so the will come first after a comparison / sort.-data VoiceEvent -    -- | @Controller chan type value@ - controller change to the channel,-    -- e.g. by a footswitch.-    = Controller          Word8 Word8 Word8-    -- | @ProgramChange chan num@ - change the instrument playing on the -    -- specified channel. See 'GMInst' for the instruments available with-    -- General MIDI.-    | ProgramChange       Word8 Word8-    -- | @NoteOff chan note velocity@ - turn off a sounding note.-    | NoteOff             Word8 Word8 Word8   -    -- | @NoteOn chan note velocity@ - start playing a note.-    | NoteOn              Word8 Word8 Word8-    -- | @NoteAftertouch chan note value@ - change in pressure applied to -    -- the synthesizer key. -    | NoteAftertouch      Word8 Word8 Word8     -    -- | @ChanAftertouch chan value@ - -    | ChanAftertouch      Word8 Word8-    -- | @PitchBend chan value@ - change the pitch of a sounding note. -    -- Often used to approxiamate microtonal tunings.-    | PitchBend           Word8 Word16-  deriving (Eq,Show,Ord)---- | @'SystemEvent'@ ------ \SysEx\ events - these are generally uninterpreted. -data SystemEvent -    -- | @SysEx length data@ - an uninterpreted sysex event.          -    = SysEx               Word32 [Word8]-    -- | @DataEvent value@ - value should be in the range 0..127.-    | DataEvent           Word8 -  deriving (Eq,Show,Ord)---- | @'MetaEvent'@ ------ Meta events - in Format 1 files \general\ events (e.g. text events) should--- only appear in track 1. \Specific\ events (e.g. end-of-track) should appear--- in any track where necessary. -data MetaEvent-    -- | @TextEvent text_type contents@ - a free text field (e.g. copyright).-    -- The contents can notionally be any length.-    = TextEvent           TextType String-    -- | @SequenceNumber value@ - Format 1 files - only track 1 should have a -    -- sequence number. Format 2 files - a sequence number should identify -    -- each track. -    -- This should occur at the start of a track, before any non-zero time -    -- events.-    | SequenceNumber      Word16-    -- | @ChannelPrefix chan@ - relay all meta and sysex events to the -    -- given channel.-    | ChannelPrefix       Word8-    -- | @EndOfTrack@ - indicated end of track. -    | EndOfTrack-    -- | @SetTempo mspqn@ - microseconds per quarter-note.-    | SetTempo            Word32-    -- | @SMPTEOffset hour  minute second frac subfrac@ - the SMPTE time when -    -- a track should start. This should occur at the start of a track,-    -- before any non-zero time events.-    | SMPTEOffset         Word8 Word8 Word8 Word8 Word8-    -    -- | @TimeSignature numerator denominator metro num-32nd-notes@ - time -    -- signature.-    | TimeSignature       Word8 Word8 Word8 Word8-    -    -- | @KeySignature key_type scale_type@ - key_type is the number of -    -- sharps (postive numbers) or flats (negative numbers), -    -- e.g. (-1) is 1 flat.-    -- 'ScaleType' indicates major or minor.  -    | KeySignature        Int8 ScaleType-    -    -- | @SSME length data@ - sequencer specific meta-event.-    | SSME                Word32 [Word8]-  deriving (Eq,Show,Ord)---- | @'ScaleType'@ ------ Scale type - @major@ or @minor@.  -data ScaleType = MAJOR | MINOR-  deriving (Eq,Enum,Ord,Show)------------------------------------------------------------------------------------- helper for varlen------------------------------------------------------------------------------------ | @varlenSplit@ - reduce a varlen into a list of Word8. -varlenSplit :: Word32 -> [Word8]-varlenSplit i | i < 0x80        = [fromIntegral i]-              | i < 0x4000      = [wise i 7, wise i 0]-              | i < 0x200000    = [wise i 14, wise i 7, wise i 0] -              | otherwise       = [wise i 21, wise i 14, wise i 7, wise i 0] -  where         -    wise m 0 = fromIntegral $ m .&. 0x7F-    wise m n = fromIntegral $ m `shiftR` n   .&.  0x7F  .|.  0x80;-    --hexStr :: (Integral a) => a -> String-hexStr i = (showString "0x" . showHex i) "" 

@@ -1,216 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  MidiRead--- Copyright   :  (c) Stephen Tetley 2009-2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  volatile--- Portability :  to be determined.------ A MIDI file parser. --------------------------------------------------------------------------------------module MidiRead (-    -- * Read a MIDI file-    -- $readmididoc-    readMidi-  ) where--import MidiDatatypes--import Data.ParserCombinators.KangarooWriter-import Data.ParserCombinators.Kangaroo.Utils---import Control.Applicative-import Control.Monad-import Data.Bits-import Data.Sequence ( Seq , (<|) )-import qualified Data.Sequence as S-import Data.Word--type MidiParser a = Kangaroo String a---readMidi :: FilePath -> IO MidiFile  -readMidi filename = do -   (a,w) <- runKangaroo midiFile filename-   putStrLn w-   either error return a-    ------------------------------------------------------------------------------------- ---- Not sure about this ... -(-*-) :: MidiParser a -> String -> MidiParser a-(-*-) = substError-    -midiFile :: MidiParser MidiFile  -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"                -*- "header"-                 *> assertWord32 (6::Int)               -*- "length"-                 *> format                              -*- "format")-                <*> word16be                            -*- "num tracks"-                <*> timeDivision                        -*- "time division"--countS :: Int -> MidiParser a -> MidiParser (Seq a)-countS = genericCount (<|) S.empty ---track :: MidiParser Track-track = liftM Track (trackHeader >>= getMessages)--trackHeader :: MidiParser Word32-trackHeader = assertString "MTrk" >> word32be--getMessages :: Word32 -> MidiParser (Seq Message)-getMessages i = restrict "messages" Alfermata (fromIntegral i) messages-  where    -    messages = genericRunOn (<|) S.empty message--message :: MidiParser Message-message = pairA deltaTime (uncurry next =<< word8split)-  where  -    next code chan  -        | code == 0xF && chan == 0xF  = MetaEvent   <$> (word8 >>= metaEvent)         -        | code == 0xF                 = SystemEvent <$> systemEvent-        | code >= 0x8 && code <  0xF  = VoiceEvent  <$> voiceEvent code chan-        | otherwise                   = reportError $ unwords -                                          [ "unrecognized message "-                                          , hexStr ((code `shiftL` 4) + chan)-                                          , "code:"-                                          , hex2 code []-                                          , "chan:"-                                          , hex2 chan []-                                          ]----deltaTime :: MidiParser Word32-deltaTime = getVarlen-   -voiceEvent :: Word8 -> Word8 -> MidiParser VoiceEvent-voiceEvent 0x8 ch = (NoteOff ch)        <$> word8 <*> word8-voiceEvent 0x9 ch = (NoteOn ch)         <$> word8 <*> word8-voiceEvent 0xA ch = (NoteAftertouch ch) <$> word8 <*> word8-voiceEvent 0xB ch = (Controller ch)     <$> word8 <*> word8-voiceEvent 0xC ch = (ProgramChange ch)  <$> word8 -voiceEvent 0xD ch = (ChanAftertouch ch) <$> word8 -voiceEvent z   _  = reportError $ "voiceEvent " ++ hexStr z -----metaEvent :: Word8 -> MidiParser MetaEvent-metaEvent 0x00 = SequenceNumber   <$> (assertWord8 2     *> word16be)-metaEvent 0x01 = textEvent GENERIC_TEXT -metaEvent 0x02 = textEvent COPYRIGHT_NOTICE-metaEvent 0x03 = textEvent SEQUENCE_NAME-metaEvent 0x04 = textEvent INSTRUMENT_NAME-metaEvent 0x05 = textEvent LYRICS-metaEvent 0x06 = textEvent MARKER-metaEvent 0x07 = textEvent CUE_POINT-metaEvent 0x2F = EndOfTrack       <$   assertWord8 0  -metaEvent 0x51 = SetTempo         <$> (assertWord8 3     *> word24be)-metaEvent 0x54 = SMPTEOffset      <$> (assertWord8 5     *> word8) -                                  <*> word8             <*> word8-                                  <*> word8             <*> word8-metaEvent 0x58 = TimeSignature    <$> (assertWord8 4     *> word8)-                                  <*> word8             <*> word8 -                                  <*> word8 -metaEvent 0x59 = KeySignature     <$> (assertWord8 2     *> int8) -                                  <*> scale-metaEvent 0x7F = (uncurry SSME)   <$> getVarlenBytes     -metaEvent z    = reportError $ "unreconized meta-event " ++ hexStr z---systemEvent :: MidiParser SystemEvent-systemEvent = (uncurry SysEx) <$> getVarlenBytes-                      -                          -format :: MidiParser HFormat-format = word16be >>= fn -  where -    fn 0 = return MF0-    fn 1 = return MF1-    fn 2 = return MF2-    fn z = reportError $ -              "getFormat - unrecognized file format " ++ hexStr z-        -timeDivision :: MidiParser TimeDivision-timeDivision = division <$> word16be-  where division i | i `testBit` 15 = FPS (i `clearBit` 15)-                   | otherwise      = TPB i---scale :: MidiParser ScaleType-scale = word8 >>= fn -  where-    fn 0 = return MAJOR-    fn 1 = return MINOR-    fn z = reportError $ "scale expecting 0 or 1, got " ++ hexStr z-    -    -textEvent :: TextType -> MidiParser MetaEvent-textEvent ty = (TextEvent ty . snd) <$> getVarlenText------------------------------------------------------------------------------------- helpers--{---- enumerate doesn't really seem worth it for scale etc... -enumerate :: Integral a => [ans] -> a -> String -> MidiParser ans-enumerate []     _ msg = reportError msg-enumerate (x:xs) i msg | i == 0    = return x-                       | otherwise = enumerate xs (i-1) msg---}----word8split :: MidiParser (Word8,Word8) -word8split = split <$> word8 -  where-    split i = ((i .&. 0xF0) `shiftR` 4, i .&. 0x0F)-- -assertWord8 :: Word8 -> MidiParser Word8-assertWord8 i = postCheck word8 (==i) msg-  where -    msg = "assertWord8 - input did not match " ++ show i-             -assertWord32 :: Integral a => a -> MidiParser Word32-assertWord32 i = postCheck word32be ((==i) . fromIntegral) msg-  where-    msg = "assertWord32 - input did not match " ++ show i--assertString :: String -> MidiParser String-assertString s = postCheck (text $ length s) (==s) msg-  where-    msg = "assertString - input did not match " ++ s---getVarlenText :: MidiParser (Word32,String)  -getVarlenText = countPrefixed getVarlen anyChar--getVarlenBytes :: MidiParser (Word32,[Word8]) -getVarlenBytes = countPrefixed getVarlen word8---getVarlen :: MidiParser Word32-getVarlen = buildWhile (`testBit` 7) merge merge 0 word8-  where-    merge i acc = (acc `shiftL` 7) + ((fromIntegral i) .&. 0x7F)-   --

@@ -1,137 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  MidiText--- Copyright   :  (c) Stephen Tetley 2009-2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  volatile--- Portability :  to be determined.------ Pretty print a textual representaton of MIDI files. ---------------------------------------------------------------------------------------module MidiText (-    -- * Print a midi file to stdout-    printMidi--  ) where---import MidiDatatypes-import Text.PrettyPrint.JoinPrint hiding ( length )---import qualified Data.Foldable as F-import Data.Word--void :: Monad m => m a -> m ()-void mf = mf >> return ()---printMidi :: MidiFile -> IO ()-printMidi (MidiFile hdr tracks)  = do -   header hdr -   void $ F.foldlM (\i t -> track i t >> return (i+1)) 0 tracks---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"-ppHFormat MF1  = text "Type 1"-ppHFormat MF2  = text "Type 2"- -ppTimeDivision :: TimeDivision -> Doc-ppTimeDivision (FPS i)   = text "fps"   <+> integral i-ppTimeDivision (TPB i)   = text "ticks" <+> integral i--track :: Int -> Track -> IO ()-track i (Track se) = do -    renderIO $ brackets (text "Track" <+> int i) -    void $ F.foldlM fn 0 se-  where-    fn gt (dt,evt)  = let (name,d) =  event evt in-                      do { renderIO $ mkEvent gt dt name d -                         ; return (gt+dt)-                         }---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)---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 = padl 3 ' ' . integral--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])--  --systemEvent :: SystemEvent -> EventDescr-systemEvent (SysEx _ _)    = ("sysex", empty)   -systemEvent (DataEvent i)  = ("data",  oxhex2 i)--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 "...")--dashInts :: Integral a => [a] -> Doc-dashInts = punctuate (text " - ") . map fli---scaleType :: ScaleType -> String-scaleType MAJOR  = "major"-scaleType MINOR  = "minor"-  -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-

@@ -1,39 +0,0 @@-{-# OPTIONS -Wall #-}----- shell> ghc --make PrintMIDI.hs ------ shell> runhaskell.exe PrintMIDI.hs bulgarian6.mid----module Main where---import MidiRead-import MidiText---import Control.Exception-import Prelude hiding (catch)--import System.Environment-import System.Exit---main :: IO ()-main = do -  args <- getArgs-  case args of-    [path] -> process path-    _ ->  putStrLn "Usage: MidiPrint <filename>"--process :: FilePath -> IO ()-process filename = do-    ans <- catch (readMidi filename) exitHandle-    printMidi ans-  where-    exitHandle :: IOException -> IO a -    exitHandle e = putStrLn (show e) >> exitFailure-- 

@@ -1,5 +1,5 @@ name:             kangaroo-version:          0.3.0+version:          0.4.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -18,18 +18,26 @@   \* Caveat \* - the above of course means that the target file    is obliged to be small enough to fit into memory.    .-  \*\* MAJOR CAVEAT \*\* - kangaroo is somewhat half-baked at the-  moment - the parsing machinery seems good but the combinators-  and primitive parsers need more work. I\'ve only released it on -  Hackage because I'm now using it with Hurdle which was already -  on Hackage.+  \*\* MAJOR CAVEAT \*\* - kangaroo is somewhat half-baked (maybe +  now two thirds baked). The parsing machinery seems good but the +  combinators need more work. It\'s on Hackage because I'm using +  it with Hurdle which was already on Hackage and the techinique+  of moving a cursor rather than consuming input seems at least +  interesting.   .   Currently kangaroo is twinned with its own library of formatting-  combinators, at some point this is likely to be put into its -  own package+  combinators (JoinPrint), at some point this is may go in its a +  separate package.   .   Changelog:   .+  0.4.0 Changed JoinPrint to have distinct types for single-line+  documents (Doc) and multi-line documents (VDoc). This is +  because single-line docs track their horizontal length.+  .+  Added a 'skip' primitive to the Parse Monad. Added 'local' and+  'asks' to the Reader top-level modules.+  .   0.3.0 Documented the primitive parsers. @char@ renamed @anyChar@   to match Parsec\'s convention. Rationalized exports from    ParseMonad module.@@ -45,11 +53,7 @@ cabal-version:      >= 1.2  extra-source-files:-  demo/MidiDatatypes.hs-  demo/MidiRead.hs-  demo/MidiText.hs-  demo/PrintMidi.hs-  test/Picklers.hs+  demo/AR.hs   library

@@ -41,6 +41,7 @@   , satisfy   , checkWord8   , opt +  , skip    -- * Query the cursor position   , position@@ -58,8 +59,9 @@       -- * Debug   , printHexAll+  , printHexRange   , printRegionStack -+     , module Data.ParserCombinators.Kangaroo.Combinators   , module Data.ParserCombinators.Kangaroo.Prim 

@@ -16,8 +16,9 @@  module Data.ParserCombinators.Kangaroo.Debug   (-    slowHexAll-  +    debugHexAll+  , debugHexRange+   ) where  @@ -26,7 +27,10 @@ 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+debugHexAll :: IOUArray Int Word8 -> IO ()+debugHexAll arr = getBounds arr    >>= \(s,e) -> +                 hexdumpA s e arr >>= (putStrLn . show) ++debugHexRange :: (Int,Int) -> IOUArray Int Word8 -> IO ()+debugHexRange (s,e) arr = hexdumpA s e arr >>= (putStrLn . show)

@@ -46,6 +46,7 @@   , satisfy   , checkWord8   , opt +  , skip    -- * Query the cursor position   , position@@ -64,6 +65,7 @@   -- * Debug   , printHexAll   , printRegionStack +  , printHexRange    ) where @@ -339,7 +341,18 @@       (Left _, _, ust')    -> return (Right Nothing, st, ust')       (Right a, st', ust') -> return (Right $ Just a, st', ust') -+-- | 'skip' : @ num_bytes -> () @+--+-- Move the cursor forward by the supplied distance. The distance+-- must be positive, negative distances are ignored.+--+-- 'skip' performs no range checking. If the cursor is +-- moved beyond the region boundary then the next parse will +-- fail.+--+skip :: Int -> GenKangaroo ust ()+skip n | n <= 0 = return ()+skip n          = modifyPos (n+)   --------------------------------------------------------------------------------@@ -488,7 +501,10 @@ -- Debug  printHexAll         :: GenKangaroo ust ()-printHexAll         = askEnv >>= liftIOAction . slowHexAll+printHexAll         = askEnv >>= liftIOAction . debugHexAll++printHexRange       :: (Int,Int) -> GenKangaroo ust ()+printHexRange rng   = askEnv >>= liftIOAction . (debugHexRange rng)  printRegionStack    :: GenKangaroo ust () printRegionStack    = getSt >>= liftIOAction . putStrLn . printParseStack

@@ -27,6 +27,8 @@   , gets   , tell   , ask+  , asks+  , local    -- Re-exports from ParseMonad   -- * Parser types@@ -49,6 +51,7 @@   , satisfy   , checkWord8   , opt +  , skip    -- * Query the cursor position   , position@@ -66,6 +69,7 @@       -- * Debug   , printHexAll+  , printHexRange   , printRegionStack     , module Data.ParserCombinators.Kangaroo.Combinators@@ -146,5 +150,24 @@ tell :: Monoid w => w -> Kangaroo r w st () tell s = getUserSt >>= \(r,w,st) -> putUserSt (r,w `mappend` s,st) +-- | Retrieve the environment.+-- ask :: Kangaroo r w st r ask = liftM env3 getUserSt++asks :: (r -> a) -> Kangaroo r w st a+asks f = liftM (f . env3) getUserSt++++-- | Execute a computation in a modified environment.+--+local :: (r -> r) -> Kangaroo r w st a -> Kangaroo r w st a+local upd ma = do +    st@(e,_,_)  <- getUserSt +    putUserSt $ fmap3a upd st+    ans <- ma+    putUserSt $ fmap3a (const e) st+    return ans+  where+    fmap3a f (a,b,c) = (f a,b,c)

@@ -23,6 +23,8 @@   , parse   , runKangaroo   , ask+  , asks+  , local    -- Re-exports from ParseMonad   -- * Parser types@@ -45,6 +47,7 @@   , satisfy   , checkWord8   , opt +  , skip    -- * Query the cursor position   , position@@ -52,7 +55,7 @@   , atEnd   , lengthRemaining   , regionSize-+    -- * Parse within a region   , intraparse   , advance@@ -62,6 +65,7 @@       -- * Debug   , printHexAll+  , printHexRange   , printRegionStack   @@ -76,20 +80,36 @@  import Control.Monad ( liftM ) -type Kangaroo e a = GenKangaroo e a+type Kangaroo r a = GenKangaroo r a  -parse :: Kangaroo e a  -      -> e+parse :: Kangaroo r a+      -> r       -> FilePath        -> IO (Either ParseErr a) parse = runKangaroo  -runKangaroo :: Kangaroo e a-            -> e+runKangaroo :: Kangaroo r a+            -> r             -> FilePath              -> IO (Either ParseErr a) runKangaroo p env filename = liftM fst (runGenKangaroo p env filename) -ask :: Kangaroo e e+-- | Retrieve the environment.+--+ask :: Kangaroo r r ask = getUserSt++asks :: (r -> a) -> Kangaroo r a+asks f = liftM f getUserSt++-- | Execute a computation in a modified environment.+--+local :: (r -> r) -> Kangaroo r a -> Kangaroo r a+local f ma = do +    e  <- getUserSt +    putUserSt (f e)+    ans <- ma+    putUserSt e+    return ans+

@@ -16,10 +16,7 @@  module Data.ParserCombinators.KangarooState   (-    module Data.ParserCombinators.Kangaroo.Combinators-  , module Data.ParserCombinators.Kangaroo.ParseMonad-  , module Data.ParserCombinators.Kangaroo.Prim-  , Kangaroo+    Kangaroo   , parse   , runKangaroo   , evalKangaroo@@ -28,6 +25,51 @@   , get   , modify   , gets++  -- Re-exports from ParseMonad+  -- * Parser types+  , ParseErr++  -- * Region types+  , RegionCoda(..)+  , RegionName    +++  -- * Lift IO actions+  , liftIOAction++  -- * Error reporting and exception handling+  , reportError+  , substError++  -- * Primitive parsers+  , word8+  , satisfy+  , checkWord8+  , opt +  , skip++  -- * Query the cursor position+  , position+  , region+  , atEnd+  , lengthRemaining+  , regionSize++  -- * Parse within a region+  , intraparse+  , advance+  , advanceRelative+  , restrict+  , restrictToPos+   +  -- * Debug+  , printHexAll+  , printHexRange+  , printRegionStack ++  , module Data.ParserCombinators.Kangaroo.Combinators+  , module Data.ParserCombinators.Kangaroo.Prim    ) where 

@@ -43,6 +43,7 @@   , satisfy   , checkWord8   , opt +  , skip    -- * Query the cursor position   , position@@ -60,6 +61,7 @@       -- * Debug   , printHexAll+  , printHexRange   , printRegionStack     , module Data.ParserCombinators.Kangaroo.Combinators

@@ -12,6 +12,11 @@ -- -- Printing with /join-strings/. --+-- Note - JoinPrint is just a formatter and not a \'pretty printer\'. +-- No line fitting takes place - lines are printed exactly as +-- they are specified. +--+-- --------------------------------------------------------------------------------  module Text.PrettyPrint.JoinPrint

@@ -17,22 +17,33 @@ module Text.PrettyPrint.JoinPrint.Core   (      Doc+  , VDoc   , empty   , null   , length +  -- * Compose Docs   , (<>)   , (<+>)-  , (<%>)-  , vcat   , hcat   , hsep +  -- * Compose VDocs+  , vcat+  , vsep+  , vcons+  , vsnoc+  , vconcat+  , vconcatSep++  -- * Primitive Docs   , text   , char   , int   , integer   , integral+  , float+  , double    , sglspace   , dblspace@@ -62,12 +73,13 @@   , replicateChar   , spacer -+  -- * Padding and truncation   , padl   , padr   , truncl    , truncr   +  -- * Output   , render   , renderIO   @@ -77,171 +89,402 @@ import Text.PrettyPrint.JoinPrint.JoinString ( JoinString, (++) ) import qualified Text.PrettyPrint.JoinPrint.JoinString as JS +import Data.List ( foldl' )+import Data.Monoid import Prelude hiding ( (++), null, length ) ++-- | Doc is the abstract data type respresenting single line +-- documents.+--+-- JoinPrint ditinguishes between single-line and multi-line +-- documents. Single-line, horizontal documents support some +-- operations not multi-line documents, e.g. padding, see 'padl' +-- and 'padr' and truncating 'truncl' and 'truncr'.+-- newtype Doc = Doc { getDoc :: JoinString } ++-- | VDoc is the abstract data type respresenting multi-line +-- documents.+--+-- Multi-line documents have a limited set of operations +-- (basically concatenation with or without a blank line +-- inbetween) compared to single line docs which support e.g. +-- padding and truncating. +--+newtype VDoc = VDoc { getVDoc :: ShowS }++--------------------------------------------------------------------------------+ instance Show Doc where   show = render++instance Show VDoc where+  show = renderV+++instance Monoid Doc where+  mempty = empty+  mappend = (<>)++instance Monoid VDoc where+  mempty                      = VDoc id+  (VDoc f) `mappend` (VDoc g) = VDoc (f . showChar '\n' . g)++++--------------------------------------------------------------------------------         -infixr 5 <%> infixr 6 <>, <+> -+-- | Create an empty, zero length document.+-- empty :: Doc empty = Doc $ JS.empty +-- | Test if the doc is empty.+-- null :: Doc -> Bool null = JS.null . getDoc   --- | length on a Doc is O(1).+-- | Get the length of the Doc. +-- +-- Length is cached in the document\'s  data type so this +-- operation is O(1).+-- length :: Doc -> Int length = JS.length . getDoc -+-- | Horizontally concatenate two documents with no space +-- between them.+--  (<>) :: Doc -> Doc -> Doc Doc a <> Doc b = Doc $ a ++ b +-- | Horizontally concatenate two documents with a single space +-- between them.+--  (<+>) :: 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-+-- | Horizontally concatenate a list of documents with @(\<\>)@.+-- hcat :: [Doc] -> Doc hcat = foldr (<>) empty +-- | Horizontally concatenate a list of documents with @(\<+\>)@.+-- hsep :: [Doc] -> Doc hsep = foldr (<+>) empty  +-- Vertically concatenation is different to PPrint or Hughes-PJ.+-- Because the Doc type tracks (horizontal) length, vertically+-- concat cannot use the same type as there is no reasonable+-- horizontal length (max length, length of first, length of +-- last?)+-- +-- | Vertically concatenate a list of documents, one doc per +-- line.+--+-- Note - this function produces a 'VDoc' rather than a 'Doc'.+-- +vcat :: [Doc] -> VDoc+vcat []     = VDoc id+vcat [a]    = VDoc (renderS a)+vcat (a:as) = VDoc $ foldl' fn (renderS a) as+  where+    fn f d = f . showChar '\n' . renderS d++-- | Vertically concatenate a list of documents, one doc per +-- line with a blank line inbetween.+--+-- Note - this function produces a 'VDoc' rather than a 'Doc'.+-- +vsep :: [Doc] -> VDoc+vsep []     = VDoc id+vsep [a]    = VDoc (renderS a)+vsep (a:as) = VDoc $ foldl' fn (renderS a) as+  where+    fn f d = f . showString "\n\n" . renderS d++-- | Prefix the 'Doc' to the start of the 'VDoc'. +--+vcons :: Doc -> VDoc -> VDoc+vcons d (VDoc f) = VDoc (renderS d . showChar '\n' . f)++-- | Suffix the 'VDoc' with the 'Doc'. +--+vsnoc :: VDoc -> Doc -> VDoc+vsnoc (VDoc f) d = VDoc (f . showChar '\n' . renderS d)++++-- | Concatenate a list of 'VDoc'.+--+vconcat :: [VDoc] -> VDoc+vconcat []          = VDoc id+vconcat [a]         = a+vconcat (VDoc a:as) = VDoc (a . showChar '\n' . getVDoc (vconcat as))++-- | Concatenate a list of 'VDoc' with a blank line separating +-- them.+--+vconcatSep :: [VDoc] -> VDoc+vconcatSep []          = VDoc id+vconcatSep [a]         = a+vconcatSep (VDoc a:as) = VDoc (a . showString "\n\n" . getVDoc (vconcatSep as))+++-- | Create a document from a literal string.+-- +-- The string should not contain tabs or newlines (though this+-- is not enforced). To allow padding and truncating the +-- horizontal width of a 'Doc' is cached in the datatype, +-- building a Doc containing tabs or newlines leads to +-- unspecified behaviour.+-- text :: String -> Doc text = Doc . (JS.text) +-- | Create a document from a literal character.+--+-- The char should not be a tab or newline. See 'text' for the+-- rational.+-- char :: Char -> Doc char = Doc . (JS.text) . return +-- | Show the Int as a Doc.+--+-- > int  = text . show+-- int :: Int -> Doc int  = text . show +-- | Show the Integer as a Doc.+-- integer :: Integer -> Doc integer = text . show +-- | Show an \"integral value\" as a Doc via 'fromIntegral'.+-- integral :: Integral a => a -> Doc integral = integer . fromIntegral +-- | Show the Float as a Doc.+--+float :: Double -> Doc+float = text . show++-- | Show the Double as a Doc.+--+double :: Double -> Doc+double = text . show+ +++-- | Create a Doc containing a single space character.+-- sglspace :: Doc sglspace = char ' ' +-- | Create a Doc containing a two-space characters.+-- dblspace :: Doc dblspace = text "  " ++-- | Create a Doc containing a comma, \",\".+-- comma :: Doc comma = char ',' +-- | Create a Doc containing a semi colon, \";\".+-- semicolon :: Doc semicolon = char ';'   -------------------------------------------------------------------------------- +-- | Punctuate the Doc list with the separator, producing a Doc. +-- punctuate :: Doc -> [Doc] -> Doc punctuate _ []     = empty punctuate _ [x]    = x punctuate s (x:xs) = x <> s <> punctuate s xs -+-- | Enclose the final Doc within the first two.+--+-- There are no spaces between the documents:+--+-- > enclose l r d = l <> d <> r+-- enclose :: Doc -> Doc -> Doc -> Doc enclose l r d = l <> d <> r +++-- | Enclose the Doc within single quotes.+-- squotes :: Doc -> Doc squotes = enclose (char '\'') (char '\'') +-- | Enclose the Doc within double quotes.+-- dquotes :: Doc -> Doc dquotes = enclose (char '"') (char '"') -+-- | Enclose the Doc within parens @()@.+-- parens :: Doc -> Doc parens = enclose lparen rparen +-- | Enclose the Doc within square brackets @[]@.+-- brackets :: Doc -> Doc brackets = enclose lbracket rbracket +-- | Enclose the Doc within curly braces @{}@.+-- braces :: Doc -> Doc braces = enclose lbrace rbrace +-- | Enclose the Doc within angle brackets @\<\>@.+-- angles :: Doc -> Doc angles = enclose langle rangle   +-- | Create a Doc containing a left paren, \'(\'.+-- lparen :: Doc lparen = char '(' +-- | Create a Doc containing a right paren, \')\'.+-- rparen :: Doc rparen = char ')' +-- | Create a Doc containing a left square bracket, \'[\'.+-- lbracket :: Doc lbracket = char '[' +-- | Create a Doc containing a right square bracket, \']\'.+-- rbracket :: Doc rbracket = char ']' +-- | Create a Doc containing a left curly brace, \'{\'.+-- lbrace :: Doc lbrace = char '{' +-- | Create a Doc containing a right curly brace, \'}\'.+-- rbrace :: Doc rbrace = char '}' +-- | Create a Doc containing a left angle bracket, \'\<\'.+-- langle :: Doc langle = char '<' +-- | Create a Doc containing a right angle bracket, \'\>\'.+-- rangle :: Doc rangle = char '>'   -------------------------------------------------------------------------------- +-- | 'replicateChar' : @ n * ch -> Doc@+--+-- Repeat the supplied char (@ch@), @n@ times.+--  replicateChar :: Int -> Char -> Doc replicateChar i = Doc . (JS.text) . replicate i +-- | Create a list of space characters of length @n@.+-- spacer :: Int -> Doc spacer = replicateChar `flip` ' ' -+-- | 'padl' : @ width * ch * doc -> Doc @+--+-- Pad the supplied Doc to fit @width@ using the char @ch@.+-- Padding is performed at the left, right-justifying the Doc. +-- +-- If the doc is already wider than supplied width it is returned +-- as-is (no truncation takes place).+-- 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' : @ width * ch * doc -> Doc @+--+-- Pad the supplied Doc to fit @width@ using the char @ch@.+-- Padding is performed at the right, left-justifying the Doc. +-- +-- If the doc is already wider than supplied width it is returned+-- as-is (no truncation takes place).+-- 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' : @width * doc -> Doc@+--+-- Truncate a doc to the supplied @width@. Characters are dropped+-- from the left until the document fits. If the document is +-- shorter than the supplied width it is returned as is (no +-- padding takes place).+-- truncl :: Int -> Doc -> Doc truncl i d = step (length d) where     step dl | dl > i    = Doc $ JS.dropLeft i (getDoc d)             | otherwise = d +-- | 'truncr' : @width * doc -> Doc@+--+-- Truncate a doc to the supplied @width@. Characters are dropped+-- from the right until the document fits. If the document is +-- shorter than the supplied width it is returned as is (no +-- padding takes place).+-- 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.+-- | Rendering the Doc to a String. This is the same as using 'show'. -- render :: Doc -> String render = JS.toString . getDoc  +renderS :: Doc -> ShowS+renderS = showString . render +renderV :: VDoc -> String+renderV = ($ "") . getVDoc+++-- | Print the Doc.+--+-- > renderIO = putStrLn . render+--  renderIO :: Doc -> IO ()-renderIO = putStrLn . JS.toString . getDoc+renderIO = putStrLn . render+

@@ -27,13 +27,14 @@   , oxhex8    , hexdump-+  , hexdumpA    ) where   import Text.PrettyPrint.JoinPrint.Core +import Data.Array.IO import Data.Char import Data.List ( unfoldr ) import Data.Word@@ -61,13 +62,18 @@   -+-- | Print a Word8 as a 2-digit hex number.+-- hex2 :: Word8 -> Doc hex2 = padl 2 '0' . text . ($ []) . showHex +-- | Print a Word16 as a 4-digit hex number.+-- hex4 :: Word16 -> Doc hex4 = padl 4 '0' . text . ($ []) . showHex +-- | Print a Word32 as a 8-digit hex number.+-- hex8 :: Word32 -> Doc hex8 = padl 8 '0' . text . ($ []) . showHex @@ -83,36 +89,74 @@     | i >= 0    = text "0x" <> padl plen '0' (text $ showHex i [])     | otherwise = text "0x" <> padl plen '*' (asterix $ showHex (abs i) []) +-- | Print a Word8 as a 2-digit hex number prefixed with \"0x\".+-- oxhex2 :: Word8 -> Doc oxhex2 = (text "0x" <>) . hex2 +-- | Print a Word16 as a 4-digit hex number prefixed with \"0x\".+-- oxhex4 :: Word16 -> Doc oxhex4 = (text "0x" <>) . hex4 +-- | Print a Word32 as a 8-digit hex number prefixed with \"0x\".+-- oxhex8 :: Word32 -> Doc oxhex8 = (text "0x" <>) . hex8  -------------------------------------------------------------------------------- +hexdumpA :: Int -> Int -> IOUArray Int Word8 -> IO VDoc +hexdumpA start end arr = getBounds arr >>= next +  where+    next (s,e) = lineSpans c1_width (segment16Ixs (max s start) (min e end)) arr+    c1_width   = 2 +  sizeHexStr end++lineSpans :: Int -> [(Int,Int)] -> IOUArray Int Word8 -> IO VDoc +lineSpans _        []     _   = return $ vcat []+lineSpans c1_width (x:xs) arr = do +    w8s <- spanArr x arr+    let vdoc = vcat [firstLine (lineStart $ fst x) w8s]+    docTail xs vdoc+  where+    docTail []             vdoc = return vdoc+    docTail (ix@(s,_):ixs) vdoc = do { w8s <- spanArr ix arr+                                     ; let d = tailLine (lineStart s) w8s+                                     ; docTail ixs (vdoc `vsnoc` d) }++    firstLine                   = hexLine True  c1_width+    tailLine                    = hexLine False c1_width+                                     +        ++ -- 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 = +hexdump :: Int -> Int -> [Word8] -> VDoc+hexdump start end bs = hexdump2 start end segs  where+    segs = segment16 (16 - (start `mod` 16)) bs++hexdump2 :: Int -> Int -> [[Word8]] -> VDoc+hexdump2 start end segs =      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 "")+    c1_width   = 2 +  sizeHexStr end     index_nums = lineNumbers start end ++sizeHexStr :: Int -> Int+sizeHexStr n = Pre.length $ showHex (abs n) []++-- zipWith an \anacrusis\ on the first element.+-- 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@@ -135,12 +179,24 @@                      lineNumbers :: Int -> Int -> [Int]-lineNumbers s e = unfoldr phi $ s `div` 16 where+lineNumbers s e = unfoldr phi $ lineStart s where    phi n | n > e     = Nothing          | otherwise = Just (n,n+16)  +lineEnd :: Int -> Int+lineEnd l = (l `div` 16) * 16 + 15  +lineStart :: Int -> Int+lineStart l = (l `div` 16) * 16+++segment16Ixs :: Int -> Int -> [(Int,Int)]+segment16Ixs start end = unfoldr phi start where+  phi i | i > end    = Nothing+        | otherwise  = let e1 = lineEnd i in Just ((i, min end e1), e1+1)++ -- Show 16 bytes per line... segment16 :: Int -> [a] -> [[a]] segment16 initial ls = let (top,rest) = splitAt initial ls@@ -150,7 +206,13 @@     phi cs = let (xs,rest) = splitAt 16 cs in Just (xs,rest)  +spanArr :: (Int,Int) -> IOUArray Int Word8 -> IO [Word8]+spanArr (l,u) arr = rstep u [] where+  rstep i acc | i < l = return acc+  rstep i acc         = do { e <- readArray arr i ; rstep (i-1) (e:acc ) }+ printable :: Word8 -> Char printable = fn . chr . fromIntegral where -  fn c | isPrint c = c-       | otherwise = '.'+  fn c | ord c >= 160  = '.'            -- GHC 6.12.1 Windows bug?+       | isPrint c     = c+       | otherwise     = '.'

@@ -1,57 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Picklers--- Copyright   :  (c) Stephen Tetley 2009--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  to be determined.------ Pickling--------------------------------------------------------------------------------------module Picklers where---import qualified Data.ByteString as BS-import Data.Char-import Data.List ( foldl' )-import Data.Word-import System.IO--newtype RevBS = RevBS { getRevBS :: BS.ByteString }--type Pickle = RevBS--empty :: RevBS -empty = RevBS BS.empty---writePickle :: FilePath -> Pickle -> IO ()-writePickle file pkl = withBinaryFile file WriteMode (BS.hPut `flip` rpkl)-  where rpkl = BS.reverse $ getRevBS pkl ---cons :: Word8 -> Pickle -> Pickle-cons c = RevBS . BS.cons c . getRevBS --putCString :: String -> Pickle -> Pickle-putCString s pkl = putWord8 0 $ foldl' (flip putChar8) pkl s--putWord8 :: Word8 -> Pickle -> Pickle-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