packages feed

kangaroo (empty) → 0.1.0

raw patch · 18 files changed

+2206/−0 lines, 18 filesdep +arraydep +basesetup-changed

Dependencies added: array, base

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2008 Stephen Peter Tetley++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runhaskell++import Distribution.Simple+main = defaultMain
+ demo/MidiDatatypes.hs view
@@ -0,0 +1,252 @@+{-# 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) ""
+ demo/MidiRead.hs view
@@ -0,0 +1,233 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  MidiRead+-- Copyright   :  (c) Stephen Tetley 2009+-- 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 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+    +{-++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++-}++--------------------------------------------------------------------------------+-- +++    +midiFile :: MidiParser MidiFile  +midiFile = 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 ++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 = alfineRelative 0 (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++-}+++word24be   :: MidiParser Word32+word24be   = w32be 0 <$> word8 <*> word8 <*> word8+++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 char++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)+   ++
+ demo/MidiText.hs view
@@ -0,0 +1,160 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  MidiText+-- Copyright   :  (c) Stephen Tetley 2009+-- 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 readable text representation+    printMidi, ppMidiFile,+    +    ppHeader, ppMessage,+  +  ) where+++import MidiDatatypes++import qualified Data.Foldable as F+import Numeric+import Text.PrettyPrint.HughesPJ+++printMidi :: MidiFile -> IO ()+printMidi = putStrLn . render . ppMidiFile +++++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 []++++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+  +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++prettyTrack :: Track -> Int -> Doc+prettyTrack (Track se) i = +    brackets (text "Track" <+> int i) $$ (snd $ F.foldl fn (0,empty) se)+  where+    fn (gt,doc) msg@(dt,_)  = +      (gt+dt, doc $$ (padshow 8 (gt+dt) `hyph` ppMessage msg))    +++ppMessage :: Message -> Doc+ppMessage (dt,evt) = padshow 5 dt `hyph` ppEvent evt      +++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 +                  +++fli :: (Integral a, Show a) => a -> Doc+fli = padshow 3++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++  ++ppSystemEvent :: SystemEvent -> Doc+ppSystemEvent (SysEx _ _)    = text "sysex"   -- system exclusive event - length x data+ppSystemEvent (DataEvent i)  = text "data" <+> ppHex 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 "..."++ppScaleType :: ScaleType -> Doc+ppScaleType MAJOR  = text "major"+ppScaleType MINOR  = text "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"+
+ demo/PrintMidi.hs view
@@ -0,0 +1,38 @@+{-# 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++
+ kangaroo.cabal view
@@ -0,0 +1,72 @@+name:             kangaroo+version:          0.1.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.+description:+  Binary parsing with random access. The target file to be +  parsed is loaded into memory at the start (represented as+  an IOUArray Int Word8). Parsing proceeds by moving a cursor+  around, the array is left intact. This allows _jumping_+  inside the file and contrasts with other parser +  combinators that progress via consuming input.+  .+  \* 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.+  .+  Changelog:+  . +  0.1.0 First version+  +build-type:         Simple+stability:          half baked+cabal-version:      >= 1.2++extra-source-files:+  demo/MidiDatatypes.hs+  demo/MidiRead.hs+  demo/MidiText.hs+  demo/PrintMidi.hs+  test/Picklers.hs+++library+  hs-source-dirs:     src+  build-depends:      base < 5,+                      array >= 0.3.0.0 && < 0.4++  +  exposed-modules:+    Data.ParserCombinators.Kangaroo,+    Data.ParserCombinators.KangarooReader+    Data.ParserCombinators.KangarooRWS,+    Data.ParserCombinators.KangarooState,+    Data.ParserCombinators.KangarooWriter,+    Data.ParserCombinators.Kangaroo.Combinators,+    Data.ParserCombinators.Kangaroo.IEEEFloat,+    Data.ParserCombinators.Kangaroo.ParseMonad,+    Data.ParserCombinators.Kangaroo.Prim,+    Data.ParserCombinators.Kangaroo.Utils++  other-modules:+      +  extensions:+    ++  ghc-options:+  +  includes: +  ++  +
+ src/Data/ParserCombinators/Kangaroo.hs view
@@ -0,0 +1,43 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Data.ParserCombinators.Kangaroo+-- Copyright   :  (c) Stephen Tetley 2009+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  to be determined.+--+-- Binary parser combinators with random access+--+--------------------------------------------------------------------------------++module Data.ParserCombinators.Kangaroo +  (+    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.Prim+import Data.ParserCombinators.Kangaroo.Utils hiding ( (<:>), oo, ooo, oooo )+++type Kangaroo a = GenKangaroo () a++runKangaroo :: Kangaroo a -> FilePath -> IO (Either ParseErr a)+runKangaroo p filename = runGenKangaroo p () filename >>= \(a,_) -> return a++-- jsut runKangaroo here+parse :: Kangaroo a -> FilePath -> IO (Either ParseErr a)+parse = runKangaroo +
+ src/Data/ParserCombinators/Kangaroo/Combinators.hs view
@@ -0,0 +1,192 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Data.ParserCombinators.Kangaroo.Combinators+-- Copyright   :  (c) Stephen Tetley 2009+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  to be determined.+--+-- Combinators+--+--------------------------------------------------------------------------------++module Data.ParserCombinators.Kangaroo.Combinators +  ( +    satisfy+  , manyTill+  , genericManyTill+  , manyTillPC+  , genericManyTillPC+  , count+  , countPrefixed+  , genericCount+  , runOn+  , genericRunOn+  , postCheck+  , buildWhile+  , buildPrimitive++  ) where++import Data.ParserCombinators.Kangaroo.ParseMonad+import Data.ParserCombinators.Kangaroo.Utils++import Control.Applicative+import Data.Word++satisfy :: (Word8 -> Bool) -> GenKangaroo ust Word8+satisfy p = word8 >>= \x -> +    if p x then return x else reportError $ "satisfy"+++manyTill :: GenKangaroo ust a -> GenKangaroo ust b -> GenKangaroo ust [a]+manyTill = genericManyTill (:) [] ++++genericManyTill :: (a -> c -> c) -> c +                -> GenKangaroo ust a +                -> GenKangaroo ust b+                -> GenKangaroo ust c+genericManyTill op initial p end = opt end >>= \ans ->+    case ans of +      Just _  -> return initial+      Nothing -> op <$> p <*> genericManyTill op initial p end+++manyTillPC :: GenKangaroo ust a -> (a -> Bool) -> GenKangaroo ust ([a],a)+manyTillPC = genericManyTillPC (:) []++genericManyTillPC :: (a -> b -> b) -> b +                  -> GenKangaroo ust a +                  -> (a -> Bool) +                  -> GenKangaroo ust (b,a)+genericManyTillPC op initial p check =  p >>= \ans ->+  if check ans then do { (acc,end) <- genericManyTillPC op initial p check+                       ; return (ans `op` acc,end)+                       }+               else return (initial,ans) +   +count :: Int -> GenKangaroo ust a -> GenKangaroo ust [a]+count = genericCount (:) []+++-- Generalized version of count (like a fold)+genericCount :: (a -> b -> b) -> b -> Int +             -> GenKangaroo ust a +             -> GenKangaroo ust b+genericCount op initial i p +    | i <= 0    = pure initial+    | otherwise = op <$> p <*> genericCount op initial (i-1) p++countPrefixed :: Integral i +              => GenKangaroo ust i -> GenKangaroo ust a -> GenKangaroo ust (i,[a]) +countPrefixed plen p = plen >>= \i -> +    count (fromIntegral i) p >>= \ans -> return (i,ans)+++runOn :: GenKangaroo ust a -> GenKangaroo ust [a]+runOn p = atEnd >>= \end -> if end then return [] else p <:> runOn p+++genericRunOn :: (a -> b -> b) -> b -> GenKangaroo ust a -> GenKangaroo ust b+genericRunOn op initial p = atEnd >>= \end -> +   if end then return initial else op <$> p <*> genericRunOn op initial p++++-- | Apply parse then apply the check, if the check fails report+-- the error message. +postCheck :: GenKangaroo ust a -> (a -> Bool) -> String -> GenKangaroo ust a+postCheck p check msg = p >>= \ans -> +    if check ans then return ans else reportError msg+++-- | Build a value by while the test holds. When the test fails +-- the position is not backtracked, instead we use the \"failing\"+-- element with @lastOp@ potentially still building the value +-- with it.+-- +buildWhile :: (a -> Bool) +           -> (a -> b -> b) +           -> (a -> b -> b) +           -> b +           -> GenKangaroo ust a +           -> GenKangaroo ust b+buildWhile test op lastOp initial p = step where+    step = p >>= \ans -> +      if test ans then (step >>= \acc -> return $ ans `op` acc)+                  else (return $ ans `lastOp` initial)++-- building on Word8\'s, progress is checked - only elements that +-- match the check are consumed up the the max count.+buildPrimitive :: Int +               -> (Word8 -> Bool) +               -> (Word8 -> b -> b) +               -> b +               -> GenKangaroo ust b+buildPrimitive maxc check op initial | maxc <= 0 = return initial+                                     | otherwise = step 0 initial+  where+    step i a | i >= maxc = return a+             | otherwise = checkWord8 check >>= \ans -> case ans of +                             Nothing -> return a +                             Just x  -> step (i+1) (x `op` a)++ ++-- Can't rely on Alternative as Kangaroo doesn't support it.+{-++choice :: Alternative f => [f a] -> f a+choice = foldr (<|>) empty +          +between :: Applicative f => f open -> f close -> f a -> f a+between o c a = o *> a <* c++          +option :: Alternative f => a -> f a -> f a+option x p          = p <|> pure x++optionMaybe :: Alternative f => f a -> f (Maybe a)+optionMaybe = optional++-- aka Parsecs /optional/+optionUnit :: Alternative f => f a -> f ()+optionUnit p = () <$ p <|> pure ()++skipMany1 :: Alternative f => f a -> f ()+skipMany1 p = p *> skipMany p++skipMany :: Alternative f => f a -> f ()+skipMany p = many_p+  where many_p = some_p <|> pure ()+        some_p = p       *> many_p++-- | @many1@ an alias for @some@. +many1 :: Alternative f => f a -> f [a]+many1 = some++sepBy :: Alternative f => f a -> f b -> f [a]+sepBy p sep = sepBy1 p sep <|> pure []++sepBy1 :: Alternative f => f a -> f b -> f [a]+sepBy1 p sep = p <:> step where+    step = (sep *> p) <:> step <|> pure []++sepEndBy :: Alternative f => f a -> f b -> f [a]+sepEndBy p sep = sepEndBy1 p sep <|> pure []++sepEndBy1 :: Alternative f => f a -> f b -> f [a]+sepEndBy1 p sep = (p <* sep) <:> step where+    step = (p <* sep) <:> step <|> pure []+    +manyTill :: Alternative f => f a -> f b -> f [a]+manyTill p end = step <|> pure [] where+    step = p <:> (step <|> (pure [] <$> end))++-}
+ src/Data/ParserCombinators/Kangaroo/IEEEFloat.hs view
@@ -0,0 +1,118 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Data.ParserCombinators.Kangaroo.IEEEFloat+-- Copyright   :  (c) Stephen Tetley 2009+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  to be determined.+--+-- IEEE floats (single precision so far...)+--+--------------------------------------------------------------------------------++module Data.ParserCombinators.Kangaroo.IEEEFloat where++import Data.ParserCombinators.Kangaroo.Utils+++import Data.Bits+import Data.Char+import Data.Word+import Numeric+++const_B :: Int+const_B = 127+++printBin :: (Fractional a,Ord a) => a -> ShowS+printBin a = +    f s . showChar ' ' . f t . showChar ' ' . f u . showChar ' ' . f v+  where+    f = showIntAtBase 2 (chr . (48+))+    (s,t,u,v) = packIEEESingle a +  +toAndFro :: (Fractional a, Ord a) => a -> a+toAndFro a = let (s,t,u,v) = packIEEESingle a in unpackIEEESingle s t u v++unpackIEEESingle :: Fractional a => Word8 -> Word8 -> Word8 -> Word8 -> a+unpackIEEESingle b24_31 b16_23 b8_15 b0_7 =  sign $ fract * (2 ^^ expo)+  where+    sign  = if b24_31 `testBit` 7 then negate else id+  +    expo  = exponent' b24_31 b16_23+  +    fract = fraction b16_23 b8_15 b0_7+++exponent' :: Word8  -> Word8 -> Int+exponent' a b = (a' `shiftL` 1) + (b' `shiftR` 7) - 127+  where+    a' = fromIntegral $ (a .&. 0x7f) +    b' = fromIntegral $ (b .&. 0x80)+++iPow :: Fractional a => a -> Integer -> a+iPow = (^^)++fraction :: Fractional a => Word8 -> Word8 -> Word8 -> a+fraction b16_24 b8_15 b0_7 = 1.0 + ((fromIntegral frac) / (2 `iPow` 23))+  where+   frac :: Int +   frac = (shiftL16 (b16_24 .&. 0x7f)) + (shiftL8 b8_15) + fromIntegral b0_7+    +++packIEEESingle :: (Fractional a,Ord a) => a -> (Word8,Word8,Word8,Word8)+packIEEESingle a = (flipSign b24_31, exp_part+mant_part, b8_15, b0_7)+  where+    k     = findPosExpo $ abs a+    e     = k + const_B+    halfa = (abs a) / (2 `iPow` fromIntegral k)+    f     = expand $ halfa - 1+    +    (b24_31, exp_part)          = expoWords e+    (mant_part,b8_15, b0_7)     = mantWords f+    +    flipSign = if a > 0 then id else (`setBit` 7)+++findPosExpo :: (Fractional a, Ord a) => a -> Int+findPosExpo r | r <= 0    = 0 +              | otherwise = step r 1+  where+    step r' k | r <= fromIntegral (2::Int) ^^ k = k-1+              | otherwise                       = step r' (k+1)+++expand :: (Fractional a, Ord a) => a -> Word32+expand n = (`shiftR` 9) $ step n 0 id+  where+    step x ix f | x <= 0    = f (0::Word32) +                | otherwise = let y = 1 / (2 ^^ (ix+1))+                              in if x >= y +                                 then step (x-y) (ix+1) (f . (`setBit` (31-ix)))+                                 else step x (ix+1) f++++-- 7 bits left, 1 bit right+expoWords :: Int -> (Word8,Word8)+expoWords n = (left, right)+  where+    right = if n `testBit` 0 then 128 else 0+    left  = fromIntegral $ n `shiftR` 1+++mantWords :: Word32 -> (Word8,Word8,Word8)+mantWords x = (a,b,c)+  where+    c = fromIntegral $ x .&. 0xff+    b = fromIntegral $ (`shiftR` 8)  $ x .&. 0xff00+    a = fromIntegral $ (`shiftR` 16) $ x .&. 0xff0000+    +
+ src/Data/ParserCombinators/Kangaroo/ParseMonad.hs view
@@ -0,0 +1,418 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Data.ParserCombinators.Kangaroo.ParseMonad+-- Copyright   :  (c) Stephen Tetley 2009+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  to be determined.+--+-- Random access parse monad +--+--------------------------------------------------------------------------------++module Data.ParserCombinators.Kangaroo.ParseMonad +  (+    GenKangaroo+  , ParseErr+  +  , getSt+  , putSt+  , modifySt+  +  , getUserSt+  , putUserSt+  , modifyUserSt++  , askEnv+  , throwErr+  , runGenKangaroo++  , reportError+  , substError+  , word8+  , checkWord8+  , opt +  , position+  , regionEnd+  , atEnd+  , lengthRemaining++  -- * Parse within a /region/.+  , dalpunto+  , dalpuntoRelative+  , advanceDalpunto+  , advanceDalpuntoAbsolute++  , alfine+  , alfineRelative+  , restrictAlfine++  , alfermata+  , alfermataRelative+  , advanceAlfermata+  , advanceAlfermataAbsolute+  , restrictAlfermata +   +  ) where++import Control.Applicative+import Control.Monad+import Data.Array.IO+import Data.Word+import Numeric+import System.IO++type ParseErr = String++type ImageData = IOUArray Int Word8   -- Is Int big enough for index?++data ArrIx = ArrIx { arr_ix_ptr :: !Int, arr_ix_end :: !Int }+  deriving (Eq,Show) ++type St    = ArrIx+type Env   = ImageData+  ++-- Kangaroo is not a transformer as IO is always at the +-- \'bottom\' of the effect stack. Like the original Parsec it is+-- parametric on user state (refered to as ust).+--+newtype GenKangaroo ust a = GenKangaroo { +          getGenKangaroo :: Env -> St -> ust -> IO (Either ParseErr a, St, ust) }+          ++fmapKang :: (a -> b) -> GenKangaroo ust a -> GenKangaroo ust b+fmapKang f (GenKangaroo x) = GenKangaroo $ \env st ust -> +    x env st ust `bindIO` \(a,st',ust') -> return (fmap f a, st', ust')+++instance Functor (GenKangaroo ust) where+    fmap = fmapKang++++returnIO :: a -> IO a+returnIO = return++infixl 1 `bindIO`++bindIO :: IO a -> (a -> IO b) -> IO b+bindIO = (>>=)+++returnKang :: a -> GenKangaroo st a+returnKang a = GenKangaroo $ \_ st ust -> returnIO (Right a, st, ust)++infixl 1 `bindKang`++bindKang :: GenKangaroo ust a -> (a -> GenKangaroo ust b) -> GenKangaroo ust b+(GenKangaroo x) `bindKang` f = GenKangaroo $ \env st ust -> +    x env st ust `bindIO` \(ans, st', ust') ->+        case ans of Left err -> returnIO (Left err,st',ust')+                    Right a  -> getGenKangaroo (f a) env st' ust'+ ++++instance Monad (GenKangaroo ust) where+  return = returnKang+  (>>=)  = bindKang+++instance Applicative (GenKangaroo ust) where+  pure = return+  (<*>) = ap++-- I don't think Kangaroo has natural implementations of +-- Alternative or MonadPlus.+-- My 'proposition' is that the sort of parsing that Kangaroo +-- intends to provide you always now want you want hence there +-- is no inbuilt backtracking or support for list-of-successes.+++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)+++getUserSt :: GenKangaroo ust ust+getUserSt = GenKangaroo $ \_ st ust -> return (Right ust, st, ust)++putUserSt :: ust -> GenKangaroo ust ()+putUserSt ust = GenKangaroo $ \_ st _ -> return (Right (), st, ust)++modifyUserSt :: (ust -> ust) -> GenKangaroo ust ()+modifyUserSt f = GenKangaroo $ \_ st ust -> return (Right (), st, f ust)++++askEnv :: GenKangaroo ust Env+askEnv = GenKangaroo $ \env st ust -> return (Right env, 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) +++++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++++--------------------------------------------------------------------------------+-- 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+    throwErr $ s ++ posStr posn+  where+    posStr (ArrIx pos end) = concat [ " absolute position "+                                    , show pos+                                    , " (0x" +                                    , showHex pos []+                                    , "), region length "+                                    , show end+                                    ]+++substError :: GenKangaroo ust a -> ParseErr -> GenKangaroo ust a+substError p msg = GenKangaroo $ \env st ust -> +    (getGenKangaroo p) env st ust >>= \ ans -> +      case ans of+        (Left _, st', ust')  -> return (Left msg, st', ust')+        okay                 -> return okay++   +word8 :: GenKangaroo ust Word8+word8 = do+    (ArrIx ix end)   <- getSt+    when (ix>end)    (reportError "word8")   -- test emphatically is (>) !+    arr              <- askEnv+    a                <- liftIOAction $ readArray arr ix+    putSt $ ArrIx (ix+1) end+    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++++-- no 'try' in Kangaroo... +-- opt is the nearest to it, opt backtracks the cursor onm 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/ ...++-- 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.+--+-- 3. alfermata - 'to the stop'    +-- - Run the parser within a region, the cursor remains wherever +--   the parse finished.+--+++++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 ()+++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+    ]++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+    ]+++-- Parser inside the supplied region, afterwards restore the+-- end of the /outer/ region and return to the initial position.+--+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+    +++-- | return to the start position - start x length+dalpunto :: Int -> Int -> GenKangaroo ust a -> GenKangaroo ust a+dalpunto = dalpuntoP "dalpunto"+++-- | 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+++-- Parse inside the supplied region, afterwards go to the end of+-- the supplied region and restore the end of the /outer/ 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+++-- | alfine - parse to the end+alfine :: Int -> Int -> GenKangaroo ust a -> GenKangaroo ust a+alfine = alfineP "alfine"++-- | 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+++restrictAlfine :: Int -> GenKangaroo ust p -> GenKangaroo ust p+restrictAlfine dist_to_end p = getSt >>= \(ArrIx pos _) -> +    alfineP "restrictAlfine" pos (pos + dist_to_end) p+    +++-- Parser inside the supplied region, afterwards restore the end +-- of the /outer/region but keep the cursor in at the current +-- position.+--+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.+--+alfermata :: Int -> Int -> GenKangaroo ust a -> GenKangaroo ust a+alfermata = alfermataP "alfermata"+++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+++-- | 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++-- | 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++restrictAlfermata :: Int -> GenKangaroo ust p -> GenKangaroo ust p+restrictAlfermata dist_to_end p = getSt >>= \(ArrIx pos _) ->+    alfermataP "restrictAlfermata" pos (pos + dist_to_end) p
+ src/Data/ParserCombinators/Kangaroo/Prim.hs view
@@ -0,0 +1,113 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Data.ParserCombinators.Kangaroo.Prim+-- Copyright   :  (c) Stephen Tetley 2009+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  to be determined.+--+-- Primitive parsers - charactors, numbers...+--+--------------------------------------------------------------------------------++module Data.ParserCombinators.Kangaroo.Prim +  (+    cstring+  , w8Zero+  , getBytes+  , char+  , text+  , int8+  , word16be+  , word32be+  , word64be  +  , word16le+  , word32le+  , int16be+  , int32be+  , int16le+  , int32le++  , ieeeFloatSP++  ) where++import Data.ParserCombinators.Kangaroo.Combinators+import Data.ParserCombinators.Kangaroo.IEEEFloat+import Data.ParserCombinators.Kangaroo.ParseMonad+import Data.ParserCombinators.Kangaroo.Utils++import Control.Applicative+import Data.Char+import Data.Int+import Data.Word+++-- | Read a null-terminated string+cstring :: GenKangaroo ust String+cstring = manyTill char w8Zero+++w8Zero :: GenKangaroo ust Word8+w8Zero = satisfy (==0)++getBytes :: Integral a => a -> GenKangaroo ust [Word8]+getBytes i = count (fromIntegral i) word8++char :: GenKangaroo ust Char+char = (chr . fromIntegral) <$> word8 ++++text :: Int -> GenKangaroo ust String+text = count `flip` char++++int8 :: GenKangaroo ust Int8+int8 = (fromIntegral . unwrap) <$> word8+  where+    unwrap :: Word8 -> Int+    unwrap i | i > 128   = (fromIntegral i) - 256+             | otherwise = fromIntegral i++word16be   :: GenKangaroo ust Word16+word16be   = w16be     <$> word8 <*> word8  ++word32be   :: GenKangaroo ust Word32+word32be   = w32be     <$> word8 <*> word8 <*> word8 <*> word8++word64be   :: GenKangaroo ust Word64+word64be   = w64be <$> word8 <*> word8 <*> word8 <*> word8+                   <*> word8 <*> word8 <*> word8 <*> word8++word16le   :: GenKangaroo ust Word16+word16le   = w16le     <$> word8 <*> word8  ++word32le   :: GenKangaroo ust Word32+word32le   = w32le     <$> word8 <*> word8 <*> word8 <*> word8+++int16be   :: GenKangaroo ust Int16+int16be   = i16be <$> word8 <*> word8+  +int32be   :: GenKangaroo ust Int32+int32be   = i32be <$> word8 <*> word8 <*> word8 <*> word8++                         +int16le   :: GenKangaroo ust Int16+int16le   = i16le <$> word8 <*> word8+                         +int32le   :: GenKangaroo ust Int32+int32le   = i32le <$> word8 <*> word8 <*> word8 <*> word8+++ieeeFloatSP :: Fractional a => GenKangaroo ust a+ieeeFloatSP = unpackIEEESingle <$> word8 <*> word8 <*> word8 <*> word8+++
+ src/Data/ParserCombinators/Kangaroo/Utils.hs view
@@ -0,0 +1,195 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Data.ParserCombinators.Kangaroo.Utils+-- Copyright   :  (c) Stephen Tetley 2009+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  to be determined.+--+-- Utils...+--+--------------------------------------------------------------------------------++module Data.ParserCombinators.Kangaroo.Utils +  ( +    (<:>)+  , pairA+  , mprogress++  -- * Specs+  , oo+  , ooo+  , oooo++  -- * numbers from Word8 +  , w16be+  , w32be++  , w16le+  , w32le+  , w64be++  , i16be+  , i32be++  , i16le+  , i32le+  +  , shiftL8+  , shiftL16+  , shiftL24+  , shiftL32+  , shiftL40+  , shiftL48+  , shiftL56+  +  -- * Hex printing+  , hex2+  , hex4+  , hex8+  ++  ) where+++import Control.Applicative++import Data.Bits+import Data.Int+import Data.Word+import Numeric++infixr 5 <:>++-- | applicative cons+(<:>) :: Applicative f => f a -> f [a] -> f [a]+(<:>) p1 p2 = (:) <$> p1 <*> p2+++    ++pairA :: Applicative f => f a -> f b -> f (a,b)+pairA fa fb = (,) <$> fa <*> fb++-- 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++-- specs - defined in my package data-aviary but defined here to +-- avoid a dependency++-- | Compose an arity 1 function with an arity 2 function.+-- B1 - blackbird+oo :: (c -> d) -> (a -> b -> c) -> a -> b -> d+oo f g = (f .) . g++-- | Compose an arity 1 function with an arity 3 function.+-- B2 - bunting+ooo :: (d -> e) -> (a -> b -> c -> d) -> a -> b -> c -> e+ooo f g = ((f .) .) . g++-- | Compose an arity 1 function with an arity 4 function.+oooo :: (e -> f) -> (a -> b -> c -> d -> e) -> a -> b -> c -> d -> f+oooo f g = (((f .) .) .) . g  ++++--------------------------------------------------------------------------------++++w16le :: Word8 -> Word8 -> Word16+w16le a b = fromIntegral a + (shiftL8 b)++w32le :: Word8 -> Word8 -> Word8 -> Word8 -> Word32+w32le a b c d = fromIntegral a + (shiftL8 b) + (shiftL16 c) + (shiftL24 d)      +++-- Woah! The integer ones don't look right - what about the sign?++i16le :: Word8 -> Word8 -> Int16+i16le a b = fromIntegral $ w16le a b+              +i32le :: Word8 -> Word8 -> Word8 -> Word8 -> Int32+i32le a b c d  = fromIntegral $ w32le a b c d                +++i16be :: Word8 -> Word8 -> Int16+i16be a b = fromIntegral $ w16be a b+                            +i32be :: Word8 -> Word8 -> Word8 -> Word8 -> Int32+i32be a b c d = fromIntegral $ w32be a b c d+++w16be :: Word8 -> Word8 -> Word16+w16be a b = (shiftL8 a) + fromIntegral b+     +            +w32be :: Word8 -> Word8 -> Word8 -> Word8 -> Word32+w32be a b c d = (shiftL24 a) + (shiftL16 b) + (shiftL8 c) + fromIntegral d++-- To do...+w64be :: Word8 -> Word8 -> Word8 -> Word8 -> +           Word8 -> Word8 -> Word8 -> Word8 -> Word64+w64be a b c d e f g h = a' + b' + c' + d' + e' + f' + g' + h' where+    a' = (fromIntegral a) `shiftL` 56+    b' = (fromIntegral b) `shiftL` 48+    c' = (fromIntegral c) `shiftL` 40+    d' = (fromIntegral d) `shiftL` 32+    e' = (fromIntegral e) `shiftL` 24+    f' = (fromIntegral f) `shiftL` 16+    g' = (fromIntegral g) `shiftL` 8+    h' = (fromIntegral h) +++shiftL8 :: (Bits b, Integral b) => Word8 -> b+shiftL8 = (`shiftL` 8) . fromIntegral++shiftL16 :: (Bits b, Integral b) => Word8 -> b+shiftL16 = (`shiftL` 16) . fromIntegral++shiftL24 :: (Bits b, Integral b) => Word8 -> b+shiftL24 = (`shiftL` 24) . fromIntegral++shiftL32 :: (Bits b, Integral b) => Word8 -> b+shiftL32 = (`shiftL` 32) . fromIntegral++shiftL40 :: (Bits b, Integral b) => Word8 -> b+shiftL40 = (`shiftL` 40) . fromIntegral++shiftL48 :: (Bits b, Integral b) => Word8 -> b+shiftL48 = (`shiftL` 48) . fromIntegral++shiftL56 :: (Bits b, Integral b) => Word8 -> b+shiftL56 = (`shiftL` 56) . fromIntegral+++++hex2 :: Integral a => a -> ShowS+hex2 a | a < 0      = showString "-ve"+       | a < 0x10   = showString "0x0" . showHex a+       | otherwise  = showString "0x"  . showHex a +++hex4 :: Integral a => a -> ShowS+hex4 a | a < 0      = showString "-ve"+       | a < 0x10   = showString "0x000" . showHex a+       | a < 0x100  = showString "0x00"  . showHex a +       | a < 0x1000 = showString "0x0"   . showHex a +       | otherwise  = showString "0x"    . showHex a ++hex8 :: Integral a => a -> ShowS+hex8 a | a < 0          = showString "-ve"+       | a < 0x10       = showString "0x0000000" . showHex a+       | a < 0x100      = showString "0x000000"  . showHex a +       | a < 0x1000     = showString "0x00000"   . showHex a +       | a < 0x10000    = showString "0x0000"    . showHex a +       | a < 0x100000   = showString "0x000"     . showHex a +       | a < 0x1000000  = showString "0x00"      . showHex a +       | a < 0x10000000 = showString "0x0"       . showHex a +       | otherwise      = showString "0x"        . showHex a
+ src/Data/ParserCombinators/KangarooRWS.hs view
@@ -0,0 +1,112 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Data.ParserCombinators.KangarooRWS+-- Copyright   :  (c) Stephen Tetley 2009+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  to be determined.+--+-- Kangaroo parse monad with user env, logging and state.+--+--------------------------------------------------------------------------------++module Data.ParserCombinators.KangarooRWS+  (+    module Data.ParserCombinators.Kangaroo.Combinators+  , module Data.ParserCombinators.Kangaroo.ParseMonad+  , module Data.ParserCombinators.Kangaroo.Prim+  , module Data.ParserCombinators.Kangaroo.Utils+  , Kangaroo+  , parse+  , runKangaroo+  , evalKangaroo+  , execKangaroo+  , put+  , get+  , modify+  , gets+  , tell+  , ask++  ) where++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 Control.Monad+import Data.Monoid++type Kangaroo r w st a = GenKangaroo (r,w,st) a+++values :: (a,(r,w,st)) -> (a,w,st)+values (ans,(_,w,ust)) = (ans,w,ust)+++state3 :: (r,w,st) -> st+state3 (_,_,st) = st++env3 :: (r,w,st) -> r+env3 (r,_,_) = r++parse :: Monoid w +      => Kangaroo r w st a +      -> r +      -> st +      -> FilePath +      -> IO (Either ParseErr a)+parse = liftM fst `Specs.oooo` evalKangaroo ++runKangaroo :: Monoid w +            => Kangaroo r w st a +            -> r +            -> st +            -> FilePath +            -> IO (Either ParseErr a,w,st)+runKangaroo p env st filename = +    liftM values $ runGenKangaroo p (env,mempty,st) filename++-- answer, no state+evalKangaroo :: Monoid w +             => Kangaroo r w st a +             -> r +             -> st +             -> FilePath +             -> IO (Either ParseErr a,w)+evalKangaroo = liftM fn `Specs.oooo` runKangaroo where+    fn (a,w,_) = (a,w)++-- state, no answer+execKangaroo :: Monoid w +             => Kangaroo r w st a +             -> r +             -> st +             -> FilePath +             -> IO st+execKangaroo = liftM state3 `Specs.oooo` runKangaroo + ++put :: st -> Kangaroo r w st ()+put st = getUserSt >>= \(r,w,_) -> putUserSt (r,w,st)++get :: Kangaroo r w st st+get = liftM state3 getUserSt ++modify :: (st -> st) -> Kangaroo r w st ()+modify f = getUserSt >>= \(r,w,st) -> putUserSt (r,w,f st)++gets :: (st -> a) -> Kangaroo r w st a+gets f = liftM f get++tell :: Monoid w => w -> Kangaroo r w st ()+tell s = getUserSt >>= \(r,w,st) -> putUserSt (r,w `mappend` s,st)++ask :: Kangaroo r w st r+ask = liftM env3 getUserSt
+ src/Data/ParserCombinators/KangarooReader.hs view
@@ -0,0 +1,53 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Data.ParserCombinators.KangarooReader+-- Copyright   :  (c) Stephen Tetley 2009+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  to be determined.+--+-- Kangaroo parse monad with env.+--+--------------------------------------------------------------------------------++module Data.ParserCombinators.KangarooReader+  (+    module Data.ParserCombinators.Kangaroo.Combinators+  , module Data.ParserCombinators.Kangaroo.ParseMonad+  , module Data.ParserCombinators.Kangaroo.Prim+  , module Data.ParserCombinators.Kangaroo.Utils+  , Kangaroo+  , parse+  , runKangaroo+  , ask++  ) where++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 Control.Monad ( liftM )++type Kangaroo e a = GenKangaroo e a+++parse :: Kangaroo e a  +      -> e+      -> FilePath +      -> IO (Either ParseErr a)+parse = runKangaroo ++runKangaroo :: Kangaroo e a+            -> e+            -> FilePath +            -> IO (Either ParseErr a)+runKangaroo p env filename = liftM fst (runGenKangaroo p env filename)++ask :: Kangaroo e e+ask = getUserSt
+ src/Data/ParserCombinators/KangarooState.hs view
@@ -0,0 +1,70 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Data.ParserCombinators.KangarooState+-- Copyright   :  (c) Stephen Tetley 2009+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  to be determined.+--+-- Kangaroo parse monad with user state.+--+--------------------------------------------------------------------------------++module Data.ParserCombinators.KangarooState+  (+    module Data.ParserCombinators.Kangaroo.Combinators+  , module Data.ParserCombinators.Kangaroo.ParseMonad+  , module Data.ParserCombinators.Kangaroo.Prim+  , module Data.ParserCombinators.Kangaroo.Utils+  , Kangaroo+  , parse+  , runKangaroo+  , evalKangaroo+  , execKangaroo+  , put+  , get+  , modify+  , gets++  ) where++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 Control.Monad++type Kangaroo st a = GenKangaroo st a++parse :: Kangaroo st a -> st -> FilePath -> IO (Either ParseErr a)+parse = evalKangaroo++runKangaroo :: Kangaroo st a -> st -> FilePath -> IO (Either ParseErr a,st)+runKangaroo p st filename = runGenKangaroo p st filename++-- answer, no state+evalKangaroo :: Kangaroo st a -> st -> FilePath -> IO (Either ParseErr a)+evalKangaroo = liftM fst `Specs.ooo` runKangaroo++-- state, no answer+execKangaroo :: Kangaroo st a -> st -> FilePath -> IO st+execKangaroo = liftM snd `Specs.ooo` runKangaroo+++put :: st -> Kangaroo st ()+put = putUserSt++get :: Kangaroo st st+get = getUserSt++modify :: (st -> st) -> Kangaroo st ()+modify = modifyUserSt++gets :: (st -> a) -> Kangaroo st a+gets f = liftM f get
+ src/Data/ParserCombinators/KangarooWriter.hs view
@@ -0,0 +1,53 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Data.ParserCombinators.KangarooWriter+-- Copyright   :  (c) Stephen Tetley 2009+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  to be determined.+--+-- Kangaroo parse monad with logging.+--+--------------------------------------------------------------------------------++module Data.ParserCombinators.KangarooWriter+  (+    module Data.ParserCombinators.Kangaroo.Combinators+  , module Data.ParserCombinators.Kangaroo.ParseMonad+  , module Data.ParserCombinators.Kangaroo.Prim+  , module Data.ParserCombinators.Kangaroo.Utils+  , Kangaroo+  , parse+  , runKangaroo+  , tell++  ) where++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++type Kangaroo r a = GenKangaroo r a+++parse :: Monoid w +      => Kangaroo w a  +      -> FilePath +      -> IO (Either ParseErr a,w)+parse = runKangaroo ++runKangaroo :: Monoid w +            => Kangaroo w a+            -> FilePath +            -> IO (Either ParseErr a,w)+runKangaroo p filename = runGenKangaroo p mempty filename++tell :: Monoid w => w -> Kangaroo w ()+tell s = getUserSt >>= \w -> putUserSt $ w `mappend` s
+ test/Picklers.hs view
@@ -0,0 +1,50 @@+{-# 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.Char8 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 :: Char -> Pickle -> Pickle+cons c = RevBS . BS.cons c . getRevBS ++putCString :: String -> Pickle -> Pickle+putCString s pkl = putWord8 0 $ foldl' (flip cons) pkl s++putWord8 :: Word8 -> Pickle -> Pickle+putWord8 w = cons (chr $ fromIntegral w)++-- TODO +cstring :: String -> Pickle+cstring = putCString `flip` empty