Mullein M2

Copperbox revision 1112.

I've added some Kure boilerplate to make traversals more systematic, however it might not stay in for long as I've decided I don't want overlays in the syntax tree. Moving overlays to a post-processing step will simplify things and possibly remove the need for complicated traversals.

KURE

I've been using Andy Gill's KURE, unfortunately there aren't many examples on the web. Here are two versions of Company the SYB example. One version has handwritten bolierplate, they other uses kure-your-boilerplate. The Template Haskell generated by kyb has problems with the monomorphism restriction - it needs to be turned off, otherwise there will be type errors for crushU. Also the Generic union type - here CGeneric - needs a (hand-coded) instance of Term where the Generic is its own Generic root!

{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE NoMonomorphismRestriction  #-}
{-# OPTIONS -Wall #-}

-- NOTE - without NoMonomorphismRestriction, the generated 
-- function crushU has type errors


module Company where

import Language.KURE
import Language.KURE.Boilerplate

import Control.Monad
import Control.Monad.Identity
import Data.Monoid



data Company  = C [Dept]               deriving (Eq, Show)
data Dept     = D Name Manager [Unt]   deriving (Eq, Show)
data Unt      = PU Employee | DU Dept  deriving (Eq, Show)
data Employee = E Person Salary        deriving (Eq, Show)
data Person   = P Name Address         deriving (Eq, Show)
data Salary   = S Float                deriving (Eq, Show, Ord)
type Manager  = Employee
type Name     = String
type Address  = String

-- An illustrative company
genCom :: Company
genCom = C [D "Research" joe  [PU mike, PU kate],
            D "Strategy" mary []]

joe, mike, kate, mary :: Employee
joe  = E (P "Joe"  "Oregon") (S 8000)
mike = E (P "Mike" "Boston") (S 1000)
kate = E (P "Kate" "San Diego") (S 2000)
mary = E (P "Mary" "Washington") (S 100000)


data CGeneric = GCompany  Company
              | GDept     Dept
              | GUnt      Unt
              | GEmployee Employee
              | GPerson   Person
              | GSalary   Salary

instance Term Company where
  type Generic Company  = CGeneric
  inject                = GCompany
  select (GCompany a)   = Just a
  select _              = Nothing               

instance Term Dept where
  type Generic Dept     = CGeneric
  inject                = GDept
  select (GDept a)      = Just a
  select _              = Nothing               

instance Term Unt where
  type Generic Unt      = CGeneric
  inject                = GUnt
  select (GUnt a)       = Just a
  select _              = Nothing               

instance Term Employee where
  type Generic Employee = CGeneric
  inject                = GEmployee
  select (GEmployee a)  = Just a
  select _              = Nothing               

instance Term Person where
  type Generic Person   = CGeneric
  inject                = GPerson
  select (GPerson a)    = Just a
  select _              = Nothing               


instance Term Salary where
  type Generic Salary   = CGeneric
  inject                = GSalary
  select (GSalary a)    = Just a
  select _              = Nothing               

instance Term CGeneric where
  type Generic CGeneric = CGeneric  -- CGeneric is its own Generic root.
  inject    = id
  select e  = return e


$(kureYourBoilerplate ''CGeneric [(''Identity, ''())])

incS :: Float -> Salary -> Salary
incS k (S s) = S (s * (1+k))



--- Increase salary

-- increase everyone's salary by 10%, topdown.
-- transformer, non-contextual, full, topdown, left-to-right
-- f1 :: Data t => Float -> t -> Maybe t
-- f1 k = traverse Trans NoCtx Full FromTop FromLeft (always $ incS k)

rewriteStep :: Float -> Rewrite Identity () Salary
rewriteStep k = rewrite $ \ e -> return (incS k e)



f1 :: (CGeneric ~ Generic exp, Term exp) 
   => Float -> Rewrite Identity () exp
f1 k = extractR $ topdownR $ tryR $ promoteR (rewriteStep k)


demo1 :: IO ()
demo1 = do 
    print $ runIdentity $ runRewrite (f1 0.10) () genCom
    print $ runIdentity $ runRewrite (f1 0.10) () joe
    print $ runIdentity $ runRewrite (f1 0.10) () (S 10000.0)

Here's a version with handwritten boilerplate, note that the Generic union type (CGeneric) needs a Walker instance just like the other types:

{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# OPTIONS -Wall #-}

module Company where

import Language.KURE

import Control.Monad
import Control.Monad.Identity
import Data.Monoid



data Company  = C [Dept]               deriving (Eq, Show)
data Dept     = D Name Manager [Unt]   deriving (Eq, Show)
data Unt      = PU Employee | DU Dept  deriving (Eq, Show)
data Employee = E Person Salary        deriving (Eq, Show)
data Person   = P Name Address         deriving (Eq, Show)
data Salary   = S Float                deriving (Eq, Show, Ord)
type Manager  = Employee
type Name     = String
type Address  = String

-- An illustrative company
genCom :: Company
genCom = C [D "Research" joe  [PU mike, PU kate],
            D "Strategy" mary []]

joe, mike, kate, mary :: Employee
joe  = E (P "Joe"  "Oregon") (S 8000)
mike = E (P "Mike" "Boston") (S 1000)
kate = E (P "Kate" "San Diego") (S 2000)
mary = E (P "Mary" "Washington") (S 100000)


data CGeneric = GCompany  Company
              | GDept     Dept
              | GUnt      Unt
              | GEmployee Employee
              | GPerson   Person
              | GSalary   Salary

instance Term Company where
  type Generic Company  = CGeneric
  inject                = GCompany
  select (GCompany a)   = Just a
  select _              = Nothing               

instance Term Dept where
  type Generic Dept     = CGeneric
  inject                = GDept
  select (GDept a)      = Just a
  select _              = Nothing               

instance Term Unt where
  type Generic Unt      = CGeneric
  inject                = GUnt
  select (GUnt a)       = Just a
  select _              = Nothing               

instance Term Employee where
  type Generic Employee = CGeneric
  inject                = GEmployee
  select (GEmployee a)  = Just a
  select _              = Nothing               

instance Term Person where
  type Generic Person   = CGeneric
  inject                = GPerson
  select (GPerson a)    = Just a
  select _              = Nothing               

instance Term Salary where
  type Generic Salary   = CGeneric
  inject                = GSalary
  select (GSalary a)    = Just a
  select _              = Nothing               

instance Term CGeneric where
  type Generic CGeneric = CGeneric  -- CGeneric is its own Generic root.
  inject    = id
  select e  = return e


instance (Monoid dec, Monad m) => Walker m dec Company where
  allR rr   = companyR (extractR rr)
  crushU rr = companyU (extractU rr)


companyR :: (Monoid dec, Monad m) 
         => Rewrite m dec Dept -> Rewrite m dec Company
companyR rr = transparently $ translate $ \ (C xs) -> 
    liftM C (mapM (apply rr) xs)
   

companyU :: (Monad m, Monoid dec, Monoid r)
         => Translate m dec Dept r -> Translate m dec Company r
companyU rr = translate $ \ (C xs) -> 
    liftM mconcat $ mapM (apply rr) xs


instance (Monoid dec, Monad m) => Walker m dec Dept where
  allR rr   = deptR (extractR rr) (extractR rr)
  crushU rr = deptU (extractU rr) (extractU rr)


deptR :: (Monoid dec, Monad m) 
    => Rewrite m dec Employee -> Rewrite m dec Unt -> Rewrite m dec Dept
deptR rr1 rr2  = transparently $ translate $ \ (D name m us) -> 
    liftM2 (D name) (apply rr1 m) (mapM (apply rr2) us)
   

deptU :: (Monad m, Monoid dec, Monoid r)
     => Translate m dec Employee r -> Translate m dec Unt r
     -> Translate m dec Dept r 
deptU rr1 rr2 = translate $ \ (D _ a xs) -> 
    liftM2 mappend (apply rr1 a) (liftM mconcat (mapM (apply rr2) xs))




instance (Monoid dec, Monad m) => Walker m dec Unt where
  allR rr   = puR (extractR rr) 
           <+ duR (extractR rr)
  crushU rr = puU (extractU rr) 
           <+ duU (extractU rr)


puR :: (Monoid dec, Monad m) 
    => Rewrite m dec Employee -> Rewrite m dec Unt
puR rr = transparently $ translate $ \ e -> case e of
    PU e1 -> liftM PU (apply rr e1)
    _     -> fail "puR"

puU :: (Monad m, Monoid dec, Monoid r)
     => Translate m dec Employee r -> Translate m dec Unt r
puU rr = translate $ \ e -> case e of 
    PU e1 -> apply rr e1
    _     -> fail "puU"

duR :: (Monoid dec, Monad m) 
    => Rewrite m dec Dept -> Rewrite m dec Unt
duR rr = transparently $ translate $ \ e -> case e of
    DU d1 -> liftM DU (apply rr d1)
    _     -> fail "duR"

duU :: (Monad m, Monoid dec, Monoid r)
     => Translate m dec Dept r -> Translate m dec Unt r
duU rr = translate $ \ e -> case e of 
    DU d1 -> apply rr d1
    _     -> fail "duU"


instance (Monoid dec, Monad m) => Walker m dec Employee where
  allR rr   = employeeR (extractR rr) (extractR rr)
  crushU rr = employeeU (extractU rr) (extractU rr)


employeeR :: (Monoid dec, Monad m) 
          => Rewrite m dec Person -> Rewrite m dec Salary 
          -> Rewrite m dec Employee
employeeR rr1 rr2 = transparently $ translate $ \ (E p s) ->
    liftM2 E (apply rr1 p) (apply rr2 s)

employeeU :: (Monad m, Monoid dec, Monoid r)
          => Translate m dec Person r -> Translate m dec Salary r
          -> Translate m dec Employee r
employeeU rr1 rr2 = translate $ \ (E p s) ->
    liftM2 mappend (apply rr1 p) (apply rr2 s)


instance (Monoid dec, Monad m) => Walker m dec Person where
  allR _   = personR
  crushU _ = personU

personR :: (Monoid dec, Monad m)
        => Rewrite m dec Person
personR = transparently $ rewrite $ return 

personU :: (Monad m, Monoid dec, Monoid r)
        => Translate m dec Person r
personU = translate $ \ _ -> return mempty


instance (Monoid dec, Monad m) => Walker m dec Salary where
  allR _   = salaryR
  crushU _ = salaryU

salaryR :: (Monoid dec, Monad m)
        => Rewrite m dec Salary
salaryR = transparently $ rewrite $ return 

salaryU :: (Monad m, Monoid dec, Monoid r)
        => Translate m dec Salary r
salaryU = translate $ \ _ -> return mempty



instance (Monoid dec, Monad m) => Walker m dec CGeneric where
  allR rr = promoteR (companyR (extractR rr))
         <+ promoteR (deptR (extractR rr) (extractR rr))
         <+ promoteR (puR (extractR rr) <+ duR (extractR rr))
         <+ promoteR (employeeR (extractR rr) (extractR rr))
         <+ promoteR personR
         <+ promoteR salaryR
  crushU rr = promoteU (companyU (extractU rr))
           <+ promoteU (deptU (extractU rr) (extractU rr))
           <+ promoteU (puU (extractU rr) <+ duU (extractU rr))
           <+ promoteU (employeeU (extractU rr) (extractU rr))
           <+ promoteU personU
           <+ promoteU salaryU



incS :: Float -> Salary -> Salary
incS k (S s) = S (s * (1+k))



--- Increase salary

-- increase everyone's salary by 10%, topdown.
-- transformer, non-contextual, full, topdown, left-to-right
-- f1 :: Data t => Float -> t -> Maybe t
-- f1 k = traverse Trans NoCtx Full FromTop FromLeft (always $ incS k)

rewriteStep :: (Monad m, Monoid dec) => Float -> Rewrite m dec Salary
rewriteStep k = rewrite $ \ e -> return (incS k e)


f1 :: (Monad m, Monoid dec, Term exp, CGeneric ~ Generic exp) 
   => Float -> Rewrite m dec exp
f1 k = extractR $ topdownR $ tryR $ promoteR (rewriteStep k)


demo1 :: IO ()
demo1 = do 
    print $ runIdentity $ runRewrite (f1 0.10) () genCom
    print $ runIdentity $ runRewrite (f1 0.10) () joe
    print $ runIdentity $ runRewrite (f1 0.10) () (S 10000.0)

Mullein M2

Copperbox revision 1111.

More work on M2, Mullein's successor. I've added some of the LilyPond code from Mullein, though much of it is commented out as I haven't looked at the translation code yet.

data-aviary

Copperbox revision 1110.

I've added a new Birds module with revised type signatures, I think the new naming scheme is a bit clearer.

arity-lib

Copperbox revision 1109.

I've started a new package to collect extended arity versions of my favourite combinators. As the new revision of Mullein will no doubt use some, its seems a good time to look at them systematically.

Mullein M2

Copperbox revision 1108.

Initial work on a new version of Mullein, provisionally called M2 - I'll give it a distinct new name once I think of a good one.

I don't really want work on the old code and still call it Mullein as a lot of code needs to change and I always find it dispiriting working with a sandbox where much of the code is broken. The syntax tree needs significant changes to accommodate triplets and duplets, plus I don't like the way I previously handled updating traversals on the old tree.

Hurdle and Kangaroo

Copperbox revision 1107.

I've made new release archives, while I'm not sure how much work I want to put into them the existing versions on Hackage aren't very good, so they merit improving.

kangaroo

Copperbox revision 1106.

I've improved the MIDI pretty printer so it produces output as it goes along rather than building a large doc and rendering it at the end.

kangaroo

Copperbox revision 1105.

A round of tidying up - unfortunately there's an awful lot still to polish.

SFont - ZFont

Copperbox revision 1103 & 1104.

I've renamed the SFont package ZFont.

Hurdle, SFont and Kangaroo

Copperbox revision 1102.

Updates to Hurdle and SFont to make them run with the latest Kangaroo.

SFont will need its naming changing in due course as there is another project called SFont.

kangaroo

Copperbox revision 1101.

I've sorted out the region boundary problem that was causing the MIDI reader to fail. The nub was that I hadn't really thought about whether the region start and end values were inclusive or not. Once I realized I hadn't thought about this it was easy to consider them to be inclusive (the right choice) and change the region creation code accordingly.

kangaroo

Copperbox revision 1100.

I've improved the hex dump code quite a bit - it still is rather inefficient though.

kangaroo

Copperbox revision 1099.

I've added a Debug module to Kangaroo. Now that I'm starting to work with JoinPrint its looking rather crummy and will need some substantial revision; so I'm check-pointing it now before I get to enthusiastic in changing it.

kangaroo

Copperbox revision 1098.

Some work on regions, though not much progress. I've made cursor moving failure-free whether or not a move puts the cursor past the end of file. I tried encoding end-of-file as a constructor in the Pos data type but it added complexity rather than unanimously improving correctness.

kangaroo

Copperbox revision 1097.

I've improved the region handling with better error reporting. The parse monad still has a boundary error when it reaches the end of a region - maybe I'll have to extend the position type so it explicitly represents EOF / EOR (end-of-region).

kangaroo

Copperbox revision 1096.

I've extracted the region handling code from the parse monad into a separate module. Its still not working correctly but it should be easier to pin down what's wrong now that its outside the monad code.

data-aviary

Copperbox revision 1095.

Completed all the specializations for Data.Aviary.Functional - Applicative, Monad, Category, Arrow and Comonad. Made a new release archive.

data-aviary

Copperbox revision 1094.

I've added a new module to Data-Aviary that specializes operations from Applicative, Monad etc. to the function type. This might be useful for spotting patterns in the type signatures of the operations that might not be obvious in their more general (type-class) type.

For instance to work with records I have a family of 'substs' - extended arity versions of the S (Starling) combinator:

subst :: (r -> a -> b) -> (r -> a) -> r -> b
subst f g x = f x (g x)

subst2 :: (r -> a -> b -> c) -> (r -> a) -> (r -> b) -> r -> c
subst2 f g h x = f x (g x) (h x)

subst3 :: (r -> a -> b -> c -> d) -> (r -> a) -> (r -> b) -> (r -> c) -> r -> d
subst3 f g h i x = f x (g x) (h x) (i x)

Now because I don't use them too often, when I go back to them I'll often think "Oh, they're just liftA2, liftA3" and swap them in the code introducing new type errors everywhere. I tend to forget that liftA2, liftA3 are a family of S' combinators rather than S combinators:

liftA  :: (a -> b) -> (r -> a) -> r -> b
liftA2 :: (a -> b -> c) -> (r -> a) -> (r -> b) -> r -> c
liftA3 :: (a -> b -> c -> d) -> (r -> a) -> (r -> b) -> (r -> c) -> r -> d

OpenVG binding

Copperbox revision 1093.

I've made new releases with the improvements to the Image, Paths and RenderingQuality modules.

Versions are: OpenVG-0.6.0, OpenVGRaw-0.2.0

OpenVG binding

Copperbox revision 1092.

I've revised the Image module so it no longer exports functions with raw pointers in their signatures for pixel data. Instead pixel data is encapsulated in an opaque type.

That said - the PixelData type as currently implemented might not be sufficient to actually use. Particularly, I don't quite see where to actually create PixelData.

OpenVG binding

Copperbox revision 1091.

The opaque matrix type is now used in in the interface of the RenderingQuality module, none of the functions export a pointer type any more (some other modules in the higher level package still export raw pointers and these need work). The matrix is marshalled in and out with a list to follow HOpenGL's example however it might be better to define a simple 3x3 matrix type.

OpenVGRaw had a bad type signature for vgGetMatrix, so I've corrected that.

OpenVG binding

Copperbox revision 1090.

Initial work adding an opaque and safe matrix type. The code is derived from the Matrix type class in HOpenGL but as matrices are simpler in OpenVG I don't need a type class (there is only one matrix type).

OpenVG binding

Copperbox revision 1089.

Release archives for OpenVG-0.5.0 and OpenVGRaw-0.1.0. Some minor formatting changes to modules in OpenVG that had been pending a commit since before the new year.

precis

Copperbox revisions 1087 & 1088.

I've decided to use Cabal's machinery to parse cabal files even though I only want a few fields. The structure of cabal files is more complex than I thought, plus I couldn't make a good formulation of island parsing (and I've tried many times).

precis

Copperbox revision 1085.

Maybe this will be a bad idea, but I've started implementing a Haskell lexer with Parsec. I'm not bothered about performance so I don't mind Parsec on that score; but I am a bit concerned that the lexer spec in the H98 report relies on longest match - this might not be easily achievable with parser combinators.

Revision 1086 - deleted a wrongly created directory.

precis

Copperbox revision 1084.

Some improvements to the fact extracting parser for Cabal files, it still doesn't handle nested indenting properly though.

precis

Copperbox revision 1083.

I've made the cabal parser more intelligible. For some reason though, it throws a parse error on white space as it parses 'library' sections.

precis

Copperbox revision 1082.

More work on the fact extracting parser for Cabal files. The parser is somewhat closer to the style I had in mind, though its far too impenetrable at the moment (only I could decipher how it works).

precis

Copperbox revision 1081.

I've added a new project: Precis. The aim is to produce summaries of Cabal projects. The recent work on zparse was to make it capable for writing 'fact extracting' parsers, but I've decided to go with Parsec instead. I don't yet have Parsec code to extract facts and ignore 'water' but I've written the line- and indent-sensitive combinators that I was trying to do in zparse.

zparse

Copperbox revision 1080.

Changes to the Parse type - it no longer returns unconsumed input (unconsumed input is available at the end of parse, as it is in the state). I've only come up with one usefully different combinator to Parsec though (withinLine) and I could code this in Parsec quite easily. So I don't think I'm going in the right direction...

zparse

Copperbox revision 1079.

I've deleted Perms - the action-permutations package provides Applicative versions of the perm operations, and I think I prefer its interface to the Parsec one.

zparse

Copperbox revision 1078.

I've added permutation parsers derived from Parsec and the paper "Parsing Permutation Phrases". Perms have no dependency on parsing machinery and just need the Alternative type class.

zparse

Copperbox revision 1077.

I've fixed a long standing, but unnoticed bug in the definition of manyTill and added a manyTill1 combinator. I've also changed the type of the run function for character parsers so it returns the remaining input if there is any.

zparse

Copperbox revision 1076.

I've filled out the Lexical module, so to some degree the easy bits are now in place (with a caveat that ParseError, at least, doesn't work properly). The tough parts are next - like stacking lexical (character consuming) parsers with token consuming parsers.

zparse

Copperbox revision 1075.

More work on zparse - initial work on lexical level parsing and error reporting.

zparse

Copperbox revision 1074.

I've resurrected ZParse, at least for the moment, as there is some character level parsing I want to do which I don't want to use Parsec for. Whether or not it will be too much trouble to get ZParse working is another matter.

resumptions

More resumptions, here's a translation of the code from Andrzej Filinski's 'Representing Layered Monads'. I think the translation is accurate, except par in the version below has deterministic scheduling:

{-# OPTIONS -Wall #-}

module FilinskiConc where

data ResT m a = Done a | Susp (m (ResT m a))

instance Monad m => Monad (ResT m) where
  return = Done
  (Done v) >>= f = f v
  (Susp r) >>= f = Susp (r >>= \k -> return (k >>= f))


step :: Monad m => m a -> ResT m a
step x = Susp $ x >>= (return . Done)

yield :: Monad m => ResT m ()
yield = Susp (return (return ()))

pOr :: Monad m => ResT m Bool -> ResT m Bool -> ResT m Bool
pOr (Done True)  _  = Done True
pOr (Done False) p  = p
pOr (Susp t1)    t2 = Susp $ t1 >>= \r -> return (pOr t2 r)


atomically :: Monad m => ResT m a -> ResT m a
atomically = work `flip` False where
    work (Done a) False = step (return a)
    work (Done a) True  = Done a
    work (Susp t) _     = do { a <- step t ; work a True }

-- Unlike Filinkski's 'par' the 'par' here has a deterministic 
-- scheduler - we do one step of a and one step of b at each
-- turn.
--
par :: Monad m => ResT m a -> ResT m b -> ResT m (a,b)
par (Done a)  (Done b)  = Done (a,b)
par (Done a)  (Susp tb) = Susp $ tb >>= \r -> return (r >>= \b -> Done (a,b))
par (Susp ta) (Done b)  = Susp $ ta >>= \r -> return (r >>= \a -> Done (a,b))
par (Susp ta) (Susp tb) = do { a <- step ta; b <- step tb; par a b }


run :: Monad m => ResT m a -> m a
run (Susp phi)  = phi >>= run
run (Done v)    = return v


demo1 :: IO ((),())
demo1 = run  (par (step $ putStrLn "a") (step $ putStrLn "b"))

demo2 :: IO Bool
demo2 = run  (pOr (step $ do { putStrLn "a"; return False} ) 
                  (step $ do { putStrLn "b"; return True} ))

asteps, bsteps :: ResT IO [()]
asteps = mapM (step . putChar) "aaaaaaa"
bsteps = mapM (step . putChar) "bbbbb"

demo3 :: IO ([()],[()])
demo3 = run (par asteps bsteps)

resumptions

I can't seem to find enough examples of using resumption monads for my taste.

Here is the code from William Harrison et al's code from 'Asynchronous Exceptions As An Effect' re-written with standard machinery (i.e. with monads from mtl).

--

{-# LANGUAGE TypeSynonymInstances       #-}
{-# OPTIONS -Wall #-}


module AsyncE where


import Control.Monad.Error


merge :: [[a]] -> [a]
merge = concat


data Err = Error 
  deriving Show

instance Error Err where
  noMsg = Error
  strMsg = const Error

data ResT m a = Done a | Pause (m (ResT m a))


instance Monad m => Monad (ResT m) where
  return = Done
  Done v >>= f = f v
  Pause phi >>= f = Pause $ phi >>= \k -> return (k >>= f)

type N a = [a]

type R = ResT E


type E = ErrorT Err []



instance Show a => Show (E a) where
  show = show . runErrorT


instance Show a => Show (R a) where
  show (Done a) = "Done " ++ show a
  show (Pause phi) = "Pause " ++ show phi



ok :: a -> Either Err a
ok = Right

err :: Either Err a
err = Left Error

-- page 7 examples
ex1 :: N Int
ex2 :: E Int
ex3 :: N Int
ex4 :: E Int

ex1 = return 9
ex2 = return 9
ex3 = [1,2,3] >>= (\v -> return (v+1))
ex4 = (ErrorT [ok 1, ok 2, err]) >>= (\v -> return (v+1))


step :: E a -> R a
step x = Pause (x >>= (return . Done))



run :: R a -> E a
run (Pause phi) = phi >>= run
run (Done v)    = return v


ex5 :: E Int
ex5 = run (step (ErrorT [ok 1, ok 2, err]))

mergeN :: N (N a) -> N a
mergeN = concat


mergeE :: N (E a) -> E a
mergeE = ErrorT . mergeN . map runErrorT


mergeR :: N (R a) -> R a
mergeR xs = Pause (mergeE (map return xs))


-- page 8 examples
ex6 :: N Int
ex6 = mergeN [[1,2],[4]]

ex7 :: E Int
ex7 = mergeE [ (ErrorT [ok 1, ok 2, err]), (ErrorT [ok 4,err])]

bindN :: [a] -> (a -> [b]) -> [b]
bindN = (>>=)

etaN :: a -> [a]
etaN = return 




statusE :: E a -> E (Either Err a)
statusE phi = ErrorT $  
  (runErrorT phi) >>= \v -> 
    case v of
      Right y -> return (Right (Right y))
      Left Error  -> return (Left Error)


statusR :: R a -> R (Either Err a)
statusR (Pause phi) = 
    Pause $ (statusE phi) >>=  \v ->
              case v of
                Right x -> return (statusR x)
                Left Error  -> return (Done (Left Error)) 
    
statusR (Done v) = (Done (ok v))


throwE :: E a
throwE = ErrorT $ return (Left Error)

throwR :: R a
throwR = step throwE

fork :: R a -> R a
fork phi = mergeR [ phi, throwR ]


catchE :: E a -> E a -> E a
catchE phi gamma = (statusE phi) >>= \s ->
                          case s of 
                            Right v -> return v
                            Left Error  -> gamma

catchR :: R a -> R a -> R a
catchR phi gamma = (statusR phi) >>= \s ->
                          case s of 
                            Right v -> return v
                            Left Error  -> gamma


-- page 8 and 9 examples

ex8 :: E a
ex8 = throwE

ex9 :: E Int
ex9 = throwE >>= \v -> return (v + 1)

ex10 :: E (Either Err a)
ex10 = statusE throwE

ex11 :: E (Either Err Int)
ex11 = statusE (return 9) 


ex12 :: E Int
ex12 = catchE throwE (return 9)

ex13 :: R Int
ex13 = fork (return 9)

ex14 :: E Int
ex14 = run (fork (return 9))


-- Section 4

data Expr = Val Int
          | Add Expr Expr
          | Seqn Expr Expr
          | Throw
          | Catch Expr Expr
          | Block Expr
          | Unblock Expr
  deriving (Show)




evB :: Expr -> R Int
evB (Val i)       = step (return i)
evB (Add e1 e2)   = (evB e1) >>= \v1 ->
                    (evB e2) >>= \v2 ->
                      return (v1 + v2)
evB (Seqn e1 e2)  = (evB e1) >> (evB e2)
evB Throw         = throwR
evB (Catch e1 e2) = catchR (evB e1) (evB e2)
evB (Block e)     = (evB e)
evB (Unblock e)   = (evU e)

evU :: Expr -> R Int
evU (Val i)       = fork (step (return i))
evU (Add e1 e2)   = fork ((evU e1) >>= \v1 ->
                          (evU e2) >>= \v2 ->
                          return (v1 + v2))
evU (Seqn e1 e2)  = fork ((evU e1) >> (evU e2))
evU Throw         = fork throwR
evU (Catch e1 e2) = fork (catchR (evU e1) (evU e2))
evU (Block e)     = fork (evB e)
evU (Unblock e)   = fork (evU e)

ex15 :: E Int
ex15 = run (evU (Add (Val 1) (Val 2)))

kangaroo

Copperbox revision 1073.

I've reverted the changes made to ParseMonad in revision 1072, as the ByteString building parsers weren't useful.

Running the MIDI printer points to a persistent problem the intraparse parser - I'm not representing end-of-file in a useful way: the restrict combinator should be able to restrict to the the end-of-file and let the cursor go to the end-of-file (this is fine behaviour - it is only an error if an actually read is attempted at the end-of-file). Currently the restrict parser doesn't allow this and throws a range error if it tries to restrict to the end-of-file.

kangaroo

Copperbox revision 1072.

A unsuccessful attempt to add parsers for extract long sequences of chars or word8's. Here I was using ByteStrings - but cons on ByteStrings is expensive, so the optimization (going to the end and parsing backwards so cons is natural) didn't really improve things.

I'll take out the changes to ParseMonad in the next commit.

Hurdle and kangaroo

Copperbox revision 1071.

The stack printing now works in kangaroo. Hurdle's PECOFF parser seems to run again (it still has the problem with VC++ dlls), but the ar parser goes into an infinite loop.

** Update - the ar parser is just very slow - it uses [Char] in places where it shouldn't.

kangaroo

Copperbox revision 1069.

Small but valuable improvements to the ParseMonad code - I've added a new monadic control operator withSuccess. Maybe monads with error handling could do with some of the control operators from Control.Exception (but changed to work in the monad rather than IO of course).

kangaroo

Copperbox revision 1068.

Work fixing the bugs in the new intraparse function - the MIDI printer now works again.

kangaroo

Copperbox revision 1037.

I've improved the tabular and hexdump formatters in JoinPrint.

kangaroo

Copperbox revision 1066.

I've added a formatter for printing out hex dumps to JoinPrint.

kangaroo

Copperbox revision 1064.

I've added my own formatting library to Kangaroo to use instead of Text.PrettyPrint.HughesPJ.

Often I don't need the fitting behaviour of a proper printing library, so a couple of times I've half baked a simpler formatting library. With this one I'll attempt to make it a bit more than half baked.

Revision 1065 - adding another top-level import module - KangarooWriter.

kangaroo

Copperbox revision 1063.

I've changed to interface to intra-region parsers so the coda strategy is represented as an enumerated type rather than separate functions for each type (to do this is obvious in retrospect).

Unfortunately the MIDI parser has stopped working again, so I'm going to have to do some work on "debugging".