diff --git a/Generics/Instant.hs b/Generics/Instant.hs
new file mode 100644
--- /dev/null
+++ b/Generics/Instant.hs
@@ -0,0 +1,21 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Instant
+-- Copyright   :  (c) 2010, Universiteit Utrecht
+-- License     :  BSD3
+--
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Top-level module which re-exports the basic combinators and the generic
+-- instances for common datatypes.
+--
+-----------------------------------------------------------------------------
+
+module Generics.Instant (
+  module Generics.Instant.Base,
+  ) where
+  
+import Generics.Instant.Base
+import Generics.Instant.Instances ()
diff --git a/Generics/Instant/Base.hs b/Generics/Instant/Base.hs
new file mode 100644
--- /dev/null
+++ b/Generics/Instant/Base.hs
@@ -0,0 +1,84 @@
+{-# LANGUAGE TypeOperators            #-}
+{-# LANGUAGE TypeFamilies             #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Instant.Base
+-- Copyright   :  (c) 2010, Universiteit Utrecht
+-- License     :  BSD3
+--
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- This module defines the basic representation types and the conversion
+-- functions 'to' and 'from'. A typical instance for a user-defined datatype
+-- would be:
+-- 
+-- > -- Example datatype
+-- > data Exp = Const Int | Plus Exp Exp
+-- >
+-- > -- Auxiliary datatypes for constructor representations
+-- > data Const
+-- > data Plus
+-- > 
+-- > instance Constructor Const where conName _ = "Const"
+-- > instance Constructor Plus  where conName _ = "Plus"
+-- > 
+-- > -- Representable instance
+-- > instance Representable Exp where
+-- >   type Rep Exp = C Const (Var Int) :+: C Plus (Rec Exp :*: Rec Exp)
+-- > 
+-- >   from (Const n)   = L (C (Var n))
+-- >   from (Plus e e') = R (C (Rec e :*: Rec e'))
+-- > 
+-- >   to (L (C (Var n)))            = Const n
+-- >   to (R (C (Rec e :*: Rec e'))) = Plus e e'
+-- 
+-----------------------------------------------------------------------------
+
+module Generics.Instant.Base (
+      U(..), (:+:)(..), (:*:)(..), C(..), Var(..), Rec(..)
+    , Constructor(..), Fixity(..), Associativity(..)
+    , Representable(..)
+  ) where
+
+infixr 5 :+:
+infixr 6 :*:
+
+data U        = U           deriving (Show, Read)
+data a :+: b  = L a | R b   deriving (Show, Read)
+data a :*: b  = a :*: b     deriving (Show, Read)
+newtype C c a = C a         deriving (Show, Read)
+newtype Var a = Var a       deriving (Show, Read)
+newtype Rec a = Rec a       deriving (Show, Read)
+
+-- | Class for datatypes that represent data constructors.
+-- For non-symbolic constructors, only 'conName' has to be defined.
+class Constructor c where
+  conName   :: t c a -> String
+  conFixity :: t c a -> Fixity
+  conFixity = const Prefix
+  conIsRecord :: t c a -> Bool
+  conIsRecord = const False
+
+-- | Datatype to represent the fixity of a constructor. An infix declaration
+-- directly corresponds to an application of 'Infix'.
+data Fixity = Prefix | Infix Associativity Int
+  deriving (Eq, Show, Ord, Read)
+
+-- | Datatype to represent the associativy of a constructor.
+data Associativity = LeftAssociative | RightAssociative | NotAssociative
+  deriving (Eq, Show, Ord, Read)
+
+
+class Representable a where
+  type Rep a
+  to   :: Rep a -> a
+  from :: a -> Rep a
+  -- defaults
+  {-
+  type Rep a = a -- type synonyms defaults are not yet implemented!
+  to   = id
+  from = id
+  -}
diff --git a/Generics/Instant/Functions.hs b/Generics/Instant/Functions.hs
new file mode 100644
--- /dev/null
+++ b/Generics/Instant/Functions.hs
@@ -0,0 +1,23 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Instant.Functions
+-- Copyright   :  (c) 2010, Universiteit Utrecht
+-- License     :  BSD3
+--
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- This module simply reexports all the generic functions' modules.
+--
+-----------------------------------------------------------------------------
+
+module Generics.Instant.Functions (
+    module Generics.Instant.Functions.Empty,
+    module Generics.Instant.Functions.Show,
+    module Generics.Instant.Functions.Eq
+  ) where
+  
+import Generics.Instant.Functions.Empty
+import Generics.Instant.Functions.Show
+import Generics.Instant.Functions.Eq
diff --git a/Generics/Instant/Functions/Empty.hs b/Generics/Instant/Functions/Empty.hs
new file mode 100644
--- /dev/null
+++ b/Generics/Instant/Functions/Empty.hs
@@ -0,0 +1,109 @@
+{-# LANGUAGE ScopedTypeVariables      #-}
+{-# LANGUAGE TypeOperators            #-}
+{-# LANGUAGE FlexibleContexts         #-}
+{-# LANGUAGE OverlappingInstances     #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Instant.Functions.Empty
+-- Copyright   :  (c) 2010, Universiteit Utrecht
+-- License     :  BSD3
+--
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Generically produce a single finite value of a datatype.
+--
+-----------------------------------------------------------------------------
+
+module Generics.Instant.Functions.Empty (
+    Empty(..), empty,
+    HasRec(..)
+  ) where
+
+import Generics.Instant.Base
+import Generics.Instant.Instances ()
+
+-- Generic empty on Representable (worker)
+class Empty a where
+  empty' :: a
+
+instance Empty U where
+  empty' = U
+  
+instance (HasRec a, Empty a, Empty b) => Empty (a :+: b) where
+  empty' = if hasRec' (empty' :: a) then R empty' else L empty'
+  
+instance (Empty a, Empty b) => Empty (a :*: b) where
+  empty' = empty' :*: empty'
+  
+instance (Empty a) => Empty (C c a) where
+  empty' = C empty'
+
+instance (Empty a) => Empty (Var a) where
+  empty' = Var empty'
+
+instance (Empty a) => Empty (Rec a) where
+  empty' = Rec empty'
+
+instance Empty Int where
+  empty' = 0
+
+instance Empty Integer where
+  empty' = 0
+
+instance Empty Float where
+  empty' = 0
+
+instance Empty Double where
+  empty' = 0
+
+instance Empty Char where
+  empty' = '\NUL'
+  
+instance Empty Bool where
+  empty' = False
+
+
+-- Dispatcher
+empty :: (Representable a, Empty (Rep a)) => a
+empty = to empty'
+
+-- Adhoc instances
+-- none
+
+-- Generic instances
+instance (Empty a) => Empty (Maybe a)       where empty' = empty
+instance (Empty a) => Empty [a]             where empty' = empty
+instance (Empty a, Empty b) => Empty (a,b)  where empty' = empty
+
+
+--------------------------------------------------------------------------------
+-- | We use 'HasRec' to check for recursion in the structure. This is used 
+-- to avoid selecting a recursive branch in the sum case for 'Empty'.
+class HasRec a where
+  hasRec' :: a -> Bool
+  hasRec' _ = False
+  
+instance HasRec U
+instance HasRec (Var a)
+
+instance (HasRec a, HasRec b) => HasRec (a :*: b) where
+  hasRec' (a :*: b) = hasRec' a || hasRec' b
+  
+instance (HasRec a, HasRec b) => HasRec (a :+: b) where
+  hasRec' (L x) = hasRec' x
+  hasRec' (R x) = hasRec' x
+
+instance (HasRec a) => HasRec (C c a) where
+  hasRec' (C x) = hasRec' x
+  
+instance HasRec (Rec a) where
+  hasRec' _ = True
+  
+instance HasRec Int
+instance HasRec Integer
+instance HasRec Float
+instance HasRec Double
+instance HasRec Char
diff --git a/Generics/Instant/Functions/Eq.hs b/Generics/Instant/Functions/Eq.hs
new file mode 100644
--- /dev/null
+++ b/Generics/Instant/Functions/Eq.hs
@@ -0,0 +1,66 @@
+{-# LANGUAGE FlexibleContexts         #-}
+{-# LANGUAGE TypeOperators            #-}
+{-# LANGUAGE OverlappingInstances     #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Instant.Functions.Eq
+-- Copyright   :  (c) 2010, Universiteit Utrecht
+-- License     :  BSD3
+--
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- The equality function.
+--
+-----------------------------------------------------------------------------
+
+module Generics.Instant.Functions.Eq (Eq(..), eq) where
+
+import Generics.Instant.Base
+import Generics.Instant.Instances ()
+
+import Prelude hiding (Eq)
+
+-- Generic eq on Representable (worker)
+class Eq a where
+  eq' :: a -> a -> Bool
+
+instance Eq U where
+  eq' U U = True
+  
+instance (Eq a, Eq b) => Eq (a :+: b) where
+  eq' (L x) (L x') = eq' x x'
+  eq' (R x) (R x') = eq' x x'
+  eq' _      _     = False
+  
+instance (Eq a, Eq b) => Eq (a :*: b) where
+  eq' (a :*: b) (a' :*: b') = eq' a a' && eq' b b'
+  
+instance (Eq a) => Eq (C c a) where
+  eq' (C a) (C a') = eq' a a'
+
+instance Eq a => Eq (Var a) where
+  eq' (Var x) (Var x') = eq' x x'
+
+instance (Eq a) => Eq (Rec a) where
+  eq' (Rec x) (Rec x') = eq' x x'
+
+-- Dispatcher
+eq :: (Representable a, Eq (Rep a)) => a -> a -> Bool
+eq x y = eq' (from x) (from y)
+
+
+-- Adhoc instances
+instance Eq Int      where eq' = (==)
+instance Eq Integer  where eq' = (==)
+instance Eq Float    where eq' = (==)
+instance Eq Double   where eq' = (==)
+instance Eq Char     where eq' = (==)
+instance Eq Bool     where eq' = (==)
+
+-- Generic instances
+instance (Eq a) => Eq (Maybe a)    where eq' = eq
+instance (Eq a) => Eq [a]          where eq' = eq
+instance (Eq a, Eq b) => Eq (a, b) where eq' = eq
diff --git a/Generics/Instant/Functions/Show.hs b/Generics/Instant/Functions/Show.hs
new file mode 100644
--- /dev/null
+++ b/Generics/Instant/Functions/Show.hs
@@ -0,0 +1,89 @@
+{-# LANGUAGE TypeOperators            #-}
+{-# LANGUAGE FlexibleInstances        #-}
+{-# LANGUAGE FlexibleContexts         #-}
+{-# LANGUAGE OverlappingInstances     #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Instant.Functions.Show
+-- Copyright   :  (c) 2010, Universiteit Utrecht
+-- License     :  BSD3
+--
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Simplified generic show function.
+--
+-----------------------------------------------------------------------------
+
+module Generics.Instant.Functions.Show (Show(..), show) where
+
+import Generics.Instant.Base
+import Generics.Instant.Instances ()
+
+import Prelude hiding (Show, show)
+import qualified Prelude as P (Show, show)
+import Data.List (intersperse)
+
+-- Generic show on Representable (worker)
+class Show a where
+  show' :: a -> String
+
+instance Show U where
+  show' U = ""
+  
+instance (Show a, Show b) => Show (a :+: b) where
+  show' (L x) = show' x
+  show' (R x) = show' x
+  
+instance (Show a, Show b) => Show (a :*: b) where
+  show' (a :*: b) = show' a `space` show' b
+  
+instance (Show a, Constructor c) => Show (C c a) where
+  show' c@(C a) | show' a == "" = paren $ conName c
+                | otherwise     = paren $ (conName c) `space` show' a
+
+instance Show a => Show (Var a) where
+  show' (Var x) = show' x
+
+instance Show a => Show (Rec a) where
+  show' (Rec x) = show' x
+
+
+-- Dispatcher
+show :: (Representable a, Show (Rep a)) => a -> String
+show = show' . from
+
+
+-- Adhoc instances
+instance Show Int      where show' = P.show
+instance Show Integer  where show' = P.show
+instance Show Float    where show' = P.show
+instance Show Double   where show' = P.show
+instance Show Char     where show' = P.show
+instance Show Bool     where show' = P.show
+
+instance Show a => Show [a] where
+  show' = concat . wrap "[" "]" . intersperse "," . map show'
+
+instance Show [Char] where
+  show' = P.show
+
+instance (Show a, Show b) => Show (a, b) where
+  show' (a,b) = "(" ++ show' a ++ "," ++ show' b ++ ")"
+
+
+-- Generic instances
+instance (Show a) => Show (Maybe a) where show' = show
+
+
+-- Utilities
+space :: String -> String -> String
+space a b = a ++ " " ++ b
+
+paren :: String -> String
+paren x = "(" ++ x ++ ")"
+
+wrap :: a -> a -> [a] -> [a]
+wrap h t l = h:l++[t]
diff --git a/Generics/Instant/Functions/Update.hs b/Generics/Instant/Functions/Update.hs
new file mode 100644
--- /dev/null
+++ b/Generics/Instant/Functions/Update.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE OverlappingInstances     #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Instant.Functions.Update
+-- Copyright   :  (c) 2010, Universiteit Utrecht
+-- License     :  BSD3
+--
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Generic update function.
+--
+-----------------------------------------------------------------------------
+
+module Generics.Instant.Functions.Update (Update(..), update, MapOn(..)) where
+
+import Generics.Instant.Base
+import Generics.Instant.Instances ()
+
+
+-- Generic update on Representable (worker)
+class Update a where
+  update' :: a -> a
+
+instance Update U where
+  update' U = U
+  
+instance (Update a, Update b) => Update (a :+: b) where
+  update' (L x) = L (update' x)
+  update' (R x) = R (update' x)
+  
+instance (Update a, Update b) => Update (a :*: b) where
+  update' (a :*: b) = update' a :*: update' b
+  
+instance (Update a, Constructor c) => Update (C c a) where
+  update' (C a) = C (update' a)
+
+instance Update a => Update (Rec a) where
+  update' (Rec x) = Rec (update' x)
+
+instance (MapOn a) => Update (Var a) where
+  update' (Var x) = Var (mapOn x)
+
+-- | This is the function that is applied by 'update' at 'Var' positions.
+class MapOn a where
+  mapOn :: a -> a
+  mapOn = id
+
+
+-- Dispatcher
+update :: (Representable a, Update (Rep a)) => a -> a
+update = to . update' . from
+
+
+-- Adhoc instances
+
+
+-- Generic instances
+instance (MapOn a)          => Update (Maybe a) where update' = update
+instance (MapOn a)          => Update [a]       where update' = update
+instance (MapOn a, MapOn b) => Update (a,b)     where update' = update
diff --git a/Generics/Instant/GDiff.hs b/Generics/Instant/GDiff.hs
new file mode 100644
--- /dev/null
+++ b/Generics/Instant/GDiff.hs
@@ -0,0 +1,257 @@
+{-# LANGUAGE GADTs                #-}
+{-# LANGUAGE TypeOperators        #-}
+{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE MagicHash            #-}
+
+module Generics.Instant.GDiff 
+  ( diff, patch, diffLen, GDiff
+  , SEq(..), shallowEqDef
+  , Build(..), buildDef
+  , Children(..), childrenDef
+  , Ex(..)
+  ) where
+
+import Control.Arrow
+import Data.Array
+
+import Data.Typeable
+import GHC.Prim
+
+
+-- GP lib
+import Generics.Instant
+
+--------------------------------------------------------------------------------
+
+ucast :: a -> b
+ucast = unsafeCoerce#
+
+--------------------------------------------------------------------------------
+
+class Children' a where
+  children' :: a -> [Ex]
+  children' _ = []
+
+instance Children' U
+
+instance (Children' a, Children' b) => Children' (a :+: b) where
+  children' (L a) = children' a
+  children' (R a) = children' a
+
+instance (Children' a, Children' b) => Children' (a :*: b) where
+  children' (a :*: b) = children' a ++ children' b 
+
+instance (Children' a) => Children' (C c a) where
+  children' (C a) = children' a
+
+instance (GDiff a) => Children' (Var a) where
+  children' (Var a) = [Ex a]
+
+instance (GDiff a) => Children' (Rec a) where
+  children' (Rec a) = [Ex a]
+
+-- | Gets all the immediate children of a term
+class Children a where
+  children :: a -> [Ex]
+  children _ = []
+
+instance Children Char
+instance Children Int
+
+instance (GDiff a) => Children [a] where
+  children []    = []
+  children (h:t) = [Ex h, Ex t]
+
+childrenDef :: (Representable a, Children' (Rep a)) => a -> [Ex]
+childrenDef x = children' (from x)
+
+--------------------------------------------------------------------------------
+
+class Build' a where
+  build' :: a -> [Ex] -> Maybe (a, [Ex])
+  build' c l = Just (c,l)
+
+instance Build' U
+
+instance (Build' a, Build' b) => Build' (a :+: b) where
+  build' (L a) l = fmap (first L) (build' a l)
+  build' (R a) l = fmap (first R) (build' a l)
+
+instance (Build' a, Build' b) => Build' (a :*: b) where
+  build' (a :*: b) l = do (r,l') <- build' a l
+                          fmap (first (r :*:)) (build' b l')
+
+instance (Build' a) => Build' (C c a) where
+  build' (C a) l = fmap (first C) (build' a l)
+
+instance (GDiff a) => Build' (Var a) where
+  build' (Var _) []         = Nothing
+  build' (Var _) ((Ex h):t) = cast h >>= return . flip (,) t . Var
+
+instance (GDiff a) => Build' (Rec a) where
+  build' (Rec _) []         = Nothing
+  build' (Rec _) ((Ex h):t) = cast h >>= return . flip (,) t . Rec
+
+
+-- | Rebuilds a term, replacing the children with elements from the list
+class Build a where
+  build :: a -> [Ex] -> Maybe (a, [Ex])
+  build c l = Just (c,l)
+
+instance Build Char
+instance Build Int
+
+instance (Typeable a) => Build [a]  where
+  build [] l = Just ([],l)
+  build _ ((Ex h'):(Ex t'):r) = do h <- cast h'
+                                   t <- cast t'
+                                   Just (h:t,r)
+  build _ _ = Nothing
+
+buildDef :: (Representable a, Build' (Rep a)) => a -> [Ex] -> Maybe (a, [Ex])
+buildDef x = fmap (first to) . build' (from x)
+
+--------------------------------------------------------------------------------
+
+-- Shallow equality
+class SEq' a where
+  shallowEq' :: a -> a -> Bool
+
+instance (SEq' a, SEq' b) => SEq' (a :+: b) where
+  shallowEq' (L x) (L x') = shallowEq' x x'
+  shallowEq' (R x) (R x') = shallowEq' x x'
+  shallowEq' _      _     = False
+  
+instance SEq' (C c a) where
+  shallowEq' _ _ = True
+
+
+-- | Shallow equality: compare the constructor name only
+class SEq a where
+  shallowEq :: a -> a -> Bool
+
+instance SEq Char where
+  shallowEq = (==)
+instance SEq Int  where 
+  shallowEq = (==)
+instance SEq [a]  where
+  shallowEq [] [] = True
+  shallowEq (_:_) (_:_) = True
+  shallowEq _ _ = False
+
+shallowEqDef :: (Representable a, SEq' (Rep a)) => a -> a -> Bool
+shallowEqDef x y = shallowEq' (from x) (from y)
+
+--------------------------------------------------------------------------------
+
+-- | Tying the recursive knot
+class (Typeable a, SEq a, Children a, Build a) => GDiff a
+
+instance GDiff Char
+instance GDiff Int
+instance (GDiff a) => GDiff [a]
+
+-- | Existentials
+data Ex where Ex :: (GDiff a) => !a -> Ex
+
+instance Show Ex where
+  -- should improve this
+  show (Ex a) = show (typeOf a)
+
+--------------------------------------------------------------------------------
+
+-- | Edit actions
+data Edit = Cpy !Ex | Del !Ex | Ins !Ex deriving Show
+
+-- | Editscript
+data EditScript = ES !Int# [Edit] deriving Show
+
+editScriptLen :: EditScript -> Int
+editScriptLen (ES _ l) = editScriptLen' l where
+  editScriptLen' []          = 0
+  editScriptLen' ((Cpy _):t) = editScriptLen' t
+  editScriptLen' (_      :t) = 1 + editScriptLen' t
+
+infixr 4 &
+(&) :: EditScript -> EditScript -> EditScript
+l@(ES m _) & r@(ES n _) = if m <=# n then l else r
+
+
+-- | Generic patch
+gpatch :: EditScript -> [Ex] -> Maybe [Ex]
+gpatch (ES 0# [])        [] = Just []
+gpatch (ES 0# [])        _  = Nothing
+gpatch (ES n  (Ins x:t)) ys =                 gpatch (ES (n -# 1#) t) ys >>= insert x
+gpatch (ES n  (Del x:t)) ys = delete x ys >>= gpatch (ES (n -# 1#) t)
+gpatch (ES n  (Cpy x:t)) ys = delete x ys >>= gpatch (ES (n -# 1#) t)    >>= insert x
+gpatch _ _ = error "impossible"
+
+insert :: Ex -> [Ex] -> Maybe [Ex]
+insert (Ex x) l = case splitAt (length (children x)) l of
+                    (xs, r) -> build x xs >>= Just . (:r) . Ex . fst
+
+delete :: Ex -> [Ex] -> Maybe [Ex]
+delete _ [] = Nothing
+delete (Ex x) ((Ex h):t)
+  | typeOf x == typeOf h && length (children x) == length (children h)
+  = Just (children h ++ t)
+  | otherwise = Nothing
+
+--------------------------------------------------------------------------------
+-- Memoization
+type Table = Array (Int,Int) EditScript
+
+gdiffm :: [Ex] -> [Ex] -> EditScript
+gdiffm x y = table ! (length x, length y) where
+  table :: Table
+  table = 
+    array ((0,0),(length x,length y))
+      [ ((m,n),ES 0# []) | m <- [0..length x], n <- [0..length y]] //
+
+    [ ((0,n), add (Ins (y !! (n-1))) (0,n-1))
+    | n <- [1..length y] ] //
+
+    [ ((n,0), add (Del (x !! (n-1))) (n-1,0))
+    | n <- [1..length x] ] //
+
+    [ ((m,n), gen m n) | m <- [1..length x], n <- [1.. length y] ]
+
+  gen m n = case (x !! (m-1), y !! (n-1)) of
+    (Ex x', Ex y') -> (if typeOf x' == typeOf y' && x' `shallowEq` (ucast y')
+                        -- && length xs == length ys -- do we need this?
+                       then (add (Cpy (Ex x')) (m-1,n-1)) & alt
+                       else alt) where
+      alt = add (Del (x !! (m-1))) (m-1,n) &
+            add (Ins (y !! (n-1))) (m,n-1)
+
+  add :: Edit -> (Int,Int) -> EditScript
+  add e (a,b) = case table ! (a,b) of ES n l -> ES (n +# 1#) (e:l)
+
+allChildren :: Ex -> [Ex]
+allChildren (Ex a) = Ex a : concatMap allChildren (children a)
+{-
+-- I thought this would use less memory, but apparently it doesn't
+allChildren (Ex x) = ux : concatMap allChildren xs
+  where xs  = children x
+        uxs = map (\(Ex y) -> Ex (undefined `asTypeOf` y)) xs
+        ux  = Ex . fst . fromJust $ build x uxs
+-}
+
+--------------------------------------------------------------------------------
+
+-- Top level functions
+-- | Generic diff
+diff :: (GDiff a) => a -> a -> EditScript
+diff x y = gdiffm (reverse (allChildren (Ex x))) (reverse (allChildren (Ex y)))
+
+-- | Generic diff
+patch :: (GDiff a) => EditScript -> a -> Maybe a
+patch es x = case gpatch es [Ex x] of
+               Just [Ex h] -> cast h
+               _           -> Nothing
+
+-- | Edit distance
+diffLen :: (GDiff a) => a -> a -> Float
+diffLen x y = fromIntegral (editScriptLen (diff x y)) / 
+                fromIntegral (length (allChildren (Ex x)))
diff --git a/Generics/Instant/Instances.hs b/Generics/Instant/Instances.hs
new file mode 100644
--- /dev/null
+++ b/Generics/Instant/Instances.hs
@@ -0,0 +1,111 @@
+{-# LANGUAGE EmptyDataDecls           #-}
+{-# LANGUAGE TypeOperators            #-}
+{-# LANGUAGE TypeFamilies             #-}
+{-# OPTIONS -fno-warn-orphans         #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Instant.Instances
+-- Copyright   :  (c) 2010, Universiteit Utrecht
+-- License     :  BSD3
+--
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- This module defines instances of the 'Representable' class for a number of
+-- basic Prelude types.
+--
+-----------------------------------------------------------------------------
+
+module Generics.Instant.Instances () where
+
+import Generics.Instant.Base
+  
+instance Representable Int where 
+  type Rep Int = Int
+  to = id
+  from = id
+  
+instance Representable Char where 
+  type Rep Char = Char
+  to = id
+  from = id
+  
+instance Representable Bool where 
+  type Rep Bool = Bool
+  to = id
+  from = id
+
+instance Representable Float where 
+  type Rep Float = Float
+  to = id
+  from = id
+  
+instance Representable U where 
+  type Rep U = U
+  to = id
+  from = id
+
+instance (Representable a, Representable b) => Representable (a :*: b) where 
+  type Rep (a :*: b) = a :*: b
+  to = id
+  from = id
+
+instance (Representable a, Representable b) => Representable (a :+: b) where 
+  type Rep (a :+: b) = a :+: b
+  to = id
+  from = id
+  
+instance Representable a => Representable (C c a) where 
+  type Rep (C c a) = C c a
+  to = id
+  from = id
+  
+instance Representable a => Representable (Var a) where 
+  type Rep (Var a) = Var a
+  to = id
+  from = id
+
+instance Representable a => Representable (Rec a) where 
+  type Rep (Rec a) = Rec a
+  to = id
+  from = id
+
+-- Lists
+instance Representable [a] where
+  type Rep [a] = C List_Nil_ U :+: C List_Cons_ (Var a :*: Rec [a])
+  from []                           = L (C U)
+  from (a:as)                       = R (C (Var a :*: Rec as))
+  to (L (C U))                  = []
+  to (R (C (Var a :*: Rec as))) = (a:as)
+
+data List_Nil_
+instance Constructor List_Nil_  where conName _ = "[]"
+data List_Cons_
+instance Constructor List_Cons_  where
+  conName _   = ":"
+  conFixity _ = Infix RightAssociative 5
+
+-- Maybe
+instance Representable (Maybe a) where
+  type Rep (Maybe a) = C Maybe_Nothing_ U :+: C Maybe_Just_ (Var a)
+  from Nothing           = L (C U)
+  from (Just x)          = R (C (Var x))
+  to (L (C U))       = Nothing
+  to (R (C (Var x))) = Just x
+  
+data Maybe_Nothing_
+instance Constructor Maybe_Nothing_  where conName _ = "Nothing"
+data Maybe_Just_
+instance Constructor Maybe_Just_  where conName _ = "Just"
+
+-- Pairs
+instance Representable (a,b) where
+  type Rep (a,b) = C Tuple_Pair_ (Var a :*: Var b)
+  from (a,b)                   = C (Var a :*: Var b)
+  to (C (Var a :*: Var b)) = (a,b)
+
+
+data Tuple_Pair_
+instance Constructor Tuple_Pair_ where conName _ = "," -- Prefix?
diff --git a/Generics/Instant/TH.hs b/Generics/Instant/TH.hs
new file mode 100644
--- /dev/null
+++ b/Generics/Instant/TH.hs
@@ -0,0 +1,332 @@
+{-# LANGUAGE TemplateHaskell, CPP #-}
+{-# OPTIONS_GHC -w           #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Instant.TH
+-- Copyright   :  (c) 2010 Universiteit Utrecht
+-- License     :  BSD3
+--
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- This module contains Template Haskell code that can be used to
+-- automatically generate the boilerplate code for the generic deriving
+-- library.
+-----------------------------------------------------------------------------
+
+-- Adapted from Generics.Deriving.TH
+module Generics.Instant.TH (
+      deriveAll
+    , deriveConstructors
+    , deriveRepresentable
+    , deriveRep
+    , simplInstance
+  ) where
+
+import Generics.Instant.Base
+
+import Language.Haskell.TH hiding (Fixity())
+import Language.Haskell.TH.Syntax (Lift(..))
+
+import Data.List (intercalate)
+import Control.Monad
+
+
+-- | Given the names of a generic class, a type to instantiate, a function in
+-- the class and the default implementation, generates the code for a basic
+-- generic instance.
+simplInstance :: Name -> Name -> Name -> Name -> Q [Dec]
+simplInstance cl ty fn df = do
+  i <- reify (genRepName ty)
+  (ClassOpI _ t _ _) <- reify fn
+  let -- Only works for types with a single parameter
+      subst (ForallT lvs cxt ty) x = subst ty x
+      subst (VarT _) x             = ConT x
+      subst (AppT t1 t2) x         = AppT (subst t1 x) (subst t2 x)
+      subst (SigT ty k) x          = SigT (subst ty x) k
+      subst y _                    = y
+  prg <- pragSpecD df (return (subst t ty))
+  fmap (: [{-prg-}]) $ instanceD (cxt []) (conT cl `appT` conT ty)
+    [funD fn [clause [] (normalB (varE df)) []]]
+
+-- | Given the type and the name (as string) for the type to derive,
+-- generate the 'Constructor' instances and the 'Representable' instance.
+deriveAll :: Name -> Q [Dec]
+deriveAll n =
+  do a <- deriveConstructors n
+     b <- deriveRepresentable n
+     return (a ++ b)
+
+-- | Given a datatype name, derive datatypes and 
+-- instances of class 'Constructor'.
+deriveConstructors :: Name -> Q [Dec]
+deriveConstructors = constrInstance
+
+-- | Given the type and the name (as string) for the Representable type
+-- synonym to derive, generate the 'Representable' instance.
+deriveRepresentable :: Name -> Q [Dec]
+deriveRepresentable n = do
+    rep <- deriveRep n
+    inst <- deriveInst n
+    return $ rep ++ inst
+
+-- | Derive only the 'Rep' type synonym. Not needed if 'deriveRepresentable'
+-- is used.
+deriveRep :: Name -> Q [Dec]
+deriveRep n = do
+  i <- reify n
+  fmap (:[]) $ tySynD (genRepName n) (typeVariables i) (repType n)
+
+deriveInst :: Name -> Q [Dec]
+deriveInst t = do
+  i <- reify t
+  let typ q = return $ foldl (\a -> AppT a . VarT . tyVarBndrToName) (ConT q) 
+                (typeVariables i)
+      prg1 = pragInlD (mkName "from") (inlineSpecPhase True False True 1)
+      prg2 = pragInlD (mkName "to")   (inlineSpecPhase True False True 1)
+  fcs <- mkFrom t 1 0 t
+  tcs <- mkTo   t 1 0 t
+  liftM (:[]) $
+    instanceD (cxt [])
+      (conT ''Representable `appT` typ t)
+        [ tySynInstD ''Rep [typ t] (typ (genRepName t))
+        , {-prg1, prg2,-} funD 'from fcs, funD 'to tcs]
+
+constrInstance :: Name -> Q [Dec]
+constrInstance n = do
+  i <- reify n
+  case i of
+    TyConI (DataD    _ n _ cs _) -> mkInstance n cs
+    TyConI (NewtypeD _ n _ c  _) -> mkInstance n [c]
+    _ -> return []
+  where
+    mkInstance n cs = do
+      ds <- mapM (mkConstrData n) cs
+      is <- mapM (mkConstrInstance n) cs
+      return $ ds ++ is
+
+typeVariables :: Info -> [TyVarBndr]
+typeVariables (TyConI (DataD    _ _ tv _ _)) = tv
+typeVariables (TyConI (NewtypeD _ _ tv _ _)) = tv
+typeVariables _                           = []
+
+tyVarBndrToName :: TyVarBndr -> Name
+tyVarBndrToName (PlainTV  name)   = name
+tyVarBndrToName (KindedTV name _) = name
+
+stripRecordNames :: Con -> Con
+stripRecordNames (RecC n f) =
+  NormalC n (map (\(_, s, t) -> (s, t)) f)
+stripRecordNames c = c
+
+genName :: [Name] -> Name
+genName = mkName . (++"_") . intercalate "_" . map nameBase
+
+genRepName :: Name -> Name
+genRepName = mkName . (++"_") . ("Rep"  ++) . nameBase
+
+mkConstrData :: Name -> Con -> Q Dec
+mkConstrData dt (NormalC n _) =
+  dataD (cxt []) (genName [dt, n]) [] [] [] 
+mkConstrData dt r@(RecC _ _) =
+  mkConstrData dt (stripRecordNames r)
+mkConstrData dt (InfixC t1 n t2) =
+  mkConstrData dt (NormalC n [t1,t2])
+
+instance Lift Fixity where
+  lift Prefix      = conE 'Prefix
+  lift (Infix a n) = conE 'Infix `appE` [| a |] `appE` [| n |]
+
+instance Lift Associativity where
+  lift LeftAssociative  = conE 'LeftAssociative
+  lift RightAssociative = conE 'RightAssociative
+  lift NotAssociative   = conE 'NotAssociative
+
+mkConstrInstance :: Name -> Con -> Q Dec
+mkConstrInstance dt (NormalC n _) = mkConstrInstanceWith dt n []
+mkConstrInstance dt (RecC    n _) = mkConstrInstanceWith dt n
+      [ funD 'conIsRecord [clause [wildP] (normalB (conE 'True)) []]]
+mkConstrInstance dt (InfixC t1 n t2) =
+    do
+      i <- reify n
+      let fi = case i of
+                 DataConI _ _ _ f -> convertFixity f
+                 _ -> Prefix
+      instanceD (cxt []) (appT (conT ''Constructor) (conT $ genName [dt, n]))
+        [funD 'conName   [clause [wildP] (normalB (stringE (nameBase n))) []],
+         funD 'conFixity [clause [wildP] (normalB [| fi |]) []]]
+  where
+    convertFixity (Fixity n d) = Infix (convertDirection d) n
+    convertDirection InfixL = LeftAssociative
+    convertDirection InfixR = RightAssociative
+    convertDirection InfixN = NotAssociative
+
+mkConstrInstanceWith :: Name -> Name -> [Q Dec] -> Q Dec
+mkConstrInstanceWith dt n extra = 
+  instanceD (cxt []) (appT (conT ''Constructor) (conT $ genName [dt, n]))
+    (funD 'conName [clause [wildP] (normalB (stringE (nameBase n))) []] : extra)
+
+repType :: Name -> Q Type
+repType n =
+    do
+      -- runIO $ putStrLn $ "processing " ++ show n
+      i <- reify n
+      let b = case i of
+                TyConI (DataD _ dt vs cs _) ->
+                  (foldr1' sum (error "Empty datatypes are not supported.")
+                    (map (repCon (dt, map tyVarBndrToName vs)) cs))
+                TyConI (NewtypeD _ dt vs c _) ->
+                  repCon (dt, map tyVarBndrToName vs) c
+                TyConI (TySynD t _ _) -> error "type synonym?" 
+                _ -> error "unknown construct" 
+      --appT b (conT $ mkName (nameBase n))
+      b where
+    sum :: Q Type -> Q Type -> Q Type
+    sum a b = conT ''(:+:) `appT` a `appT` b
+
+
+repCon :: (Name, [Name]) -> Con -> Q Type
+repCon (dt, vs) (NormalC n []) =
+    conT ''C `appT` (conT $ genName [dt, n]) `appT` conT ''U
+repCon (dt, vs) (NormalC n fs) =
+    conT ''C `appT` (conT $ genName [dt, n]) `appT` 
+     (foldr1 prod (map (repField (dt, vs) . snd) fs)) where
+    prod :: Q Type -> Q Type -> Q Type
+    prod a b = conT ''(:*:) `appT` a `appT` b
+repCon (dt, vs) r@(RecC n []) =
+    conT ''C `appT` (conT $ genName [dt, n]) `appT` conT ''U
+repCon (dt, vs) r@(RecC n fs) =
+    conT ''C `appT` (conT $ genName [dt, n]) `appT` 
+      (foldr1 prod (map (repField' (dt, vs) n) fs)) where
+    prod :: Q Type -> Q Type -> Q Type
+    prod a b = conT ''(:*:) `appT` a `appT` b
+
+repCon d (InfixC t1 n t2) = repCon d (NormalC n [t1,t2])
+
+--dataDeclToType :: (Name, [Name]) -> Type
+--dataDeclToType (dt, vs) = foldl (\a b -> AppT a (VarT b)) (ConT dt) vs
+
+repField :: (Name, [Name]) -> Type -> Q Type
+--repField d t | t == dataDeclToType d = conT ''I
+repField d t = conT ''Rec `appT` return t
+
+repField' :: (Name, [Name]) -> Name -> (Name, Strict, Type) -> Q Type
+--repField' d ns (_, _, t) | t == dataDeclToType d = conT ''I
+repField' (dt, vs) ns (f, _, t) = conT ''Rec `appT` return t
+-- Note: we should generate Var too, at some point
+
+
+mkFrom :: Name -> Int -> Int -> Name -> Q [Q Clause]
+mkFrom ns m i n =
+    do
+      -- runIO $ putStrLn $ "processing " ++ show n
+      let wrapE e = lrE m i e
+      i <- reify n
+      let b = case i of
+                TyConI (DataD _ dt vs cs _) ->
+                  zipWith (fromCon wrapE ns (dt, map tyVarBndrToName vs)
+                    (length cs)) [0..] cs
+                TyConI (NewtypeD _ dt vs c _) ->
+                  [fromCon wrapE ns (dt, map tyVarBndrToName vs) 1 0 c]
+                TyConI (TySynD t _ _) -> error "type synonym?" 
+                  -- [clause [varP (field 0)] (normalB (wrapE $ conE 'K1 `appE` varE (field 0))) []]
+                _ -> error "unknown construct"
+      return b
+
+mkTo :: Name -> Int -> Int -> Name -> Q [Q Clause]
+mkTo ns m i n =
+    do
+      -- runIO $ putStrLn $ "processing " ++ show n
+      let wrapP p = lrP m i p
+      i <- reify n
+      let b = case i of
+                TyConI (DataD _ dt vs cs _) ->
+                  zipWith (toCon wrapP ns (dt, map tyVarBndrToName vs)
+                    (length cs)) [0..] cs
+                TyConI (NewtypeD _ dt vs c _) ->
+                  [toCon wrapP ns (dt, map tyVarBndrToName vs) 1 0 c]
+                TyConI (TySynD t _ _) -> error "type synonym?" 
+                  -- [clause [wrapP $ conP 'K1 [varP (field 0)]] (normalB $ varE (field 0)) []]
+                _ -> error "unknown construct" 
+      return b
+
+fromCon :: (Q Exp -> Q Exp) -> Name -> (Name, [Name]) -> Int -> Int -> Con -> Q Clause
+fromCon wrap ns (dt, vs) m i (NormalC cn []) =
+  clause
+    [conP cn []]
+    (normalB $ wrap $ lrE m i $ appE (conE 'C) $ conE 'U) []
+fromCon wrap ns (dt, vs) m i (NormalC cn fs) =
+  -- runIO (putStrLn ("constructor " ++ show ix)) >>
+  clause
+    [conP cn (map (varP . field) [0..length fs - 1])]
+    (normalB $ wrap $ lrE m i $ conE 'C `appE` 
+      foldr1 prod (zipWith (fromField (dt, vs)) [0..] (map snd fs))) []
+  where prod x y = conE '(:*:) `appE` x `appE` y
+fromCon wrap ns (dt, vs) m i r@(RecC cn []) =
+  clause
+    [conP cn []]
+    (normalB $ wrap $ lrE m i $ conE 'C `appE` (conE 'U)) []
+fromCon wrap ns (dt, vs) m i r@(RecC cn fs) =
+  clause
+    [conP cn (map (varP . field) [0..length fs - 1])]
+    (normalB $ wrap $ lrE m i $ conE 'C `appE` 
+      foldr1 prod (zipWith (fromField (dt, vs)) [0..] (map trd fs))) []
+  where prod x y = conE '(:*:) `appE` x `appE` y
+fromCon wrap ns (dt, vs) m i (InfixC t1 cn t2) =
+  fromCon wrap ns (dt, vs) m i (NormalC cn [t1,t2])
+
+fromField :: (Name, [Name]) -> Int -> Type -> Q Exp
+--fromField (dt, vs) nr t | t == dataDeclToType (dt, vs) = conE 'I `appE` varE (field nr)
+fromField (dt, vs) nr t = conE 'Rec `appE` varE (field nr)
+
+toCon :: (Q Pat -> Q Pat) -> Name -> (Name, [Name]) -> Int -> Int -> Con -> Q Clause
+toCon wrap ns (dt, vs) m i (NormalC cn []) =
+    clause
+      [wrap $ lrP m i $ conP 'C [conP 'U []]]
+      (normalB $ conE cn) []
+toCon wrap ns (dt, vs) m i (NormalC cn fs) =
+    -- runIO (putStrLn ("constructor " ++ show ix)) >>
+    clause
+      [wrap $ lrP m i $ conP 'C
+        [foldr1 prod (zipWith (toField (dt, vs)) [0..] (map snd fs))]]
+      (normalB $ foldl appE (conE cn) (map (varE . field) [0..length fs - 1])) []
+  where prod x y = conP '(:*:) [x,y]
+toCon wrap ns (dt, vs) m i r@(RecC cn []) =
+    clause
+      [wrap $ lrP m i $ conP 'U []]
+      (normalB $ conE cn) []
+toCon wrap ns (dt, vs) m i r@(RecC cn fs) =
+    clause
+      [wrap $ lrP m i $ conP 'C
+        [foldr1 prod (zipWith (toField (dt, vs)) [0..] (map trd fs))]]
+      (normalB $ foldl appE (conE cn) (map (varE . field) [0..length fs - 1])) []
+  where prod x y = conP '(:*:) [x,y]
+toCon wrap ns (dt, vs) m i (InfixC t1 cn t2) =
+  toCon wrap ns (dt, vs) m i (NormalC cn [t1,t2])
+
+toField :: (Name, [Name]) -> Int -> Type -> Q Pat
+--toField (dt, vs) nr t | t == dataDeclToType (dt, vs) = conP 'I [varP (field nr)]
+toField (dt, vs) nr t = conP 'Rec [varP (field nr)]
+
+
+field :: Int -> Name
+field n = mkName $ "f" ++ show n
+
+lrP :: Int -> Int -> (Q Pat -> Q Pat)
+lrP 1 0 p = p
+lrP m 0 p = conP 'L [p]
+lrP m i p = conP 'R [lrP (m-1) (i-1) p]
+
+lrE :: Int -> Int -> (Q Exp -> Q Exp)
+lrE 1 0 e = e
+lrE m 0 e = conE 'L `appE` e
+lrE m i e = conE 'R `appE` lrE (m-1) (i-1) e
+
+trd (_,_,c) = c
+
+-- | Variant of foldr1 which returns a special element for empty lists
+foldr1' f x [] = x
+foldr1' _ _ [x] = x
+foldr1' f x (h:t) = f h (foldr1' f x t)
diff --git a/HarmTrace.cabal b/HarmTrace.cabal
--- a/HarmTrace.cabal
+++ b/HarmTrace.cabal
@@ -1,5 +1,5 @@
 name:                   HarmTrace
-version:                0.3
+version:                0.4
 synopsis:               HarmTrace: Harmony Analysis and Retrieval of Music
 description:            HarmTrace: Harmony Analysis and Retrieval of Music 
                         with Type-level Representations of Abstract
@@ -28,7 +28,53 @@
 
 executable harmtrace
   hs-source-dirs:       .
+  other-modules:        Generics.Instant
+                        Generics.Instant.Base
+                        Generics.Instant.Functions
+                        Generics.Instant.GDiff
+                        Generics.Instant.Instances
+                        Generics.Instant.TH
+                        Generics.Instant.Functions.Empty
+                        Generics.Instant.Functions.Eq
+                        Generics.Instant.Functions.Show
+                        Generics.Instant.Functions.Update
+
+                        Text.ParserCombinators.UU
+                        Text.ParserCombinators.UU.BasicInstances
+                        Text.ParserCombinators.UU.Core
+                        Text.ParserCombinators.UU.Derived
+                        Text.ParserCombinators.UU.Parsing
+                        Text.ParserCombinators.UU.BasicInstances.List
+                        Text.ParserCombinators.UU.BasicInstances.String
+
+                        MIR.Instances
+                        MIR.Run
+                        MIR.GeneratedInstances.GeneratedInstances
+                        MIR.GeneratedInstances.GeneratedInstance0
+                        MIR.GeneratedInstances.GeneratedInstance1
+                        MIR.GeneratedInstances.GeneratedInstance2
+                        MIR.GeneratedInstances.GeneratedInstance3
+                        MIR.GeneratedInstances.GeneratedInstance4
+                        MIR.GeneratedInstances.GeneratedInstance5
+                        MIR.GeneratedInstances.GeneratedInstance6
+                        MIR.GeneratedInstances.GeneratedInstance7
+                        MIR.GeneratedInstances.GeneratedInstance8
+                        MIR.GeneratedInstances.GeneratedInstance9
+                        MIR.GeneratedInstances.GeneratedInstance10
+                        MIR.GeneratedInstances.GeneratedInstance11
+                        MIR.GeneratedInstances.GeneratedInstance12
+                        MIR.GeneratedInstances.GeneratedInstance13
+                        MIR.GeneratedInstances.GeneratedInstance14
+                        MIR.HarmGram.MIR
+                        MIR.HarmGram.ParserChord
+                        MIR.HarmGram.ShowChord
+                        MIR.HarmGram.Tokenizer
+                        MIR.HarmGram.TypeLevel
+                        MIR.Matching.GDiff
+                        MIR.Matching.Standard
+
   main-is:              Main.hs
+
   build-depends:        base >= 4.2 && < 4.4, template-haskell >=2.4 && <2.6,
                         mtl, directory, filepath, array, parallel >= 3,
                         Diff == 0.1.*, parseargs >= 0.1.3.2, 
diff --git a/MIR/GeneratedInstances/GeneratedInstance0.hs b/MIR/GeneratedInstances/GeneratedInstance0.hs
new file mode 100644
--- /dev/null
+++ b/MIR/GeneratedInstances/GeneratedInstance0.hs
@@ -0,0 +1,24 @@
+{-# OPTIONS_GHC -fno-warn-orphans   #-}
+{-# LANGUAGE TemplateHaskell        #-}
+{-# LANGUAGE EmptyDataDecls         #-}
+{-# LANGUAGE TypeFamilies           #-}
+
+module MIR.GeneratedInstances.GeneratedInstance0 where
+
+-- Generics stuff
+import Generics.Instant.TH
+
+-- Music stuff
+import MIR.HarmGram.ParserChord
+import MIR.HarmGram.ShowChord
+import MIR.Matching.GDiff
+import MIR.HarmGram.MIR
+import MIR.GeneratedInstances.GeneratedInstance1()
+
+$(deriveAll ''Piece)
+$(simplInstance ''ParseG ''Piece 'parseG 'parseGdefault)
+$(simplInstance ''ShowChord ''Piece 'showChord 'showChordDefault)
+$(simplInstance ''Children ''Piece 'children 'childrenDef)
+$(simplInstance ''Build ''Piece 'build 'buildDef)
+$(simplInstance ''SEq ''Piece 'shallowEq 'shallowEqDef)
+instance GDiff Piece
diff --git a/MIR/GeneratedInstances/GeneratedInstance1.hs b/MIR/GeneratedInstances/GeneratedInstance1.hs
new file mode 100644
--- /dev/null
+++ b/MIR/GeneratedInstances/GeneratedInstance1.hs
@@ -0,0 +1,24 @@
+{-# OPTIONS_GHC -fno-warn-orphans   #-}
+{-# LANGUAGE TemplateHaskell        #-}
+{-# LANGUAGE EmptyDataDecls         #-}
+{-# LANGUAGE TypeFamilies           #-}
+
+module MIR.GeneratedInstances.GeneratedInstance1 where
+
+-- Generics stuff
+import Generics.Instant.TH
+
+-- Music stuff
+import MIR.HarmGram.ParserChord
+import MIR.HarmGram.ShowChord
+import MIR.Matching.GDiff
+import MIR.HarmGram.MIR
+import MIR.GeneratedInstances.GeneratedInstance2()
+
+$(deriveAll ''Phrase)
+$(simplInstance ''ParseG ''Phrase 'parseG 'parseGdefault)
+$(simplInstance ''ShowChord ''Phrase 'showChord 'showChordDefault)
+$(simplInstance ''Children ''Phrase 'children 'childrenDef)
+$(simplInstance ''Build ''Phrase 'build 'buildDef)
+$(simplInstance ''SEq ''Phrase 'shallowEq 'shallowEqDef)
+instance GDiff Phrase
diff --git a/MIR/GeneratedInstances/GeneratedInstance10.hs b/MIR/GeneratedInstances/GeneratedInstance10.hs
new file mode 100644
--- /dev/null
+++ b/MIR/GeneratedInstances/GeneratedInstance10.hs
@@ -0,0 +1,24 @@
+{-# OPTIONS_GHC -fno-warn-orphans   #-}
+{-# LANGUAGE TemplateHaskell        #-}
+{-# LANGUAGE EmptyDataDecls         #-}
+{-# LANGUAGE TypeFamilies           #-}
+
+module MIR.GeneratedInstances.GeneratedInstance10 where
+
+-- Generics stuff
+import Generics.Instant.TH
+
+-- Music stuff
+import MIR.HarmGram.ParserChord
+import MIR.HarmGram.ShowChord
+import MIR.Matching.GDiff
+import MIR.HarmGram.MIR
+import MIR.GeneratedInstances.GeneratedInstance11()
+
+$(deriveAll ''SMin)
+$(simplInstance ''ParseG ''SMin 'parseG 'parseGdefault)
+$(simplInstance ''ShowChord ''SMin 'showChord 'showChordDefault)
+$(simplInstance ''Children ''SMin 'children 'childrenDef)
+$(simplInstance ''Build ''SMin 'build 'buildDef)
+$(simplInstance ''SEq ''SMin 'shallowEq 'shallowEqDef)
+instance GDiff SMin
diff --git a/MIR/GeneratedInstances/GeneratedInstance11.hs b/MIR/GeneratedInstances/GeneratedInstance11.hs
new file mode 100644
--- /dev/null
+++ b/MIR/GeneratedInstances/GeneratedInstance11.hs
@@ -0,0 +1,24 @@
+{-# OPTIONS_GHC -fno-warn-orphans   #-}
+{-# LANGUAGE TemplateHaskell        #-}
+{-# LANGUAGE EmptyDataDecls         #-}
+{-# LANGUAGE TypeFamilies           #-}
+
+module MIR.GeneratedInstances.GeneratedInstance11 where
+
+-- Generics stuff
+import Generics.Instant.TH
+
+-- Music stuff
+import MIR.HarmGram.ParserChord
+import MIR.HarmGram.ShowChord
+import MIR.Matching.GDiff
+import MIR.HarmGram.MIR
+import MIR.GeneratedInstances.GeneratedInstance12()
+
+$(deriveAll ''DiatVm)
+$(simplInstance ''ParseG ''DiatVm 'parseG 'parseGdefault)
+$(simplInstance ''ShowChord ''DiatVm 'showChord 'showChordDefault)
+$(simplInstance ''Children ''DiatVm 'children 'childrenDef)
+$(simplInstance ''Build ''DiatVm 'build 'buildDef)
+$(simplInstance ''SEq ''DiatVm 'shallowEq 'shallowEqDef)
+instance GDiff DiatVm
diff --git a/MIR/GeneratedInstances/GeneratedInstance12.hs b/MIR/GeneratedInstances/GeneratedInstance12.hs
new file mode 100644
--- /dev/null
+++ b/MIR/GeneratedInstances/GeneratedInstance12.hs
@@ -0,0 +1,24 @@
+{-# OPTIONS_GHC -fno-warn-orphans   #-}
+{-# LANGUAGE TemplateHaskell        #-}
+{-# LANGUAGE EmptyDataDecls         #-}
+{-# LANGUAGE TypeFamilies           #-}
+
+module MIR.GeneratedInstances.GeneratedInstance12 where
+
+-- Generics stuff
+import Generics.Instant.TH
+
+-- Music stuff
+import MIR.HarmGram.ParserChord
+import MIR.HarmGram.ShowChord
+import MIR.Matching.GDiff
+import MIR.HarmGram.MIR
+import MIR.GeneratedInstances.GeneratedInstance13()
+
+$(deriveAll ''SMinBorrow)
+$(simplInstance ''ParseG ''SMinBorrow 'parseG 'parseGdefault)
+$(simplInstance ''ShowChord ''SMinBorrow 'showChord 'showChordDefault)
+$(simplInstance ''Children ''SMinBorrow 'children 'childrenDef)
+$(simplInstance ''Build ''SMinBorrow 'build 'buildDef)
+$(simplInstance ''SEq ''SMinBorrow 'shallowEq 'shallowEqDef)
+instance GDiff SMinBorrow
diff --git a/MIR/GeneratedInstances/GeneratedInstance13.hs b/MIR/GeneratedInstances/GeneratedInstance13.hs
new file mode 100644
--- /dev/null
+++ b/MIR/GeneratedInstances/GeneratedInstance13.hs
@@ -0,0 +1,24 @@
+{-# OPTIONS_GHC -fno-warn-orphans   #-}
+{-# LANGUAGE TemplateHaskell        #-}
+{-# LANGUAGE EmptyDataDecls         #-}
+{-# LANGUAGE TypeFamilies           #-}
+
+module MIR.GeneratedInstances.GeneratedInstance13 where
+
+-- Generics stuff
+import Generics.Instant.TH
+
+-- Music stuff
+import MIR.HarmGram.ParserChord
+import MIR.HarmGram.ShowChord
+import MIR.Matching.GDiff
+import MIR.HarmGram.MIR
+import MIR.GeneratedInstances.GeneratedInstance14()
+
+$(deriveAll ''TMajBorrow)
+$(simplInstance ''ParseG ''TMajBorrow 'parseG 'parseGdefault)
+$(simplInstance ''ShowChord ''TMajBorrow 'showChord 'showChordDefault)
+$(simplInstance ''Children ''TMajBorrow 'children 'childrenDef)
+$(simplInstance ''Build ''TMajBorrow 'build 'buildDef)
+$(simplInstance ''SEq ''TMajBorrow 'shallowEq 'shallowEqDef)
+instance GDiff TMajBorrow
diff --git a/MIR/GeneratedInstances/GeneratedInstance14.hs b/MIR/GeneratedInstances/GeneratedInstance14.hs
new file mode 100644
--- /dev/null
+++ b/MIR/GeneratedInstances/GeneratedInstance14.hs
@@ -0,0 +1,8 @@
+{-# OPTIONS_GHC -fno-warn-orphans   #-}
+{-# LANGUAGE TemplateHaskell        #-}
+{-# LANGUAGE EmptyDataDecls         #-}
+{-# LANGUAGE TypeFamilies           #-}
+
+module MIR.GeneratedInstances.GeneratedInstance14 where
+
+import MIR.Instances ()
diff --git a/MIR/GeneratedInstances/GeneratedInstance2.hs b/MIR/GeneratedInstances/GeneratedInstance2.hs
new file mode 100644
--- /dev/null
+++ b/MIR/GeneratedInstances/GeneratedInstance2.hs
@@ -0,0 +1,24 @@
+{-# OPTIONS_GHC -fno-warn-orphans   #-}
+{-# LANGUAGE TemplateHaskell        #-}
+{-# LANGUAGE EmptyDataDecls         #-}
+{-# LANGUAGE TypeFamilies           #-}
+
+module MIR.GeneratedInstances.GeneratedInstance2 where
+
+-- Generics stuff
+import Generics.Instant.TH
+
+-- Music stuff
+import MIR.HarmGram.ParserChord
+import MIR.HarmGram.ShowChord
+import MIR.Matching.GDiff
+import MIR.HarmGram.MIR
+import MIR.GeneratedInstances.GeneratedInstance3()
+
+$(deriveAll ''PhraseMin)
+$(simplInstance ''ParseG ''PhraseMin 'parseG 'parseGdefault)
+$(simplInstance ''ShowChord ''PhraseMin 'showChord 'showChordDefault)
+$(simplInstance ''Children ''PhraseMin 'children 'childrenDef)
+$(simplInstance ''Build ''PhraseMin 'build 'buildDef)
+$(simplInstance ''SEq ''PhraseMin 'shallowEq 'shallowEqDef)
+instance GDiff PhraseMin
diff --git a/MIR/GeneratedInstances/GeneratedInstance3.hs b/MIR/GeneratedInstances/GeneratedInstance3.hs
new file mode 100644
--- /dev/null
+++ b/MIR/GeneratedInstances/GeneratedInstance3.hs
@@ -0,0 +1,24 @@
+{-# OPTIONS_GHC -fno-warn-orphans   #-}
+{-# LANGUAGE TemplateHaskell        #-}
+{-# LANGUAGE EmptyDataDecls         #-}
+{-# LANGUAGE TypeFamilies           #-}
+
+module MIR.GeneratedInstances.GeneratedInstance3 where
+
+-- Generics stuff
+import Generics.Instant.TH
+
+-- Music stuff
+import MIR.HarmGram.ParserChord
+import MIR.HarmGram.ShowChord
+import MIR.Matching.GDiff
+import MIR.HarmGram.MIR
+import MIR.GeneratedInstances.GeneratedInstance4()
+
+$(deriveAll ''TMin)
+$(simplInstance ''ParseG ''TMin 'parseG 'parseGdefault)
+$(simplInstance ''ShowChord ''TMin 'showChord 'showChordDefault)
+$(simplInstance ''Children ''TMin 'children 'childrenDef)
+$(simplInstance ''Build ''TMin 'build 'buildDef)
+$(simplInstance ''SEq ''TMin 'shallowEq 'shallowEqDef)
+instance GDiff TMin
diff --git a/MIR/GeneratedInstances/GeneratedInstance4.hs b/MIR/GeneratedInstances/GeneratedInstance4.hs
new file mode 100644
--- /dev/null
+++ b/MIR/GeneratedInstances/GeneratedInstance4.hs
@@ -0,0 +1,24 @@
+{-# OPTIONS_GHC -fno-warn-orphans   #-}
+{-# LANGUAGE TemplateHaskell        #-}
+{-# LANGUAGE EmptyDataDecls         #-}
+{-# LANGUAGE TypeFamilies           #-}
+
+module MIR.GeneratedInstances.GeneratedInstance4 where
+
+-- Generics stuff
+import Generics.Instant.TH
+
+-- Music stuff
+import MIR.HarmGram.ParserChord
+import MIR.HarmGram.ShowChord
+import MIR.Matching.GDiff
+import MIR.HarmGram.MIR
+import MIR.GeneratedInstances.GeneratedInstance5()
+
+$(deriveAll ''Ton)
+$(simplInstance ''ParseG ''Ton 'parseG 'parseGdefault)
+$(simplInstance ''ShowChord ''Ton 'showChord 'showChordDefault)
+$(simplInstance ''Children ''Ton 'children 'childrenDef)
+$(simplInstance ''Build ''Ton 'build 'buildDef)
+$(simplInstance ''SEq ''Ton 'shallowEq 'shallowEqDef)
+instance GDiff Ton
diff --git a/MIR/GeneratedInstances/GeneratedInstance5.hs b/MIR/GeneratedInstances/GeneratedInstance5.hs
new file mode 100644
--- /dev/null
+++ b/MIR/GeneratedInstances/GeneratedInstance5.hs
@@ -0,0 +1,24 @@
+{-# OPTIONS_GHC -fno-warn-orphans   #-}
+{-# LANGUAGE TemplateHaskell        #-}
+{-# LANGUAGE EmptyDataDecls         #-}
+{-# LANGUAGE TypeFamilies           #-}
+
+module MIR.GeneratedInstances.GeneratedInstance5 where
+
+-- Generics stuff
+import Generics.Instant.TH
+
+-- Music stuff
+import MIR.HarmGram.ParserChord
+import MIR.HarmGram.ShowChord
+import MIR.Matching.GDiff
+import MIR.HarmGram.MIR
+import MIR.GeneratedInstances.GeneratedInstance6()
+
+$(deriveAll ''Dom)
+$(simplInstance ''ParseG ''Dom 'parseG 'parseGdefault)
+$(simplInstance ''ShowChord ''Dom 'showChord 'showChordDefault)
+$(simplInstance ''Children ''Dom 'children 'childrenDef)
+$(simplInstance ''Build ''Dom 'build 'buildDef)
+$(simplInstance ''SEq ''Dom 'shallowEq 'shallowEqDef)
+instance GDiff Dom
diff --git a/MIR/GeneratedInstances/GeneratedInstance6.hs b/MIR/GeneratedInstances/GeneratedInstance6.hs
new file mode 100644
--- /dev/null
+++ b/MIR/GeneratedInstances/GeneratedInstance6.hs
@@ -0,0 +1,24 @@
+{-# OPTIONS_GHC -fno-warn-orphans   #-}
+{-# LANGUAGE TemplateHaskell        #-}
+{-# LANGUAGE EmptyDataDecls         #-}
+{-# LANGUAGE TypeFamilies           #-}
+
+module MIR.GeneratedInstances.GeneratedInstance6 where
+
+-- Generics stuff
+import Generics.Instant.TH
+
+-- Music stuff
+import MIR.HarmGram.ParserChord
+import MIR.HarmGram.ShowChord
+import MIR.Matching.GDiff
+import MIR.HarmGram.MIR
+import MIR.GeneratedInstances.GeneratedInstance7()
+
+$(deriveAll ''DMinBorrow)
+$(simplInstance ''ParseG ''DMinBorrow 'parseG 'parseGdefault)
+$(simplInstance ''ShowChord ''DMinBorrow 'showChord 'showChordDefault)
+$(simplInstance ''Children ''DMinBorrow 'children 'childrenDef)
+$(simplInstance ''Build ''DMinBorrow 'build 'buildDef)
+$(simplInstance ''SEq ''DMinBorrow 'shallowEq 'shallowEqDef)
+instance GDiff DMinBorrow
diff --git a/MIR/GeneratedInstances/GeneratedInstance7.hs b/MIR/GeneratedInstances/GeneratedInstance7.hs
new file mode 100644
--- /dev/null
+++ b/MIR/GeneratedInstances/GeneratedInstance7.hs
@@ -0,0 +1,24 @@
+{-# OPTIONS_GHC -fno-warn-orphans   #-}
+{-# LANGUAGE TemplateHaskell        #-}
+{-# LANGUAGE EmptyDataDecls         #-}
+{-# LANGUAGE TypeFamilies           #-}
+
+module MIR.GeneratedInstances.GeneratedInstance7 where
+
+-- Generics stuff
+import Generics.Instant.TH
+
+-- Music stuff
+import MIR.HarmGram.ParserChord
+import MIR.HarmGram.ShowChord
+import MIR.Matching.GDiff
+import MIR.HarmGram.MIR
+import MIR.GeneratedInstances.GeneratedInstance8()
+
+$(deriveAll ''SDom)
+$(simplInstance ''ParseG ''SDom 'parseG 'parseGdefault)
+$(simplInstance ''ShowChord ''SDom 'showChord 'showChordDefault)
+$(simplInstance ''Children ''SDom 'children 'childrenDef)
+$(simplInstance ''Build ''SDom 'build 'buildDef)
+$(simplInstance ''SEq ''SDom 'shallowEq 'shallowEqDef)
+instance GDiff SDom
diff --git a/MIR/GeneratedInstances/GeneratedInstance8.hs b/MIR/GeneratedInstances/GeneratedInstance8.hs
new file mode 100644
--- /dev/null
+++ b/MIR/GeneratedInstances/GeneratedInstance8.hs
@@ -0,0 +1,24 @@
+{-# OPTIONS_GHC -fno-warn-orphans   #-}
+{-# LANGUAGE TemplateHaskell        #-}
+{-# LANGUAGE EmptyDataDecls         #-}
+{-# LANGUAGE TypeFamilies           #-}
+
+module MIR.GeneratedInstances.GeneratedInstance8 where
+
+-- Generics stuff
+import Generics.Instant.TH
+
+-- Music stuff
+import MIR.HarmGram.ParserChord
+import MIR.HarmGram.ShowChord
+import MIR.Matching.GDiff
+import MIR.HarmGram.MIR
+import MIR.GeneratedInstances.GeneratedInstance9()
+
+$(deriveAll ''DMin)
+$(simplInstance ''ParseG ''DMin 'parseG 'parseGdefault)
+$(simplInstance ''ShowChord ''DMin 'showChord 'showChordDefault)
+$(simplInstance ''Children ''DMin 'children 'childrenDef)
+$(simplInstance ''Build ''DMin 'build 'buildDef)
+$(simplInstance ''SEq ''DMin 'shallowEq 'shallowEqDef)
+instance GDiff DMin
diff --git a/MIR/GeneratedInstances/GeneratedInstance9.hs b/MIR/GeneratedInstances/GeneratedInstance9.hs
new file mode 100644
--- /dev/null
+++ b/MIR/GeneratedInstances/GeneratedInstance9.hs
@@ -0,0 +1,24 @@
+{-# OPTIONS_GHC -fno-warn-orphans   #-}
+{-# LANGUAGE TemplateHaskell        #-}
+{-# LANGUAGE EmptyDataDecls         #-}
+{-# LANGUAGE TypeFamilies           #-}
+
+module MIR.GeneratedInstances.GeneratedInstance9 where
+
+-- Generics stuff
+import Generics.Instant.TH
+
+-- Music stuff
+import MIR.HarmGram.ParserChord
+import MIR.HarmGram.ShowChord
+import MIR.Matching.GDiff
+import MIR.HarmGram.MIR
+import MIR.GeneratedInstances.GeneratedInstance10()
+
+$(deriveAll ''DiatV)
+$(simplInstance ''ParseG ''DiatV 'parseG 'parseGdefault)
+$(simplInstance ''ShowChord ''DiatV 'showChord 'showChordDefault)
+$(simplInstance ''Children ''DiatV 'children 'childrenDef)
+$(simplInstance ''Build ''DiatV 'build 'buildDef)
+$(simplInstance ''SEq ''DiatV 'shallowEq 'shallowEqDef)
+instance GDiff DiatV
diff --git a/MIR/GeneratedInstances/GeneratedInstances.hs b/MIR/GeneratedInstances/GeneratedInstances.hs
new file mode 100644
--- /dev/null
+++ b/MIR/GeneratedInstances/GeneratedInstances.hs
@@ -0,0 +1,21 @@
+{-# OPTIONS_GHC -fno-warn-orphans   #-}
+{-# LANGUAGE TemplateHaskell        #-}
+{-# LANGUAGE EmptyDataDecls         #-}
+{-# LANGUAGE TypeFamilies           #-}
+
+module MIR.GeneratedInstances.GeneratedInstances where
+
+import MIR.GeneratedInstances.GeneratedInstance0()
+import MIR.GeneratedInstances.GeneratedInstance1()
+import MIR.GeneratedInstances.GeneratedInstance2()
+import MIR.GeneratedInstances.GeneratedInstance3()
+import MIR.GeneratedInstances.GeneratedInstance4()
+import MIR.GeneratedInstances.GeneratedInstance5()
+import MIR.GeneratedInstances.GeneratedInstance6()
+import MIR.GeneratedInstances.GeneratedInstance7()
+import MIR.GeneratedInstances.GeneratedInstance8()
+import MIR.GeneratedInstances.GeneratedInstance9()
+import MIR.GeneratedInstances.GeneratedInstance10()
+import MIR.GeneratedInstances.GeneratedInstance11()
+import MIR.GeneratedInstances.GeneratedInstance12()
+import MIR.GeneratedInstances.GeneratedInstance13()
diff --git a/MIR/HarmGram/MIR.hs b/MIR/HarmGram/MIR.hs
new file mode 100644
--- /dev/null
+++ b/MIR/HarmGram/MIR.hs
@@ -0,0 +1,339 @@
+{-# LANGUAGE TemplateHaskell          #-}
+{-# LANGUAGE TypeOperators            #-}
+{-# LANGUAGE EmptyDataDecls           #-}
+{-# LANGUAGE TypeSynonymInstances     #-}
+{-# LANGUAGE FlexibleInstances        #-}
+{-# LANGUAGE ScopedTypeVariables      #-}
+{-# LANGUAGE MultiParamTypeClasses    #-}
+{-# LANGUAGE TypeFamilies             #-}
+{-# LANGUAGE UndecidableInstances     #-}
+{-# LANGUAGE GADTs                    #-}
+{-# LANGUAGE CPP                      #-}
+{-# LANGUAGE DeriveDataTypeable       #-}
+
+module MIR.HarmGram.MIR where
+
+import MIR.HarmGram.TypeLevel
+
+import MIR.HarmGram.Tokenizer hiding (D)
+import Language.Haskell.TH.Syntax (Name)
+
+import Data.Typeable
+
+--------------------------------------------------------------------------------
+-- Musical structure as a datatype
+--------------------------------------------------------------------------------
+
+-- High level structure
+data Piece = Piece     [Phrase] 
+           | Piece_min [PhraseMin] 
+  deriving Typeable
+
+-- The Prase level           
+data Phrase     = PT Ton
+                | PD Dom
+  deriving Typeable
+data PhraseMin  = PT_m TMin
+                | PD_m DMin
+  deriving Typeable
+                
+-- Harmonic categories for pieces in major keys
+-- Tonic in major
+data Ton  = T_2 (SD I MajClass)
+          | Tbls_0 (Final I DomClass)
+          | T_3 (Final I MajClass) (Final IV  MajClass) (Final I MajClass)
+          | T_4 (Final I MajClass) (Final I   DimClass) (Final I MajClass)
+  deriving Typeable
+
+-- Dominant in major    
+data Dom  = D_1 SDom Dom 
+          | Dm_0 DMinBorrow 
+          | D_2 (SD V DomClass)
+          | D_3 (SD V MajClass)
+          | D_4 (SD VII DimClass)
+          | D_5 (Final V DomClass) (Final V DimClass) (Final V DomClass)   
+  deriving Typeable
+
+-- Subdominant in major          
+data SDom = S_1  DiatV
+          | Sbls_0 (SD IV DomClass) (SD I DomClass)
+          | Sm_0 SMinBorrow
+          | S_2 (SD II MinClass)
+          | S_3 (SD IV MajClass)
+          | S_4 (SD VI MinClass) -- maybe substitute by sec dom??
+          | S_5 (SD III MinClass) (Final IV MajClass) 
+          | S_6 (SD II DomClass) (Final II MinClass) -- pretty printing???
+  deriving Typeable
+
+-- account for diatonic succession          
+data DiatV  = Vd_1 (SD III MinClass) (Final VI  MinClass)
+            | Vd_2 (SD IV  MajClass) (Final VII MinClass)  
+  deriving Typeable
+
+-- Harmonic categories for pieces in minor keys
+data TMin = Tm_2 (SD I MinClass)
+          | Tm_3 (Final I MinClass) (Final IV  MinClass) (Final I MinClass)
+          | T_0 TMajBorrow
+  deriving Typeable
+
+data TMajBorrow = 
+            Tpar (SD IIIb MajClass)
+  deriving Typeable
+          
+data DMin = Dm_1 SMin DMin
+          | Dm_2 (SD V DomClass)
+          | Dm_3 (SD V MajClass)      
+          -- | Dm_4 (Final VIIb DomClass)   
+          | Dm_5 (SD IIb  MajClass)   -- Neapolitan 
+  deriving Typeable
+
+-- Borrowings from minor in a major key
+data DMinBorrow =      
+            Dm_4' (Final VIIb DomClass)   
+          | Dm_5' (SD IIb  MajClass)   -- Neapolitan 
+  deriving Typeable
+ 
+data SMin = Sm_1 DiatVm
+          | Sm_2 (SD II MinClass)
+          | Sm_3 (SD IV MinClass)
+          | Sm_4 (SD VIb MajClass)
+          | Sm_5 (SD II DomClass) (Final II MinClass) -- pretty printing???
+  deriving Typeable
+ 
+ -- Borrowings from minor in a major key
+data SMinBorrow = 
+            Sm_3' (SD IV MinClass)
+  deriving Typeable
+
+data DiatVm  = Vdm_1  (SD IIIb MajClass) (Final VIb MajClass)
+             | Vdm_2  (SD IV  MinClass)  (Final VII DomClass)  
+             -- | Vd_m2 (SD VI MajClass)  (Final II MinClass)
+  deriving Typeable
+
+         
+-- Limit secondary dominants to a few levels
+type SD deg clss = Base_SD deg clss T5
+
+-- a type that can be substituted by its tritone sub and diminished 7b9
+type TritMinVSub deg clss = Base_Final deg clss T2
+
+-- A Scale degree that can only trnaslate to a surface chord
+-- (or a dim chord transformation of a diminshed surface chord
+type Final deg clss = Surface_Chord deg clss T4
+
+
+-- Datatypes for clustering harmonic degrees
+data Base_SD deg clss :: * -> * where
+  Base_SD      :: Min5    deg clss  n           
+               -> Base_SD deg clss (Su n)
+  -- Rule for explaining perfect secondary dominants
+  Cons_Vdom :: Base_SD (VDom deg) DomClass n -> Min5 deg clss n
+               -> Base_SD deg clss (Su n)             
+  deriving Typeable
+
+-- One case only allowed (Tritone or Cons_Vmin)
+type Min5 deg clss n = Base_Vmin deg clss n
+
+data Base_Vmin deg clss :: * -> * where
+  -- No minor fifth
+  Base_Vmin :: TritMinVSub deg clss             
+            -> Base_Vmin   deg clss (Su n)
+  -- Minor fifth insertion
+  Cons_Vmin :: Base_SD  (VMin deg) MinClass     n  -> TritMinVSub deg DomClass 
+            -> Base_Vmin      deg  DomClass (Su n)
+  deriving Typeable
+            
+            
+data Base_Final deg :: * -> * -> * where
+  -- Just a "normal", final degree. The Strings are the original input.
+  Base_Final     :: Final deg clss -> Base_Final deg clss (Su n)
+  -- Tritone substitution
+  Final_Tritone  :: Base_Final (Tritone deg) DomClass n
+                 -> Base_Final deg DomClass (Su n)   
+  Final_Dim_Trit :: Base_Final (Tritone deg) DimClass n
+                 -> Base_Final deg DomClass (Su n)     
+  deriving Typeable         
+
+-- Diminished tritone substitution accounting for diminished chord transistions
+data Surface_Chord deg :: * -> * -> * where
+  Surface_Chord  :: Degree -> [(Class, String)] 
+                 -> Surface_Chord deg clss    (Su n)            
+  Dim_Chord_Trns :: Surface_Chord (MinThird deg) DimClass n
+                 -> Surface_Chord deg DimClass (Su n)  
+  deriving Typeable    
+
+--------------------------------------------------------------------------------
+-- Type Level Scale Degrees
+--------------------------------------------------------------------------------
+
+-- Classes (at the type level)
+data MajClass deriving Typeable
+data MinClass deriving Typeable
+data DomClass deriving Typeable
+data DimClass deriving Typeable
+
+-- Classes (at the value level)
+data Class = Class ClassType Shorthand deriving Typeable
+
+instance Show Class where show (Class ct sh) = show ct
+
+data ClassType = MajClass | MinClass | DomClass | DimClass
+
+instance Show ClassType where
+  show (MajClass) = ""
+  show (MinClass) = "m"
+  show (DomClass) = "7"
+  show (DimClass) = "0"
+
+-- Degrees (at the type level)
+data I deriving Typeable
+data Ib deriving Typeable
+data Is deriving Typeable
+data II deriving Typeable
+data IIb deriving Typeable
+data IIs deriving Typeable
+data III deriving Typeable
+data IIIb deriving Typeable
+data IIIs deriving Typeable
+data IV deriving Typeable
+data IVb deriving Typeable
+data IVs deriving Typeable
+data V deriving Typeable
+data Vb deriving Typeable
+data Vs deriving Typeable
+data VI deriving Typeable
+data VIb deriving Typeable
+data VIs deriving Typeable
+data VII deriving Typeable
+data VIIb deriving Typeable
+data VIIs deriving Typeable
+
+-- Used when we don't want to consider certain possibilities
+data Imp deriving Typeable
+
+-- Degrees at the value level are in Tokenizer
+-- Type to value conversions
+class ToClass clss where
+  toClass :: clss -> ClassType
+
+instance ToClass MajClass where toClass _ = MajClass
+instance ToClass MinClass where toClass _ = MinClass
+instance ToClass DomClass where toClass _ = DomClass
+instance ToClass DimClass where toClass _ = DimClass
+
+-- The class doesn't really matter, since the degree will be impossible to parse
+instance ToClass Imp where toClass _ = DimClass
+
+class ToDegree deg where
+  toDegree :: deg -> Degree
+
+instance ToDegree I     where toDegree _ = Degree Nothing 1
+instance ToDegree II    where toDegree _ = Degree Nothing 2
+instance ToDegree III   where toDegree _ = Degree Nothing 3
+instance ToDegree IV    where toDegree _ = Degree Nothing 4
+instance ToDegree V     where toDegree _ = Degree Nothing 5
+instance ToDegree VI    where toDegree _ = Degree Nothing 6
+instance ToDegree VII   where toDegree _ = Degree Nothing 7
+instance ToDegree Ib    where toDegree _ = Degree (Just Fl) 1
+instance ToDegree IIb   where toDegree _ = Degree (Just Fl) 2
+instance ToDegree IIIb  where toDegree _ = Degree (Just Fl) 3
+instance ToDegree IVb   where toDegree _ = Degree (Just Fl) 4
+instance ToDegree Vb    where toDegree _ = Degree (Just Fl) 5
+instance ToDegree VIb   where toDegree _ = Degree (Just Fl) 6
+instance ToDegree VIIb  where toDegree _ = Degree (Just Fl) 7
+instance ToDegree IIs   where toDegree _ = Degree (Just Sh) 2
+instance ToDegree IIIs  where toDegree _ = Degree (Just Sh) 3
+instance ToDegree IVs   where toDegree _ = Degree (Just Sh) 4
+instance ToDegree Vs    where toDegree _ = Degree (Just Sh) 5
+instance ToDegree VIs   where toDegree _ = Degree (Just Sh) 6
+instance ToDegree VIIs  where toDegree _ = Degree (Just Sh) 7
+
+-- Can't ever parse degree 42 (TODO: what about error correction?...)
+instance ToDegree Imp where toDegree _ = Degree Nothing 42
+
+
+--------------------------------------------------------------------------------
+-- Type Families for Relative Scale Degrees
+--------------------------------------------------------------------------------
+-- Perfect fifths (class is always Dom)
+-- See http://en.wikipedia.org/wiki/Circle_of_fifths
+type family VDom deg :: *
+
+type instance VDom I     = Imp -- interferes with dom 
+type instance VDom IIb   = VIb
+type instance VDom II    = VI 
+type instance VDom IIIb  = VIIb -- interferes with Dm_3
+type instance VDom III   = VII
+type instance VDom IV    = I
+type instance VDom IVs   = IIb
+type instance VDom V     = II -- interferes with Sm_1
+type instance VDom VIb   = IIIb
+type instance VDom VI    = III
+type instance VDom VIIb  = IV
+type instance VDom VII   = IVs
+type instance VDom Imp   = Imp
+
+-- Perfect fifths for the minor case (this is an additional
+-- type family to controll the reduction of ambiguities
+-- specifically in the minor case)
+type family VMin deg :: *
+type instance VMin I     = V 
+type instance VMin IIb   = VIb
+type instance VMin II    = VI --Imp -- VI interferes with sub 
+type instance VMin IIIb  = VIIb
+type instance VMin III   = VII
+type instance VMin IV    = I
+type instance VMin IVs   = IIb
+type instance VMin V     = Imp -- II interferes with sub
+type instance VMin VIb   = IIIb
+type instance VMin VI    = III
+type instance VMin VIIb  = IV
+type instance VMin VII   = IVs
+type instance VMin Imp   = Imp
+
+-- The tritone substitution
+-- See http://en.wikipedia.org/wiki/Tritone_substitution
+type family Tritone deg :: *
+type instance Tritone I     = IVs
+type instance Tritone IVs   = I
+
+-- type instance Tritone Is    = V
+type instance Tritone IIb   = V
+type instance Tritone V     = IIb 
+
+type instance Tritone II    = VIb
+type instance Tritone VIb   = II
+
+type instance Tritone IIIb  = VI
+type instance Tritone VI    = IIIb
+
+type instance Tritone III   = VIIb -- Interferes with VIIb from minor
+type instance Tritone VIIb  = III 
+
+type instance Tritone IV    = VII
+type instance Tritone VII   = IV
+
+type instance Tritone Imp   = Imp
+
+
+type family MinThird deg :: *
+type instance MinThird I     = IIIb 
+type instance MinThird IIb   = III
+type instance MinThird II    = IV
+type instance MinThird IIIb  = IVs
+type instance MinThird III   = V
+type instance MinThird IV    = VIb
+type instance MinThird IVs   = VI
+type instance MinThird V     = VIIb 
+type instance MinThird VIb   = VII
+type instance MinThird VI    = I
+type instance MinThird VIIb  = IIb
+type instance MinThird VII   = II
+type instance MinThird Imp   = Imp
+
+-- Belongs in Instances, but needs to be here due to staging restrictions
+allTypes :: [Name]
+allTypes = [ ''Phrase, ''PhraseMin, ''TMin, ''Ton 
+           , ''Dom, ''DMinBorrow, ''SDom, ''DMin, ''DiatV, ''SMin, ''DiatVm 
+           , ''SMinBorrow, ''TMajBorrow
+           ]
diff --git a/MIR/HarmGram/ParserChord.hs b/MIR/HarmGram/ParserChord.hs
new file mode 100644
--- /dev/null
+++ b/MIR/HarmGram/ParserChord.hs
@@ -0,0 +1,86 @@
+{-# LANGUAGE TypeOperators          #-}
+{-# LANGUAGE TypeSynonymInstances   #-}
+{-# LANGUAGE FlexibleInstances      #-}
+{-# LANGUAGE FlexibleContexts       #-}
+{-# LANGUAGE TypeFamilies           #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE OverlappingInstances   #-}
+{-# LANGUAGE ScopedTypeVariables    #-}
+
+-- Semi-generic parser for chords
+module MIR.HarmGram.ParserChord where
+
+
+-- Parser stuff
+import Text.ParserCombinators.UU hiding (T)
+import Text.ParserCombinators.UU.BasicInstances hiding (head)
+import Text.ParserCombinators.UU.BasicInstances.List
+
+-- Generics stuff
+import Generics.Instant.Base as G
+
+-- Music stuff
+import MIR.HarmGram.Tokenizer
+
+
+--------------------------------------------------------------------------------
+-- The generic part of the parser
+--------------------------------------------------------------------------------
+
+--type PMusic a = Parser [ChordDegree] a (Int, Int)
+-- type Parser a b c = Stream a d => P (Str d a c) b
+type PMusic a = P (Str ChordDegree [ChordDegree] (Int, Int)) a
+
+class Parse' f where
+  parse' :: PMusic f
+
+instance Parse' U where
+  {- INLINE parse' #-}
+  parse' = pure U
+
+instance (ParseG a) => Parse' (Rec a) where
+  {- INLINE parse' #-}
+  parse' = Rec <$> parseG
+
+-- Not really necessary because TH is not generating any Var, but anyway
+instance (ParseG a) => Parse' (Var a) where
+  {- INLINE parse' #-}
+  parse' = Var <$> parseG
+
+instance (Constructor c, Parse' f) => Parse' (G.C c f) where
+  {- INLINE parse' #-}
+  parse' = G.C <$> parse' <?> "Constructor " ++ conName (undefined :: C c f)
+
+instance (Parse' f, Parse' g) => Parse' (f :+: g) where
+  {- INLINE parse' #-}
+  parse' = L <$> parse' <|> R <$> parse'
+
+instance (Parse' f, Parse' g) => Parse' (f :*: g) where
+  {- INLINE parse' #-}
+  parse' = (:*:) <$> parse' <*> parse'
+
+
+class ParseG a where
+  {- INLINE parseG #-}
+  parseG :: PMusic a
+
+instance (ParseG a) => ParseG [a] where
+  {- INLINE parseG #-}
+  parseG = pList1 parseG
+  -- We should use non-greedy parsing here, else the final Dom is never parsed
+  -- as such.
+  -- parseG = pList1_ng parseG
+
+instance (ParseG a) => ParseG (Maybe a) where
+  {- INLINE parseG #-}
+  parseG = pMaybe parseG
+
+{- INLINE parseGdefault #-}
+parseGdefault :: (Representable a, Parse' (Rep a)) => PMusic a
+-- parseGdefault = fmap (to . head) (amb parse')
+-- Previously we used:
+parseGdefault = fmap to parse'
+-- This gave rise to many ambiguities. Now we allow parse' to be ambiguous
+-- (note that the sum case uses <|>) but then pick only the very first tree
+-- from all the possible results. It remains to be seen if the first tree is
+-- the best...
diff --git a/MIR/HarmGram/ShowChord.hs b/MIR/HarmGram/ShowChord.hs
new file mode 100644
--- /dev/null
+++ b/MIR/HarmGram/ShowChord.hs
@@ -0,0 +1,83 @@
+{-# LANGUAGE TypeOperators            #-}
+{-# LANGUAGE FlexibleInstances        #-}
+{-# LANGUAGE FlexibleContexts         #-}
+{-# LANGUAGE OverlappingInstances     #-}
+
+module MIR.HarmGram.ShowChord (ShowChord(..), showChordDefault, paren) where
+
+import Generics.Instant.Base
+
+-- Generic show for chords on Representable (worker)
+class ShowChord a where
+  showChord :: a -> ShowS
+
+instance ShowChord U where
+  {- INLINE showChord #-}
+  showChord U = showString ""
+  
+instance (ShowChord a, ShowChord b) => ShowChord (a :+: b) where
+  {- INLINE showChord #-}
+  showChord (L x) = showChord x
+  showChord (R x) = showChord x
+  
+instance (ShowChord a, ShowChord b) => ShowChord (a :*: b) where
+  {- INLINE showChord #-}
+  showChord (a :*: b) = showChord a . showChord b
+  
+instance (ShowChord a, Constructor c) => ShowChord (C c a) where
+  {- INLINE showChord #-}
+  -- showChord c@(C a) = paren $ showString (takeWhile (/= '_') (conName c)) . showChord a
+  showChord c@(C a) = paren $ showString (conName c) . showChord a
+
+instance ShowChord a => ShowChord (Var a) where
+  {- INLINE showChord #-}
+  showChord (Var x) = showChord x
+
+instance ShowChord a => ShowChord (Rec a) where
+  {- INLINE showChord #-}
+  showChord (Rec x) = showChord x
+
+
+-- Dispatcher
+{- INLINE showChordDefault #-}
+showChordDefault :: (Representable a, ShowChord (Rep a)) => a -> ShowS
+showChordDefault = showChord . from
+
+
+-- Adhoc instances
+instance ShowChord Int      where 
+  {- INLINE showChord #-}
+  showChord = shows
+instance ShowChord Integer  where 
+  {- INLINE showChord #-}
+  showChord = shows
+instance ShowChord Float    where 
+  {- INLINE showChord #-}
+  showChord = shows
+instance ShowChord Double   where 
+  {- INLINE showChord #-}
+  showChord = shows
+instance ShowChord Char     where 
+  {- INLINE showChord #-}
+  showChord = shows
+instance ShowChord Bool     where 
+  {- INLINE showChord #-}
+  showChord = shows
+
+
+instance ShowChord a => ShowChord [a] where
+  {- INLINE showChord #-}
+  showChord = paren . foldr (.) id . map showChord
+  
+instance ShowChord [Char] where
+  {- INLINE showChord #-}
+  showChord = showString
+
+instance (ShowChord a) => ShowChord (Maybe a) where
+  {- INLINE showChord #-}
+  showChord Nothing  = id
+  showChord (Just a) = showChord a
+
+-- Utilities
+paren :: ShowS -> ShowS
+paren x = showChar '[' . x . showChar ']'
diff --git a/MIR/HarmGram/Tokenizer.hs b/MIR/HarmGram/Tokenizer.hs
new file mode 100644
--- /dev/null
+++ b/MIR/HarmGram/Tokenizer.hs
@@ -0,0 +1,247 @@
+{-# LANGUAGE DeriveDataTypeable       #-}
+{-# LANGUAGE RankNTypes               #-}
+{-# LANGUAGE FlexibleContexts         #-}
+
+module MIR.HarmGram.Tokenizer where
+
+-- Parser stuff
+import Text.ParserCombinators.UU
+import Text.ParserCombinators.UU.BasicInstances.String
+
+import Data.Char (digitToInt)
+import Data.List (intersperse)
+import Data.Maybe
+import Data.Typeable
+
+import Control.Arrow (first)
+
+
+--------------------------------------------------------------------------------
+-- Tokens for parsing chords
+--------------------------------------------------------------------------------
+
+data PieceToken = PieceToken { key :: ChordName, labels :: [ChordName] }
+
+data Chord a = Chord a (Maybe Shorthand) [Degree] String Int
+                -- The String stores the original input
+                -- The Int stores the number of repeated chords
+  deriving Eq
+  
+instance (Show a) => Show (Chord a) where
+  show (Chord a sh deg _ _) = show a 
+                             ++ if isJust sh then show (fromJust sh) else ""
+                             ++ if not (null deg) then show deg else ""
+  
+type ChordName = Chord ChordRoot
+
+data Degree = Degree (Maybe Modifier) Interval
+  deriving (Eq, Typeable)
+
+instance Show Degree where
+  show (Degree m interval) = intervalToDegree interval ++ maybe "" show m
+
+intervalToDegree :: Int -> String
+intervalToDegree i = ["I","II", "III","IV","V","VI","VII"] !! ((i-1) `mod` 7)
+  
+-- shows Degrees that are used as chord additions (see also showAdditions)   
+showAddition :: Degree -> String  
+showAddition (Degree m interval) = maybe "" show m ++ show interval
+  
+data Modifier = Sh | Fl | SS | FF -- Sharp, flat, double sharp, double flat
+  deriving (Eq)
+  
+instance Show Modifier where 
+  show Sh = "#"
+  show Fl = "b"
+  show SS = "##"
+  show FF = "bb"   
+
+data Shorthand = -- Triad chords
+                 Maj | Min | Dim | Aug
+                 -- Seventh chords
+               | Maj7 | Min7 | Sev | Dim7 | HDim7 | MinMaj7
+                 -- Sixth chords
+               | Maj6 | Min6
+                 -- Extended chords
+               | Nin | Maj9 | Min9
+                 -- Suspended chords
+               | Sus4
+  deriving (Show, Eq)
+
+type Interval = Int -- Ranges from 1 to 13
+
+data ChordRoot = A  | B  | C  | D  | E  | F  | G
+               | Ab | Bb | Cb | Db | Eb | Fb | Gb
+               | As | Bs | Cs | Ds | Es | Fs | Gs
+  deriving (Show, Eq)
+
+pString :: (Provides st a b) => [a] -> P st [b]
+pString s = foldr (\a b -> (:) <$> a <*> b) (pure []) (map pSym s)
+
+-- Input is a string of whitespace-separated chords, e.g.
+-- Bb:9(s11) E:min7 Eb:min7 Ab:7 D:min7 G:7(13) C:maj6(9)
+-- First token is the key of the piece
+parseSong :: Parser PieceToken
+parseSong = PieceToken <$> parseKey <* pSpaces 
+                       <*> pListSep_ng pSpaces parseChord 
+                           <* pList pSpaces
+  where pSpaces = pAnySym [' ','\n','\t']
+
+-- For now, I assume there is always a shorthand, and sometimes extra
+-- degrees. I guess it might be the case that sometimes there is no shorthand,
+-- but then there certainly are degrees.
+parseChord, parseKey :: Parser ChordName
+parseChord = f <$> parseRoot <* pSym ':' <*> pMaybe parseShorthand
+                                         <*> (parseDegrees `opt` [])
+  where -- in case of a sus4 we also analyse the degree list, if there is one.
+        f r (Just Sus4) [] = Chord r (Just Sus4) [] (str r Sus4 []) 1
+        f r (Just Sus4) d  = Chord r (Just $ analyseDegs d) d 
+                                      (str r (analyseDegs d) d) 1
+        -- if we have a short hand we use it to determine the class of the chord
+        f r (Just s)    d  = Chord r (Just s) d (str r s d) 1
+        -- in case of there is no short hand we analyse the degree list
+        f r Nothing     d  = Chord r (Just $ analyseDegs d) d 
+                                      (str r (analyseDegs d) d) 1
+        str r s d          = show r ++ show s ++ showAdditions d
+
+parseKey = f <$> parseRoot <* pSym ':' <*> parseShorthand
+  where f k m | k == C && (m == Maj || m == Min) = Chord k (Just m) [] "" 1
+              | otherwise = error "Tokenizer: key must be C:Maj or C:min"
+
+-- analyses a list of Degrees and assigns a shortHand i.e. Chord Class        
+analyseDegs :: [Degree] -> Shorthand        
+analyseDegs d 
+  | (Degree (Just Fl) 5)  `elem` d = Min
+  | (Degree (Just Sh) 5)  `elem` d = Sev
+  | (Degree (Just Fl) 7)  `elem` d = Sev
+  | (Degree (Just Fl) 9)  `elem` d = Sev
+  | (Degree (Just Sh) 9)  `elem` d = Sev
+  | (Degree (Just Sh) 11) `elem` d = Sev
+  | (Degree (Just Fl) 13) `elem` d = Sev
+  | (Degree (Just Fl) 3)  `elem` d = Min
+  | (Degree  Nothing  3)  `elem` d = Maj
+  | otherwise                      = Maj
+   
+       
+-- for showing additional additions
+showAdditions :: [Degree] -> String
+showAdditions a 
+  | null a    = ""
+  | otherwise = "(" ++ concat (intersperse ","  (map showAddition a)) ++ ")"
+
+
+parseShorthand :: Parser Shorthand
+parseShorthand =     Maj      <$ pString "maj"
+                 <|> Min      <$ pString "min"
+                 <|> Dim      <$ pString "dim"
+                 <|> Aug      <$ pString "aug"
+                 <|> Maj7     <$ pString "maj7"
+                 <|> Min7     <$ pString "min7"
+                 <|> Sev      <$ pString "7"
+                 <|> Dim7     <$ pString "dim7"
+                 <|> HDim7    <$ pString "hdim" <* opt (pSym '7') '7'
+                 <|> MinMaj7  <$ pString "minmaj7"
+                 <|> Maj6     <$ pString "maj6"
+                 <|> Maj6     <$ pString "6"
+                 <|> Min6     <$ pString "min6"
+                 <|> Nin      <$ pString "9"
+                 <|> Maj9     <$ pString "maj9"
+                 <|> Min9     <$ pString "min9"
+                 <|> Sus4     <$ pString "sus4" <?> "Shorthand"
+
+-- We don't produce intervals for a shorthand. This could easily be added,
+-- though.
+parseDegrees :: Parser [Degree]
+parseDegrees = pPacked (pSym '(') (pSym ')') 
+                       (catMaybes <$> (pList1Sep (pSym ',') parseDegree))
+                 
+parseDegree :: Parser (Maybe Degree)
+parseDegree =     (Just   <$> (Degree <$> pMaybe parseModifier <*> parseInterval))
+              <|> Nothing <$  pSym '*' <* pMaybe parseModifier <*  parseInterval
+              
+parseModifier :: Parser Modifier
+parseModifier =     Sh <$ pSym    's'
+                <|> Fl <$ pSym    'b'
+                <|> SS <$ pString "ss"
+                <|> FF <$ pString "bb" <?> "Modifier"
+
+parseInterval :: Parser Interval
+parseInterval = pInt
+
+pInt :: Parser Int
+pInt = fmap (foldl (\b a -> b * 10 + digitToInt a) 0) 
+            (pList (pAnySym ['0'..'9']))
+
+parseRoot :: Parser ChordRoot
+parseRoot =     A  <$ pSym 'A'
+            <|> B  <$ pSym 'B'
+            <|> C  <$ pSym 'C'
+            <|> D  <$ pSym 'D'
+            <|> E  <$ pSym 'E'
+            <|> F  <$ pSym 'F'
+            <|> G  <$ pSym 'G'
+            <|> Ab <$ pString "Ab"
+            <|> Bb <$ pString "Bb"
+            <|> Cb <$ pString "Cb"
+            <|> Db <$ pString "Db"
+            <|> Eb <$ pString "Eb"
+            <|> Fb <$ pString "Fb"
+            <|> Gb <$ pString "Gb"
+            <|> As <$ pString "A#"
+            <|> Bs <$ pString "B#"
+            <|> Cs <$ pString "C#"
+            <|> Ds <$ pString "D#"
+            <|> Es <$ pString "E#"
+            <|> Fs <$ pString "F#"
+            <|> Gs <$ pString "G#" <?> "Chord root"
+
+-- Testing the tokenizer
+testTokenizer :: String -> IO ()
+testTokenizer s = readFile s >>= print' . map (first labels) . aux where
+  aux = parse (amb ((,) <$> parseSong <*> pEnd)) . createStr
+  print' l@(h:_:_) =
+       putStrLn (show (length l) ++ " possible trees, showing the first:")
+    >> print' [h]
+  print' [(l,e)]   = mapM_ print l >> show_errors e
+  print' []        = print "No parse trees!"
+
+--------------------------------------------------------------------------------
+-- From chord names to chord degrees
+--------------------------------------------------------------------------------
+type ChordDegree = Chord Degree
+
+-- relativizeC chord converts a chord to a degree, on scale C
+-- (Obviously, this should be generalized to any scale degree, but for now
+-- this will do.)
+relativizeC :: ChordName -> ChordDegree
+relativizeC (Chord n s i r m) = Chord (rel n) s i r m where
+  rel :: ChordRoot -> Degree
+  rel C = Degree Nothing 1
+  rel D = Degree Nothing 2
+  rel E = Degree Nothing 3
+  rel F = Degree Nothing 4
+  rel G = Degree Nothing 5
+  rel A = Degree Nothing 6
+  rel B = Degree Nothing 7
+  rel Cs = Degree (Just Sh) 1
+  rel Ds = Degree (Just Sh) 2
+  rel Es = Degree (Just Sh) 3
+  rel Fs = Degree (Just Sh) 4
+  rel Gs = Degree (Just Sh) 5
+  rel As = Degree (Just Sh) 6
+  rel Bs = Degree (Just Sh) 7
+  rel Cb = Degree (Just Fl) 1
+  rel Db = Degree (Just Fl) 2
+  rel Eb = Degree (Just Fl) 3
+  rel Fb = Degree (Just Fl) 4
+  rel Gb = Degree (Just Fl) 5
+  rel Ab = Degree (Just Fl) 6
+  rel Bb = Degree (Just Fl) 7
+
+-- Merges duplicate chords
+mergeDups :: (Eq a) => [Chord a] -> [Chord a]
+mergeDups []  = []
+mergeDups [x] = [x]
+mergeDups (c1@(Chord n s i r m):c2@(Chord n2 s2 i2 r2 _):t)
+  | n == n2 && s == s2 = mergeDups ((Chord n s (i++i2) (r ++" "++ r2) (m+1)):t)
+  | otherwise          = c1 : mergeDups (c2:t)
diff --git a/MIR/HarmGram/TypeLevel.hs b/MIR/HarmGram/TypeLevel.hs
new file mode 100644
--- /dev/null
+++ b/MIR/HarmGram/TypeLevel.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE EmptyDataDecls           #-}
+{-# LANGUAGE KindSignatures           #-}
+{-# LANGUAGE TypeFamilies             #-}
+{-# LANGUAGE UndecidableInstances     #-}
+{-# LANGUAGE ScopedTypeVariables      #-}
+{-# LANGUAGE DeriveDataTypeable       #-}
+
+module MIR.HarmGram.TypeLevel (
+      Su, Ze 
+    , T0, T1, T2, T3, T4, T5, T6, T7, T8, T9, T10
+    , ToNat(..)
+  ) where
+
+import Data.Typeable
+
+
+-- Type level peano naturals
+data Su :: * -> *  deriving Typeable
+data Ze :: *       deriving Typeable
+
+-- Some shorthands
+type T0 = Ze
+type T1 = Su T0
+type T2 = Su T1
+type T3 = Su T2
+type T4 = Su T3
+type T5 = Su T4
+type T6 = Su T5
+type T7 = Su T6
+type T8 = Su T7
+type T9 = Su T8
+type T10 = Su T9
+
+class ToNat n where
+  toNat :: n -> Int
+
+instance ToNat Ze where toNat _ = 0
+instance (ToNat n) => ToNat (Su n) where toNat _ = 1 + toNat (undefined :: n)
diff --git a/MIR/Instances.hs b/MIR/Instances.hs
new file mode 100644
--- /dev/null
+++ b/MIR/Instances.hs
@@ -0,0 +1,532 @@
+{-# OPTIONS_GHC -fno-warn-orphans   #-}
+{-# LANGUAGE TemplateHaskell        #-}
+{-# LANGUAGE TypeOperators          #-}
+{-# LANGUAGE EmptyDataDecls         #-}
+{-# LANGUAGE TypeSynonymInstances   #-}
+{-# LANGUAGE ScopedTypeVariables    #-}
+{-# LANGUAGE FlexibleInstances      #-}
+{-# LANGUAGE FlexibleContexts       #-}
+{-# LANGUAGE TypeFamilies           #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE UndecidableInstances   #-}
+{-# LANGUAGE OverlappingInstances   #-}
+-- {-# LANGUAGE IncoherentInstances    #-} -- for ghc-6.12
+{-# LANGUAGE GADTs                  #-}
+
+module MIR.Instances where
+
+-- Generics stuff
+import Generics.Instant.TH
+
+-- Parser stuff
+import Text.ParserCombinators.UU
+import Text.ParserCombinators.UU.BasicInstances.List ()
+
+-- Diff
+import MIR.Matching.GDiff
+
+-- Music stuff
+import MIR.HarmGram.ParserChord
+import MIR.HarmGram.ShowChord
+import MIR.HarmGram.MIR
+import MIR.HarmGram.Tokenizer
+import MIR.HarmGram.TypeLevel
+
+-- Library modules
+import Control.Monad (join)
+import Data.List  (intersperse)
+import Data.Array
+import Control.Arrow
+import Data.Typeable 
+
+
+--------------------------------------------------------------------------------
+-- The non-generic part of the parser
+--------------------------------------------------------------------------------
+
+-- Ad-hoc cases for Base_SD
+instance ParseG (Base_SD   deg clss Ze) where parseG = empty
+instance ParseG (Base_Vmin deg clss Ze) where parseG = empty
+
+
+instance ( ParseG (Base_SD (VDom deg) DomClass n)
+         , ParseG (Min5 deg clss n)
+         ) => ParseG (Base_SD deg clss (Su n)) where
+  parseG =     Base_SD      <$> parseG
+           <|> Cons_Vdom <$> parseG <*> parseG
+  
+-- Ad-hoc cases for Base_Vmin
+instance ( ParseG (Base_SD (VMin deg) MinClass n)
+         , ParseG (TritMinVSub    deg        DomClass)
+         ) => ParseG (Base_Vmin deg DomClass (Su n)) where
+  parseG =     Base_Vmin <$> parseG
+           <|> Cons_Vmin      <$> parseG <*> parseG
+
+instance ( ParseG (TritMinVSub deg         clss)
+         ) => ParseG (Base_Vmin deg clss (Su n)) where
+  parseG =     Base_Vmin <$> parseG
+
+
+-- Ad-hoc cases for Base_Final
+instance ParseG (Base_Final deg clss Ze) where parseG = empty
+
+instance ( ParseG (Final deg clss)
+         ) => ParseG (Base_Final deg clss (Su n)) where
+  parseG =     Base_Final  <$> parseG
+  
+instance ( ToDegree deg
+         , ParseG (Final   deg           DomClass)
+         , ParseG (Base_Final (Tritone deg) DomClass n)
+         , ParseG (Base_Final (Tritone deg) DimClass n)
+         ) => ParseG (Base_Final deg DomClass (Su n)) where
+  parseG =     Base_Final     <$> parseG
+           <|> Final_Tritone  <$> parseG
+           <|> Final_Dim_Trit <$> parseG
+    where deg = toDegree (undefined :: deg)  
+-- for dim chors    
+instance ParseG (Surface_Chord deg clss Ze) where parseG = empty
+
+instance ( ToDegree deg 
+         , ParseG (Surface_Chord (MinThird deg) DimClass n)
+         ) => ParseG (Surface_Chord deg DimClass (Su n)) where
+  parseG =     Dim_Chord_Trns <$> parseG
+           <|> pChord deg DimClass
+    where deg = toDegree (undefined :: deg)  
+  
+-- all chords
+instance ( ToDegree deg, ToClass clss
+         ) => ParseG (Surface_Chord deg clss (Su n)) where
+  parseG = pChord deg clss
+    where deg = toDegree (undefined :: deg)
+          clss = toClass (undefined :: clss)
+
+pChord :: Degree -> ClassType -> PMusic (Surface_Chord deg clss (Su n))
+pChord deg clss = transform <$> 
+                    pSym (recognize, "ChordDegree", 
+                          Chord deg (Just (head classes)) [] "inserted" 1) where
+  recognize (Chord deg' (Just shrt) _ _ _) = deg == deg' && shrt `elem` classes
+  recognize (Chord deg' Nothing     _ _ _) = False -- deg == deg'
+                                             -- It seems that we can't use 
+                                             -- deg == deg' above, as we get
+                                             -- "ambiguous parser?" for some
+                                             -- sequences, e.g.
+                                             -- C:6 Bb:9 A:7 D:9 G:maj C: G:7 C:6
+  classes = case clss of
+              MajClass -> [Maj,Maj7,Maj6,Maj9,MinMaj7,Sus4]
+              MinClass -> [Min,Min7,Min6,Min9,HDim7]
+              DomClass -> [Sev,Nin,Aug]
+              DimClass -> [Dim,Dim7]
+  transform (Chord d s _ o n) = 
+    Surface_Chord d [(Class clss (maybe (head classes) id s),t) | t <- words o ]
+
+--------------------------------------------------------------------------------
+-- The non-generic part of the pretty-printer
+--------------------------------------------------------------------------------
+
+-- Ad-hoc cases for Base_SD
+instance ShowChord (Base_SD deg clss Ze) where
+  showChord _ = error "showChord: impossible?"
+  
+instance ( ShowChord (Min5    deg               clss     n)
+         , ShowChord (Base_SD (VDom deg)        DomClass n)
+         , ToDegree  (Tritone deg) -- can this go?
+         ) => ShowChord (Base_SD deg clss (Su n)) where
+  showChord (Base_SD s)        = showChord s
+  showChord (Cons_Vdom s d) = relVPrint "V" s d 0
+  
+
+-- Ad-hoc cases for Base_Vmin  
+instance ShowChord (Base_Vmin deg clss Ze) where
+  showChord _ = error "showChord: impossible?"
+
+instance ( ShowChord (Base_SD (VMin deg)  MinClass n)
+         , ShowChord (TritMinVSub deg        DomClass)
+         ) => ShowChord (Base_Vmin deg clss (Su n)) where
+  showChord (Base_Vmin d) = showChord d
+  -- pattern match into the SD to see if we are our target degree
+  -- is tritone substituted, if so, we "tritone-unsubstitute"
+  showChord (Cons_Vmin    s d@(Final_Tritone  _)) = relVPrint "v" s d 1
+  showChord (Cons_Vmin    s d@(Final_Dim_Trit _)) = relVPrint "v" s d 1
+  showChord (Cons_Vmin    s d                   ) = relVPrint "v" s d 0
+  
+-- Ad-hoc cases for Base_Final
+instance ShowChord (Base_Final deg clss Ze) where
+  showChord _ = error "showChord: impossible?"
+
+instance ( GetDegree (Base_Final (Tritone deg) DomClass n)
+         , GetDegree (Base_Final (Tritone deg) DimClass n)
+         , ShowChord (Final deg clss)
+         , ShowChord (Base_Final (Tritone deg)  DomClass n)
+         , ShowChord (Base_Final (Tritone deg)  DimClass n)
+         ) => ShowChord (Base_Final deg clss (Su n)) where
+  showChord (Base_Final d)  = showChord d
+  -- The tritone substitution of a relative V is as alsway one semitone above
+  -- the chord it is preceding
+  showChord (Final_Tritone  d)  = transPrint "IIb7/"   d 11 
+  showChord (Final_Dim_Trit d)  = transPrint "IIb7b9/" d 11 
+
+-- dim base case
+instance ShowChord (Surface_Chord deg clss Ze) where
+  showChord _ = error "showChord: impossible?"
+
+instance ( ShowChord (Surface_Chord deg clss n) 
+         , ShowChord (Surface_Chord (MinThird deg) DimClass n) 
+         , GetDegree (Surface_Chord (MinThird deg) DimClass n)
+         ) => ShowChord (Surface_Chord deg clss (Su n)) where
+  showChord (Surface_Chord d rs) = foldr (.) id
+     [ paren (shows d . shows r . paren (showString s)) | (r,s) <- rs ]       
+  showChord (Dim_Chord_Trns d) = paren $ toDegVal d 9 . showChar '0' . showChord d
+  
+--------------------------------------------------------------------------------
+-- Value level computation for pretty printing
+--------------------------------------------------------------------------------   
+
+-- prints a secondary dominance structure, i.e. X/Y where X and Y are scaledegrees
+relVPrint :: (GetDegree a, ShowChord b, ShowChord a) =>
+             String -> b -> a -> Int -> ShowS
+relVPrint prfx s d trans =
+  paren (showString prfx . showChar '/' . toDegVal d trans . showChord  s)
+  . showChord d 
+--  paren (toDegVal d 7 
+--  . paren (showString prfx . showChar '/' . toDegVal d trans . showChord  s))
+--  . showChord d  
+
+-- prints a single scale degree transformation  
+transPrint :: (GetDegree a, ShowChord a) =>
+              String -> a -> Int -> ShowS
+transPrint prfx d trans =
+  paren $ showString prfx. toDegVal d trans . showChord d
+  
+  
+-- This function retuns a value level description of a degree using getDegree. 
+-- Certain visualizations demand an addiional scale degree tranposition. The 
+-- addTrans integer value can be used for that (use 0 for no transposition)
+toDegVal :: (GetDegree a) => a -> Int -> ShowS  
+toDegVal deg addTrans = case getDeg deg of 
+  (deg, trans) -> shows $ transposeSem deg (trans + addTrans) 
+
+
+-- Given a degree getDegee ensures that all information about the internal
+-- structure of a scale degree, i.e. the degree and the an int value representing
+-- the transposition of that degree at the current level, is available.
+class GetDegree a where
+  getDeg :: a -> (Degree, Int) 
+  
+instance GetDegree (Base_Vmin deg clss n) where
+  getDeg (Base_Vmin d) = getDeg d
+  getDeg (Cons_Vmin _ d)    = second (+5) (getDeg d)
+
+instance ( GetDegree (Base_Final deg clss Ze)) where 
+  getDeg = error "getDegree: impossible?"
+instance ( GetDegree (Final deg clss)
+         , GetDegree (Base_Final (Tritone deg)  DomClass n)
+         , GetDegree (Base_Final (Tritone deg)  DimClass n)
+         ) => GetDegree (Base_Final deg clss (Su n)) where
+  getDeg (Base_Final d)  = getDeg d
+  -- The tritone substitution of a relative V is as alsway one semitone above
+  -- the chord it is preceding
+  getDeg (Final_Tritone  d)  = second (+6) (getDeg d)
+  getDeg (Final_Dim_Trit d)  = second (+6) (getDeg d)
+  
+instance ( GetDegree (Surface_Chord deg clss Ze)) where 
+  getDeg = error "getDegree: impossible?"
+  
+instance ( GetDegree (Surface_Chord deg clss n)
+         , GetDegree (Surface_Chord (MinThird deg) DimClass n)
+         ) => GetDegree (Surface_Chord deg clss (Su n)) where
+  getDeg (Surface_Chord d _) = (d,0) 
+  getDeg (Dim_Chord_Trns d  ) = second (+9) (getDeg d)
+
+--------------------------------------------------------------------------------
+-- Value Level Scale Degree Transposition
+-------------------------------------------------------------------------------- 
+
+-- transposes a degree with sem semitones
+transposeSem :: Degree -> Int -> Degree
+transposeSem deg sem = semiToDia!((sem + (diaToSemi deg)) `mod` 12)
+
+-- gives the semitone value [0,11] of a Degree, e.g. F# = 6
+diaToSemi :: Degree -> Int
+diaToSemi (Degree m dia) = (diaToSemi'!dia) + (modToSemi m)
+
+-- transforms type-level modifiers to semitones (Int values)
+modToSemi :: Maybe Modifier -> Int
+modToSemi  Nothing  =  0
+modToSemi (Just Sh) =  1
+modToSemi (Just Fl) = -1
+modToSemi (Just SS) =  2
+modToSemi (Just FF) = -2
+
+-- mapping diatonic intervals to semitones 
+diaToSemi' :: Array Interval Int
+diaToSemi' = listArray (1,7) [0,2,4,5,7,9,11]
+
+-- mapping semitones to diatonic Degrees
+-- TODO: what about pitch spelling...?
+semiToDia  :: Array Int Degree
+semiToDia  = listArray (0,11)
+  [ Degree  Nothing  1 -- 0 C
+  , Degree (Just Fl) 2 -- 1 Db
+  , Degree  Nothing  2 -- 2 D
+  , Degree (Just Fl) 3 -- 3 Eb
+  , Degree  Nothing  3 -- 4 E
+  , Degree  Nothing  4 -- 5 F
+  , Degree (Just Sh) 4 -- 6 F#
+  , Degree  Nothing  5 -- 7 G
+  , Degree (Just Fl) 6 -- 8 Ab
+  , Degree  Nothing  6 -- 9 A
+  , Degree (Just Fl) 7 -- 10 Bb
+  , Degree  Nothing  7 -- 11 B
+  ]
+  
+
+--------------------------------------------------------------------------------
+-- The non-generic part of the diff
+--------------------------------------------------------------------------------
+
+instance Children (Base_SD deg clss Ze) where children _ = []
+
+instance ( GDiff (Base_SD (VDom deg) DomClass n)
+         , GDiff (Min5 deg clss n)
+         ) => Children (Base_SD deg clss (Su n)) where
+  children (Base_SD x) = [Ex x]
+  children (Cons_Vdom x y) = [Ex x, Ex y]
+
+
+instance Children (Base_Vmin deg clss Ze) where children _ = []
+
+instance ({- -- for ghc-6.12 
+           Typeable (MinThird (MinThird (MinThird (MinThird (Tritone deg))))),
+           Typeable (MinThird (MinThird (MinThird (Tritone deg)))),
+           Typeable (MinThird (MinThird (Tritone deg))),
+           Typeable (MinThird (Tritone deg)),
+           Typeable (Tritone (Tritone deg)),
+           Typeable (Tritone deg),
+           Typeable deg,
+         -}
+           GDiff (Base_SD (VMin deg)  MinClass n)
+         , GDiff (TritMinVSub deg DomClass)
+         ) => Children (Base_Vmin deg DomClass (Su n)) where
+  children (Base_Vmin x) = [Ex x]
+  children (Cons_Vmin x y) = [Ex x, Ex y]
+
+instance ( Typeable deg, Typeable clss, GDiff (TritMinVSub deg clss)
+         ) => Children (Base_Vmin deg clss (Su n)) where
+  children (Base_Vmin x) = [Ex x]
+
+
+instance Children (Base_Final deg clss Ze) where children _ = []
+
+instance ( GDiff (Base_Final (Tritone deg) DomClass n)
+         , GDiff (Base_Final (Tritone deg) DimClass n)
+         , GDiff (Final      deg           DomClass), Typeable deg
+         ) => Children (Base_Final deg DomClass (Su n)) where
+  children (Base_Final x) = [Ex x]
+  children (Final_Tritone x) = [Ex x]
+  children (Final_Dim_Trit x) = [Ex x]
+
+instance (Typeable deg, Typeable clss, GDiff (Final deg clss)) 
+    => Children (Base_Final deg clss (Su n)) where
+  children (Base_Final x) = [Ex x]
+
+instance Children (Surface_Chord deg clss Ze) where children _ = []
+
+instance Children (Surface_Chord deg clss (Su n)) where
+  children (Surface_Chord d ((c,_):_)) = [Ex d, Ex c]
+
+instance (GDiff (Surface_Chord (MinThird deg) DimClass n))
+    => Children (Surface_Chord deg DimClass (Su n)) where
+  children (Surface_Chord d ((c,_):_)) = [Ex d, Ex c]
+  children (Dim_Chord_Trns x) = [Ex x]
+
+--------------------------------------------------------------------------------
+
+instance Build (Base_SD deg clss Ze) where build _ _ = Nothing
+
+instance ( Typeable n, Typeable (VDom deg), Typeable deg, Typeable clss
+         , GDiff (Base_SD (VDom deg) DomClass n)
+         , GDiff (Min5 deg clss n)
+         ) => Build (Base_SD deg clss (Su n)) where
+  build (Base_SD _) ((Ex x):r) = cast x >>= Just . (flip (,) r) . Base_SD
+  build (Cons_Vdom _ _) ((Ex x):(Ex y):r) = do x' <- cast x
+                                               y' <- cast y
+                                               Just (Cons_Vdom x' y', r)
+  build _ _ = Nothing
+
+
+instance Build (Base_Vmin deg clss Ze) where build _ _ = Nothing
+
+instance ( Typeable n, Typeable (VMin deg), Typeable deg
+         , GDiff (Base_SD (VMin deg) MinClass n)
+         , GDiff (TritMinVSub    deg        DomClass)
+         ) => Build (Base_Vmin deg DomClass (Su n)) where
+  build (Base_Vmin _) ((Ex x):r) = cast x >>= Just . (flip (,) r) . Base_Vmin
+  build (Cons_Vmin _ _) ((Ex x):(Ex y):r) = do x' <- cast x
+                                               y' <- cast y
+                                               Just (Cons_Vmin x' y', r)
+
+instance ( Typeable deg, Typeable clss, GDiff (TritMinVSub deg clss)
+         ) => Build (Base_Vmin deg clss (Su n)) where
+  build (Base_Vmin _) ((Ex x):r) = cast x >>= Just . (flip (,) r) . Base_Vmin
+
+
+instance Build (Base_Final deg clss Ze) where build _ _ = Nothing
+
+instance ( Typeable n, Typeable (Tritone deg), Typeable deg
+         , GDiff (Base_Final (Tritone deg) DomClass n)
+         , GDiff (Base_Final (Tritone deg) DimClass n)
+         , GDiff (Final      deg           DomClass)
+         ) => Build (Base_Final deg DomClass (Su n)) where
+  build (Base_Final _) ((Ex x):r) = cast x >>= Just . (flip (,) r) . Base_Final
+  build (Final_Tritone _) ((Ex x):r) = cast x >>= Just . (flip (,) r) . Final_Tritone
+  build (Final_Dim_Trit _) ((Ex x):r) = cast x >>= Just . (flip (,) r) . Final_Dim_Trit
+
+instance (Typeable deg, Typeable clss) 
+    => Build (Base_Final deg clss (Su n)) where
+  build (Base_Final _) ((Ex x):r) = cast x >>= Just . (flip (,) r) . Base_Final
+
+
+instance Build (Surface_Chord den clss Ze) where build _ _ = Nothing
+
+instance Build (Surface_Chord den clss (Su n)) where
+  build (Surface_Chord _ ((_,s):r)) ((Ex x):(Ex y):rs) = 
+    do x' <- cast x
+       y' <- cast y
+       Just (Surface_Chord x' ((y',s):r),rs)
+
+instance (Typeable (MinThird den), Typeable n)
+    => Build (Surface_Chord den DimClass (Su n)) where
+  build (Dim_Chord_Trns _) ((Ex x):r) = cast x >>= Just . (flip (,) r) . Dim_Chord_Trns
+  build (Surface_Chord _ ((_,s):r)) ((Ex x):(Ex y):rs) = 
+    do x' <- cast x
+       y' <- cast y
+       Just (Surface_Chord x' ((y',s):r),rs)
+
+--------------------------------------------------------------------------------
+
+instance SEq (Base_SD deg clss Ze) where shallowEq _ _ = False -- ?
+
+instance ( GDiff (Base_SD (VDom deg) DomClass n)
+         , GDiff (Min5 deg clss n)
+         ) => SEq (Base_SD deg clss (Su n)) where
+  shallowEq (Base_SD _) (Base_SD _) = True
+  shallowEq (Cons_Vdom _ _) (Cons_Vdom _ _) = True
+  shallowEq _ _ = False
+
+
+instance SEq (Base_Vmin deg clss Ze) where shallowEq _ _ = False
+
+instance ( GDiff (Base_SD     (VMin deg) MinClass n)
+         , GDiff (TritMinVSub deg        DomClass)
+         ) => SEq (Base_Vmin deg DomClass (Su n)) where
+  shallowEq (Base_Vmin _) (Base_Vmin _) = True
+  shallowEq (Cons_Vmin _ _) (Cons_Vmin _ _) = True
+  shallowEq _ _ = False
+
+instance ( GDiff (TritMinVSub deg         clss)
+         ) => SEq (Base_Vmin deg clss (Su n)) where
+  shallowEq (Base_Vmin _) (Base_Vmin _) = True
+  shallowEq _ _ = False
+
+
+instance SEq (Base_Final deg clss Ze) where shallowEq _ _ = False
+
+instance ( GDiff (Base_Final (Tritone deg) DomClass n)
+         , GDiff (Base_Final (Tritone deg) DimClass n)
+         , GDiff (Final      deg           DomClass)
+         ) => SEq (Base_Final deg DomClass (Su n)) where
+  shallowEq (Base_Final _) (Base_Final _) = True
+  shallowEq (Final_Tritone _) (Final_Tritone _) = True
+  shallowEq (Final_Dim_Trit _) (Final_Dim_Trit _) = True
+  shallowEq _ _ = False
+
+instance (SEq (Final deg clss)) => SEq (Base_Final deg clss (Su n)) where
+  shallowEq (Base_Final _) (Base_Final _) = True
+  shallowEq _ _ = False
+
+
+instance SEq (Surface_Chord deg clss Ze) where shallowEq _ _ = False
+
+instance SEq (Surface_Chord deg clss (Su n)) where
+  shallowEq (Surface_Chord _ _) (Surface_Chord _ _) = True
+  shallowEq _ _ = False
+
+instance SEq (Surface_Chord deg DimClass (Su n)) where
+  shallowEq (Dim_Chord_Trns _) (Dim_Chord_Trns _) = True
+  shallowEq (Surface_Chord _ _) (Surface_Chord _ _) = True
+  shallowEq _ _ = False
+
+
+--------------------------------------------------------------------------------
+
+instance (Typeable deg, Typeable clss) => 
+  GDiff (Base_SD deg clss Ze)
+
+instance ( Typeable deg, Typeable clss, Typeable n, Typeable (VDom deg)
+         , GDiff (Base_SD (VDom deg) DomClass n)
+         , GDiff (Min5 deg clss n)
+         ) => GDiff (Base_SD deg clss (Su n))
+
+
+instance (Typeable deg, Typeable clss)
+  => GDiff (Base_Vmin deg clss Ze)
+
+instance ({- -- for ghc-6.12
+           Typeable (MinThird (MinThird (MinThird (MinThird (Tritone deg))))),
+           Typeable (MinThird (MinThird (MinThird (Tritone deg)))),
+           Typeable (MinThird (MinThird (Tritone deg))),
+           Typeable (MinThird (Tritone deg)),
+           Typeable (Tritone (Tritone deg)),
+           Typeable (Tritone deg),
+          -}
+           Typeable (VMin deg), Typeable deg, Typeable n
+         , GDiff (Base_SD (VMin deg) MinClass n)
+         , GDiff (TritMinVSub    deg        DomClass)
+         ) => GDiff (Base_Vmin deg DomClass (Su n))
+
+instance ( Typeable deg, Typeable clss, Typeable n
+         , GDiff (TritMinVSub deg         clss)
+         ) => GDiff (Base_Vmin deg clss (Su n))
+
+
+instance (Typeable deg, Typeable clss)
+  => GDiff (Base_Final deg clss Ze)
+
+instance ( Typeable deg, Typeable n, Typeable (Tritone deg)
+         , GDiff (Base_Final (Tritone deg) DomClass n)
+         , GDiff (Base_Final (Tritone deg) DimClass n)
+         , GDiff (Final      deg           DomClass)
+         ) => GDiff (Base_Final deg DomClass (Su n))
+
+instance (Typeable deg, Typeable clss, Typeable n, GDiff (Final deg clss)) 
+  => GDiff (Base_Final deg clss (Su n))
+
+
+instance (Typeable deg, Typeable clss)
+  => GDiff (Surface_Chord deg clss Ze)
+
+instance (Typeable deg, Typeable clss, Typeable n)
+  => GDiff (Surface_Chord deg clss (Su n))
+
+instance ( Typeable deg, Typeable n, Typeable (MinThird deg)
+         , GDiff (Surface_Chord (MinThird deg) DimClass n)
+         )
+  => GDiff (Surface_Chord deg DimClass (Su n))
+--------------------------------------------------------------------------------
+
+instance Children Class where children _ = []
+instance Build Class where build c r = Just (c,r)
+instance SEq Class where shallowEq _ _ = True
+instance GDiff Class
+
+instance Children Degree where children _ = []
+instance Build Degree where build c r = Just (c,r)
+instance SEq Degree where shallowEq _ _ = True
+instance GDiff Degree
+
+--------------------------------------------------------------------------------
+-- ChordDegree as tokens
+--------------------------------------------------------------------------------
+
+instance IsLocationUpdatedBy (Int, Int) ChordDegree where
+  advance (line,pos) _ = (line,pos+1)
diff --git a/MIR/Matching/GDiff.hs b/MIR/Matching/GDiff.hs
new file mode 100644
--- /dev/null
+++ b/MIR/Matching/GDiff.hs
@@ -0,0 +1,4 @@
+
+module MIR.Matching.GDiff (module Generics.Instant.GDiff) where
+
+import Generics.Instant.GDiff
diff --git a/MIR/Matching/Standard.hs b/MIR/Matching/Standard.hs
new file mode 100644
--- /dev/null
+++ b/MIR/Matching/Standard.hs
@@ -0,0 +1,15 @@
+
+module MIR.Matching.Standard where
+
+import Data.Algorithm.Diff -- cabal install Diff
+
+diff :: (Eq a) => [a] -> [a] -> [(DI,a)]
+diff = getDiff
+
+diffLen :: (Eq a) => [a] -> [a] -> Float
+diffLen x y = fromIntegral (len (diff x y)) / fromIntegral (length x)
+
+len :: [(DI,a)] -> Int
+len []        = 0
+len ((B,_):t) = len t
+len ((_,_):t) = 1 + len t
diff --git a/MIR/Run.hs b/MIR/Run.hs
new file mode 100644
--- /dev/null
+++ b/MIR/Run.hs
@@ -0,0 +1,249 @@
+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- Testing
+module MIR.Run 
+  ( readFile', parseTree, testDir,  string2PieceC
+  , diffPiece, diffChords, diffChordsLen, diffPieceLen, showFloat
+  , getId, getTitle, getDb, readDataDir, writeGroundTruth
+  , createGroundTruth, getClassSizes, showErrors, errorRatio
+  ) where
+
+-- Parser stuff
+import Text.ParserCombinators.UU
+import Text.ParserCombinators.UU.BasicInstances hiding (head)
+import Text.ParserCombinators.UU.BasicInstances.List
+
+-- Music stuff
+import MIR.HarmGram.ParserChord
+import MIR.HarmGram.ShowChord
+--import EnumChord
+import MIR.HarmGram.MIR
+import MIR.HarmGram.Tokenizer
+import qualified MIR.Matching.GDiff as GD
+import qualified MIR.Matching.Standard as STDiff
+import MIR.GeneratedInstances.GeneratedInstances ()
+--import MIR.Instances ()
+import Text.Regex.TDFA
+
+-- Library modules
+import System.Console.ParseArgs hiding (args) -- cabal install parseargs
+import Control.Monad (when)
+import Data.List (intersperse, sort, groupBy, genericLength)
+import Control.Arrow ((***))
+import System.FilePath
+import System.Directory
+import System.IO
+import System.CPUTime
+-- import qualified Data.HashTable as HT
+
+
+--------------------------------------------------------------------------------
+-- From tokens to structured music pieces
+--------------------------------------------------------------------------------
+
+-- Piece needs to be adhoc so that we do not use 'amb'
+{-
+instance ParseG Piece where
+  parseG = Piece <$> parseG <|> Piece_min <$> parseG <|> Piece_bls <$> parseG
+
+instance ShowChord Piece where
+  showChord (Piece     l) = paren (showString "P"    . showChord l)
+  showChord (Piece_min l) = paren (showString "PMin" . showChord l)
+  showChord (Piece_bls l) = paren (showString "PBls" . showChord l)
+-}
+
+
+-- parsePiece :: PMusic [Piece]
+{-
+parsePiece = fmap (:[]) $     Piece     <$> parseG 
+                          <|> Piece_min <$> parseG
+                          <|> Piece_bls <$> parseG
+-}
+-- parsePiece = amb (parseG :: PMusic Piece)
+-- parsePiece = fmap ((:[]) . head) $ amb (parseG :: PMusic Piece)
+
+pMajOrMin :: ChordName -> PMusic [Piece]
+pMajOrMin (Chord C (Just Maj) _ _ _) = map Piece     <$> amb parseG
+pMajOrMin (Chord C (Just Min) _ _ _) = map Piece_min <$> amb parseG
+pMajOrMin _                          = error "Parser: key must be C:Maj or C:min"
+
+--------------------------------------------------------------------------------
+-- Plugging everything together
+--------------------------------------------------------------------------------
+
+instance Show Piece where show x = showChord x ""
+
+-- Takes a string with line-separated chords of a song in C and
+-- returns all possible parsed pieces, together with error-correction steps
+-- taken (on tokenizing and on musical recognition).
+string2PieceC :: String -> ([ChordName],[Piece],[Error (Int, Int)],[Error (Int, Int)])
+string2PieceC s = let (PieceToken k a,err) = parse ((,) <$> parseSong <*> pEnd)
+                                      (createStr s (0,0))
+                      b = mergeDups (map relativizeC a)
+                      (c,err2) = parse_h ((,) <$> pMajOrMin k <*> pEnd) 
+                                      (createStr b (0,0))
+                  in (a, c, err, err2)
+
+--------------------------------------------------------------------------------
+-- Matching
+--------------------------------------------------------------------------------
+
+diffPiece :: Piece -> Piece -> String
+diffPiece x y = show (GD.diff x y)
+
+diffPieceLen :: Maybe Float -> Float -> Float -> Piece -> Piece -> Float
+diffPieceLen Nothing   _  _  x y = GD.diffLen x y
+diffPieceLen (Just et) ex ey x y = GD.diffLen x y
+                                 -- Error penalty
+                                 + if (GD.diffLen x y > 0)
+                                   then et * (ex + ey) else 0
+
+diffChordsLen :: Maybe Float -> Float -> Float -> [ChordName] -> [ChordName]
+              -> Float
+diffChordsLen _ _ _ = STDiff.diffLen
+
+diffChords :: [ChordName] -> [ChordName] -> String
+diffChords x y = show (STDiff.diff x y)
+
+
+--------------------------------------------------------------------------------
+-- Data set Info
+--------------------------------------------------------------------------------
+biabPat :: String
+biabPat = "^(.*)_id_([0-9]{5})_(allanah|wdick|community|midicons|realbook).(M|S|m|s)(G|g)[0-9A-Za-z]{1}.txt$"     
+    
+getInfo :: String -> Maybe [String]     
+getInfo fileName = 
+  do let 
+     (_,_,_,groups) <- fileName =~~ biabPat :: Maybe (String,String,String,[String])
+     return groups
+
+getTitle, getId, getDb :: String -> String
+getTitle fn = getInfo' 0 fn     
+getId fn    = getInfo' 1 fn
+getDb fn    = getInfo' 2 fn
+    
+getInfo' :: Int -> String -> String    
+getInfo' i fn = maybe "no_info" (!!i) (getInfo fn)
+                    
+createGroundTruth :: [String] -> [(String, String)]
+createGroundTruth files = [ (getTitle x, getId x) | x <- files ]
+
+getClassSizes :: [String] -> [(String,[String])]
+getClassSizes = map ((head *** id) . unzip) . groupBy gf . createGroundTruth
+  where gf (name1, _key1) (name2, _key2) = name1 == name2
+
+writeGroundTruth :: [FilePath] -> FilePath -> IO ()
+writeGroundTruth files outfp =
+  writeFile outfp . Prelude.tail $ concatMap merge (createGroundTruth files) 
+     where merge :: (String, String) -> String
+           -- merge = uncurry (++) . second ((:) '\t') . first ((:) '\n')
+           merge (x,y) = '\n' : y ++ "\t" ++ x
+  
+    
+
+--------------------------------------------------------------------------------
+-- Testing
+-------------------------------------------------------------------------------- 
+
+-- parses a string of chords s and returns a parse tree with the harmony structure
+parseTree :: String -> IO ()
+parseTree s = do let (toks, ps, err1, err2) = string2PieceC s -- we hardcode C for now
+                 putStrLn "\nTokenizer output:"
+                 mapM_ print toks
+                 putStrLn "\nCorrection steps (tokenizer):"
+                 show_errors err1
+                 putStrLn "\nCorrection steps (music recognizer):"
+                 show_errors err2
+                 putStrLn (show (length ps) ++ " possible outputs:")
+                 mapM_ print (take 10 ps)
+
+-- Batch analyzing a directory with chord sequence files with reduced output.
+testDir :: FilePath -> IO ()
+testDir filepath = getDirectoryContents filepath >>= process filepath . sort
+
+process :: String -> [String] -> IO ()
+process fp fs = do putStr "Filename\tNumber of trees\t"
+                   putStr "Insertions\tDeletions\tDeletions at the end\t"
+                   putStr "Tot_Correction\tNr_of_chords\t"
+                   putStrLn "Error ratio\tTime taken"
+                   mapM_ (process1 fp) fs where
+  process1 path x = when (takeExtension x == ".txt") $
+    do content <- readFile (path </> x)
+       let (toks, ps, _err1, err2) = string2PieceC content
+           t                       = seq (length (show (head ps))) (return ())
+           ErrorNrs i d e          = countErrors err2
+           errRat                  = errorRatio err2 toks
+           nrOfChords              = length (mergeDups toks)
+       t1 <- getCPUTime
+       t
+       t2 <- getCPUTime
+       let diff = fromIntegral (t2 - t1) / (1000000000 :: Float)
+       mapM_ putStr (intersperse "\t" [ x, show (length ps)
+                                      , show i, show d, show e, show (i+d+e)
+                                      , show nrOfChords, showFloat errRat
+                                      , showFloat diff ++ "\n"])
+
+-- | Shows a Float with three decimal places
+showFloat :: Float -> String
+showFloat =   show . (/ (1000 :: Float)) . fromIntegral 
+            . (round :: Float -> Int) . (* 1000)
+
+data ErrorNrs = ErrorNrs { ins :: Int, del :: Int, delEnd :: Int }
+
+-- datatype for storing the number of different error types
+instance Show ErrorNrs where 
+   show (ErrorNrs i d e) = show i ++ " insertions, " ++ show d 
+        ++ " deletions and " ++ show e ++ " unconsumed tokens"
+
+
+-- Counts the number of insertions and deletions
+countErrors :: [Error (Int,Int)] -> ErrorNrs
+countErrors [] = ErrorNrs 0 0 0
+countErrors ((Inserted _ _ _):t) = inc1 (countErrors t)
+countErrors ((Deleted _ _ _) :t) = inc2 (countErrors t)
+countErrors ((DeletedAtEnd _):t) = inc3 (countErrors t)
+
+simpleErrorMeasure :: ErrorNrs -> Float
+simpleErrorMeasure (ErrorNrs i d e) = fromIntegral (i + d + e)
+
+errorRatio :: (Eq a) => [Error (Int,Int)] -> [Chord a] -> Float
+errorRatio errs toks = simpleErrorMeasure (countErrors errs) /
+                        genericLength (mergeDups toks)
+
+inc1, inc2, inc3 :: ErrorNrs -> ErrorNrs
+inc1 e = e { ins    = ins e + 1 }
+inc2 e = e { del    = del e + 1 }
+inc3 e = e { delEnd = delEnd e + 1 }
+
+-- More concise showing errors, and in IO
+showErrors :: [Error (Int, Int)] -> IO ()
+showErrors l = case countErrors l of
+                 ErrorNrs i d e -> putStrLn (   show i ++ " insertions, " 
+                                      ++ show d ++ " deletions, "
+                                      ++ show e ++ " deletions at the end")
+
+
+--------------------------------------------------------------------------------
+-- Utils
+--------------------------------------------------------------------------------
+
+-- Stricter readFile
+hGetContents' :: Handle -> IO [Char]
+hGetContents' hdl = do e <- hIsEOF hdl
+                       if e then return []
+                         else do c <- hGetChar hdl
+                                 cs <- hGetContents' hdl
+                                 return (c:cs)
+
+readFile' :: FilePath -> IO [Char]
+readFile' fn = do hdl <- openFile fn ReadMode
+                  xs <- hGetContents' hdl
+                  hClose hdl
+                  return xs
+                  
+readDataDir :: FilePath -> IO [FilePath]
+readDataDir fp = 
+  do fs <- getDirectoryContents fp
+     return . sort $ filter (\str -> str =~ biabPat) fs
diff --git a/Text/ParserCombinators/UU.hs b/Text/ParserCombinators/UU.hs
new file mode 100644
--- /dev/null
+++ b/Text/ParserCombinators/UU.hs
@@ -0,0 +1,26 @@
+-- | The non-exported module "Text.ParserCombinators.UU.Examples" contains a list of examples of how to use the main functionality of this library which demonstrates:
+--
+-- * how to write basic parsers
+--
+-- * how to to write ambiguous parsers
+--
+-- * how the error correction works
+--
+-- * how to fine tune your parsers to get rid of ambiguities
+--
+-- * how to use the monadic interface
+--
+-- * what kind of error messages you can get if you write erroneous parsers
+--
+-- * how to use the permutation/merging parsers
+--
+-- * to see the parsers in action load the module "Text.ParserCombinators.UU.Examples" in @ghci@ and type @main@ or @demo_merge@, while looking at the corresponding code
+--
+
+module Text.ParserCombinators.UU ( module Text.ParserCombinators.UU.Core
+                                 , module Text.ParserCombinators.UU.Derived
+) where
+import Text.ParserCombinators.UU.Core
+import Text.ParserCombinators.UU.Derived
+
+
diff --git a/Text/ParserCombinators/UU/BasicInstances.hs b/Text/ParserCombinators/UU/BasicInstances.hs
new file mode 100644
--- /dev/null
+++ b/Text/ParserCombinators/UU/BasicInstances.hs
@@ -0,0 +1,167 @@
+{-# LANGUAGE  RankNTypes, 
+              GADTs,
+              MultiParamTypeClasses,
+              FunctionalDependencies, 
+              FlexibleInstances, 
+              FlexibleContexts, 
+              UndecidableInstances,
+              NoMonomorphismRestriction,
+              TypeSynonymInstances #-}
+
+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+-- %%%%%%%%%%%%% Some Instances        %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+module Text.ParserCombinators.UU.BasicInstances where
+import Text.ParserCombinators.UU.Core
+import Data.Maybe
+import qualified Data.List as L
+import Debug.Trace
+import Prelude hiding (null, head, tail, span)
+
+data Error  pos =    Inserted String pos Strings
+                   | Deleted  String pos Strings
+                   | DeletedAtEnd String
+
+instance (Show pos) => Show (Error  pos) where 
+ show (Inserted s pos expecting) = "-- >    Inserted " ++  s ++ " at position " ++ show pos ++  show_expecting  expecting 
+ show (Deleted  t pos expecting) = "-- >    Deleted  " ++  t ++ " at position " ++ show pos ++  show_expecting  expecting 
+ show (DeletedAtEnd t)           = "-- >    The token " ++ t ++ " was not consumed by the parsing process."
+
+show_errors :: (Show a) => [a] -> IO ()
+show_errors = sequence_ . (map (putStrLn . show))
+
+show_expecting :: [String] -> String
+show_expecting [a]    = " expecting " ++ a
+show_expecting (a:as) = " expecting one of [" ++ a ++ concat (map (", " ++) as) ++ "]"
+show_expecting []     = " expecting nothing"
+
+data Str a s loc = Str { input    :: s
+                       , msgs     :: [Error loc]
+                       , pos      :: loc
+                       , deleteOk :: !Bool}
+
+class Stream s t | s -> t where
+   uncons :: s -> Maybe (t, s)
+   null :: s -> Bool
+   null = isNothing . uncons
+   head :: s -> t
+   head = fst . fromMaybe (error "Cannot get head at end of stream.") . uncons
+   tail :: s -> s
+   tail = snd . fromMaybe (error "Cannot get tail at end of stream.") . uncons
+   span :: (t -> Bool) -> s -> ([t], s)
+   span p s = case uncons s of
+                 Nothing    -> ([], s)
+                 Just (h,t) -> if   p h
+                               then let (a,b) = span p t
+                                    in  (h:a,b)
+                               else ([], s)
+   stripPrefix :: Eq t => [t] -> s -> Maybe s
+   stripPrefix []     s = Just s
+   stripPrefix (x:xs) s = do (h,t) <- uncons s
+                             if h == x
+                              then stripPrefix xs t
+                              else Nothing
+
+instance IsLocationUpdatedBy (Int,Int) Char where
+   advance (line,pos) c = case c of
+                          '\n' ->  (line+1, 0) 
+                          '\t' ->  (line  , pos + 8 - (pos-1) `mod` 8)
+                          _    ->  (line  , pos + 1)
+
+instance IsLocationUpdatedBy loc a => IsLocationUpdatedBy loc [a] where
+   advance  = foldl advance 
+
+instance (Show a,  loc `IsLocationUpdatedBy` a, Stream s a) => Provides  (Str a s loc)  (a -> Bool, String, a)  a where
+       splitState (p, msg, a) k (Str  tts   msgs pos  del_ok) 
+          = show_attempt ("Try Predicate: " ++ msg ++ "\n") (
+            let ins exp =       (5, k a (Str tts (msgs ++ [Inserted (show a)  pos  exp]) pos  False))
+                del exp =       (5, splitState (p,msg, a) 
+                                    k
+                                    (Str (tail tts) 
+                                         (msgs ++ [Deleted  (show(head tts))  pos  exp]) 
+                                         (advance pos (head tts))
+                                         True ))
+            in case uncons tts of
+               Just (t,ts) ->  if p t 
+                               then  show_symbol ("Accepting symbol: " ++ show t ++ " at position: " ++ show pos ++"\n") 
+                                     (Step 1 (k t (Str ts msgs (advance pos t) True)))
+                               else  Fail [msg] (ins: if del_ok then [del] else [])
+               _           ->  Fail [msg] [ins]
+            )
+
+instance (Ord a, Show a, loc `IsLocationUpdatedBy`  a, Stream s a) => Provides  (Str  a s loc)  (a,a)  a where
+       splitState a@(low, high) = splitState (\ t -> low <= t && t <= high, show low ++ ".." ++ show high, low)
+
+instance (Eq a, Show a, loc `IsLocationUpdatedBy`  a, Stream s a) => Provides  (Str  a s loc)  a  a where
+       splitState a  = splitState ((==a), show a, a) 
+
+instance (Show a, Stream s a) => Eof (Str a s loc) where
+       eof (Str  i        _    _    _    )                = null i
+       deleteAtEnd (Str s msgs pos ok )                   = do (i,ii) <- uncons s
+                                                               return (5, Str ii (msgs ++ [DeletedAtEnd (show i)]) pos ok)
+
+
+instance  Stores (Str a s loc) (Error loc) where
+       getErrors   (Str  inp      msgs pos ok    )     = (msgs, Str inp [] pos ok)
+
+instance  HasPosition (Str a s loc) loc where
+       getPos   (Str  inp      msgs pos ok    )        = pos
+
+-- pMunch
+
+data Munch a = Munch (a -> Bool) String
+
+instance (Show a, loc `IsLocationUpdatedBy` [a], Stream s a) => Provides (Str a s loc) (Munch a) [a] where 
+       splitState (Munch p x) k inp@(Str tts msgs pos del_ok)
+          =    show_attempt ("Try Munch: " ++ x ++ "\n") (
+               let (munched, rest) = span p tts
+                   l               = length munched
+               in if l > 0 then show_munch ("Accepting munch: " ++ x ++ " " ++ show munched ++  show pos ++ "\n") 
+                                (Step l (k munched (Str rest msgs (advance pos munched)  (l>0 || del_ok))))
+                           else show_munch ("Accepting munch: " ++ x ++ " as emtty munch " ++ show pos ++ "\n") (k [] inp)
+               )
+
+-- | Parse the longest prefix of tokens obeying the predicate.
+pMunch :: (Provides st (Munch a) [a]) => (a -> Bool) -> P st [a]
+pMunch  p   = pSymExt Zero Nothing  (Munch p "") -- the empty case is handled above
+pMunchL p l = pSymExt Zero Nothing  (Munch p l) -- the empty case is handled above
+
+
+data Token a = Token [a] Int -- the Int value represents the cost for inserting such a token
+
+instance (Show a, Eq a, loc `IsLocationUpdatedBy` a, Stream s a) => Provides (Str a s loc) (Token a) [a] where 
+  splitState tok@(Token  as cost) k (Str tts msgs pos del_ok)
+   =  let l = length as
+          msg = show as 
+      in  show_attempt ("Try Token: " ++ show as ++ "\n") (
+          case stripPrefix as tts of
+          Nothing  ->  let ins exp =  (cost, k as             (Str tts         (msgs ++ [Inserted msg               pos  exp])   pos    False))
+                           del exp =  (5,    splitState tok k (Str (tail tts)  (msgs ++ [Deleted  (show(head tts))  pos  exp])  (advance pos [(head tts)]) True ))
+                       in if null tts then  Fail [msg] [ins]
+                                      else  Fail [msg] (ins: if del_ok then [del] else [])
+          Just rest -> show_tokens ("Accepting token: " ++ show as ++"\n") 
+                       (Step l (k as (Str rest msgs (advance pos as) True)))
+          )
+
+-- | Parse a list of primitive tokens (for example characters).
+pToken :: (Provides state (Token a) token) => [a] -> P state token
+pToken     as   =   pTokenCost as 5
+
+-- | Parse a list of primitive tokens (for example characters) with a certain cost.
+pTokenCost :: (Provides state (Token a) token) => [a] -> Int -> P state token
+pTokenCost as c =   if L.null as then error "call to pToken with empty token"
+                    else pSymExt (length as) Nothing (Token as c)
+                    where length [] = Zero
+                          length (_:as) = Succ (length as)
+
+show_tokens :: String -> b -> b
+show_tokens m v =   {- trace m -}  v
+
+show_munch :: String -> b -> b
+show_munch  m v =   {- trace m -}  v
+
+show_symbol :: String -> b -> b
+show_symbol m v =  {-  trace m -}  v
+
+show_attempt m v = {- trace m -} v
diff --git a/Text/ParserCombinators/UU/BasicInstances/List.hs b/Text/ParserCombinators/UU/BasicInstances/List.hs
new file mode 100644
--- /dev/null
+++ b/Text/ParserCombinators/UU/BasicInstances/List.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE  FlexibleInstances,
+              MultiParamTypeClasses,
+              FlexibleContexts,
+              RankNTypes #-}
+
+module Text.ParserCombinators.UU.BasicInstances.List (
+   Parser,
+   createStr,
+   
+   -- From BasicInstances
+   pToken,
+   pTokenCost,
+   pMunch,
+   show_errors,
+   show_expecting
+   ) where
+
+import Text.ParserCombinators.UU.BasicInstances
+import Text.ParserCombinators.UU.Core
+import qualified Data.List as L
+
+instance Stream [a] a where
+   uncons (x:xs) = Just (x, xs)
+   uncons _      = Nothing
+   null          = L.null
+   head          = L.head
+   tail          = L.tail
+   span          = L.span
+   stripPrefix   = L.stripPrefix
+
+-- | Abstract type of a parser with input stream @a@, return type @b@ and location representation @c@.
+-- Can be @Parser String Char (Int, Int)@ for example
+type Parser a b c = Stream a d => P (Str d a c) b
+-- type Parser a b c = P (Str a [a] c) b
+
+-- | @`createStr`@ creates a @`Str`@ state from a list and a location representation.
+createStr :: Stream [t] t => [t] -> loc -> Str t [t] loc
+createStr ls initloc = Str ls [] initloc True
diff --git a/Text/ParserCombinators/UU/BasicInstances/String.hs b/Text/ParserCombinators/UU/BasicInstances/String.hs
new file mode 100644
--- /dev/null
+++ b/Text/ParserCombinators/UU/BasicInstances/String.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE  FlexibleContexts,
+              RankNTypes #-}
+
+module Text.ParserCombinators.UU.BasicInstances.String (
+   Parser,
+   createStr,
+   
+   -- From BasicInstances
+   pToken,
+   pTokenCost,
+   pMunch,
+   show_errors,
+   show_expecting
+   ) where
+
+import Text.ParserCombinators.UU.Core
+import Text.ParserCombinators.UU.BasicInstances
+import qualified Text.ParserCombinators.UU.BasicInstances.List as BL
+
+-- | Basic type of a parser with returntype @a@.
+type Parser a = P (Str Char String (Int, Int)) a
+
+-- | @`createStr`@ creates a @`Str`@ state from a @String@.
+createStr :: String -> Str Char String (Int, Int)
+createStr ls = BL.createStr ls (0,0)
diff --git a/Text/ParserCombinators/UU/Core.hs b/Text/ParserCombinators/UU/Core.hs
new file mode 100644
--- /dev/null
+++ b/Text/ParserCombinators/UU/Core.hs
@@ -0,0 +1,600 @@
+{-# LANGUAGE  RankNTypes, 
+              GADTs,
+              MultiParamTypeClasses,
+              FunctionalDependencies #-}
+
+-- | The module `Core` contains the basic functionality of the parser library. 
+--   It  uses the  breadth-first module  to realise online generation of results, the error
+--   correction administration, dealing with ambigous grammars; it defines the types  of the elementary  parsers
+--   and  recognisers involved.For typical use cases of the libray see the module @"Text.ParserCombinators.UU.Examples"@
+
+module Text.ParserCombinators.UU.Core ( module Text.ParserCombinators.UU.Core
+                                      , module Control.Applicative) where
+import Control.Applicative  hiding  (many, some, optional)
+import Data.Char
+import Debug.Trace
+import Data.Maybe
+
+
+infix   2  <?>    -- should be the last element in a sequence of alternatives
+infixl  3  <<|>   -- intended use p <<|> q <<|> r <|> x <|> y <?> z
+infixl  3  <-|->  -- an alternative for <|> which does not compare the lengths, to be used in permutation parsers
+
+-- ** `Provides'
+
+-- | The function `splitState` playes a crucial role in splitting up the state. 
+--   The `symbol` parameter tells us what kind of thing, and even which value of that kind, is expected from the input.
+--   The state  and  and the symbol type together determine what kind of token has to be returned. Since the function is overloaded we do not have to invent 
+--   all kind of different names for our elementary parsers.
+class  Provides state symbol token | state symbol -> token  where
+       splitState   ::  symbol -> (token -> state  -> Steps a) -> state -> Steps a
+
+-- ** `Eof'
+
+class Eof state where
+       eof          ::  state   -> Bool
+       deleteAtEnd  ::  state   -> Maybe (Cost, state)
+
+-- ** `Location` 
+-- | The input state may contain a location which can be used in error messages. Since we do not want to fix our input to be just a @String@ we provide an interface
+--   which can be used to advance the location by passing its information in the function splitState
+
+class Show loc => loc `IsLocationUpdatedBy` str where
+    advance::loc -> str -> loc
+
+--  ** An extension to @`Alternative`@ which indicates a biased choice
+-- | In order to be able to describe greedy parsers we introduce an extra operator, whch indicates a biased choice
+class (Alternative p) => ExtAlternative p where
+  (<<|>)  :: p a -> p a -> p a
+  (<-|->) :: p a -> p a -> p a
+  (<-|->) = (<|>)
+     
+
+-- * The  triples containg a  history, a future parser and a recogniser: @`T`@
+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+-- %%%%%%%%%%%%% Triples     %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+-- actual parsers
+data T st a  = T  (forall r . (a  -> st -> Steps r)  -> st -> Steps       r  ) --  history parser
+                  (forall r . (      st -> Steps r)  -> st -> Steps   (a, r) ) --  future parser
+                  (forall r . (      st -> Steps r)  -> st -> Steps       r  ) --  recogniser
+
+instance Functor (T st) where
+  fmap f (T ph pf pr) = T  ( \  k -> ph ( k .f ))
+                           ( \  k ->  apply2fst f . pf k) -- pure f <*> pf
+                           pr
+  f <$ (T _ _ pr)     = T  ( pr . ($f)) 
+                           ( \ k st -> push f ( pr k st)) 
+                           pr
+
+-- ** Triples are Applicative:  @`<*>`@,  @`<*`@,  @`*>`@ and  @`pure`@
+instance   Applicative (T  state) where
+  T ph pf pr  <*> ~(T qh qf qr)  =  T ( \  k -> ph (\ pr -> qh (\ qr -> k (pr qr))))
+                                      ((apply .) . (pf .qf))
+                                      ( pr . qr)
+  T ph pf pr  <*  ~(T _  _  qr)   = T ( ph. (qr.))  (pf. qr)   (pr . qr)
+  T _  _  pr  *>  ~(T qh qf qr )  = T ( pr . qh  )  (pr. qf)    (pr . qr)            
+  pure a                          = T ($a) ((push a).) id 
+
+instance   Alternative (T  state) where 
+  T ph pf pr  <|> T qh qf qr  =   T (\  k inp  -> ph k inp `best` qh k inp)
+                                    (\  k inp  -> pf k inp `best` qf k inp)
+                                    (\  k inp  -> pr k inp `best` qr k inp)
+  empty                =  T  ( \  k inp  ->  noAlts) ( \  k inp  ->  noAlts) ( \  k inp  ->  noAlts)
+
+{-
+-- instance ExtAlternative (T st) where 
+-- unfortunatelythis is not possible since we have to make the choice for swapping elsewhere
+-}
+
+
+instance ExtAlternative Maybe where
+  Nothing <<|> r        = r
+  l       <<|> Nothing  = l 
+  l       <<|> r        = l -- choosing the high priority alternative ? is this the right choice?
+
+
+-- * The  descriptor @`P`@ of a parser, including the tupled parser corresponding to this descriptor
+--
+data  P   st  a =  P  (T  st a)         --   actual parsers
+                      (Maybe (T st a))  --   non-empty parsers; Nothing if  they are absent
+                      Nat               --   minimal length
+                      (Maybe a)         --   possibly empty with value 
+
+instance Show (P st a) where
+  show (P _ nt n e) = "P _ " ++ maybe "Nothing" (const "(Just _)") nt ++ " (" ++ show n ++ ") " ++ maybe "Nothing" (const "(Just _)") e
+
+getOneP :: P a b -> Maybe (P a b)
+getOneP (P _ (Just _)  Zero _ )    =  error "The element is a special parser which cannot be combined"
+getOneP (P _ Nothing   l    _ )    =  Nothing
+getOneP (P _ onep      l    ep )   =  Just( P (mkParser onep Nothing)  onep l Nothing)
+
+getZeroP :: P t a -> Maybe (P st a)
+getZeroP (P _ _ l Nothing)         =  Nothing
+getZeroP (P _ _ l pe)              =  Just (P (mkParser Nothing pe) Nothing l pe) -- TODO check for erroneous parsers
+
+mkParser :: Maybe (T st a) -> Maybe a -> T st a
+mkParser np@Nothing   ne@Nothing   =  empty           
+mkParser np@(Just nt) ne@Nothing   =  nt              
+mkParser np@Nothing   ne@(Just a)  =          (pure a)        
+mkParser np@(Just nt) ne@(Just a)  =  (nt <|> pure a) 
+
+-- combine creates the non-empty parser 
+combine :: (Alternative f) => Maybe t1 -> Maybe t2 -> t -> Maybe t3
+        -> (t1 -> t -> f a) -> (t2 -> t3 -> f a) -> Maybe (f a)
+combine Nothing   Nothing  _  _     _   _   = Nothing      -- this Parser always fails
+combine (Just p)  Nothing  aq _     op1 op2 = Just (p `op1` aq) 
+combine (Just p)  (Just v) aq nq    op1 op2 = case nq of
+                                              Just nnq -> Just (p `op1` aq <|> v `op2` nnq)
+                                              Nothing  -> Just (p `op1` aq                ) -- rhs contribution is just from empty alt
+combine Nothing   (Just v) _  nq    _   op2 = case nq of
+                                              Just nnq -> Just (v `op2` nnq)  -- right hand side has non-empty part
+                                              Nothing  -> Nothing             -- neither side has non-empty part
+
+-- ** Parsers are functors:  @`fmap`@
+instance   Functor (P  state) where 
+  fmap f   (P  ap np l me)   =  let nnp =  fmap (fmap     f)  np
+                                    nep =  f <$> me                                    
+                                in  P (mkParser nnp nep) nnp l nep
+  f <$     (P  ap np l me)   =  let nnp =  fmap (f <$)        np
+                                    nep =  f <$   me                                    
+                                in  P (mkParser nnp  nep) nnp l nep
+
+
+-- ** Parsers are Applicative:  @`<*>`@,  @`<*`@,  @`*>`@ and  @`pure`@
+instance   Applicative (P  state) where
+  P ap np  pl pe <*> ~(P aq nq  ql qe)  =  let newnp = combine np pe aq nq (<*>) (<$>)
+                                               newlp = nat_add pl ql
+                                               newep = pe <*> qe
+                                           in  P (mkParser newnp newep) newnp newlp newep
+  P ap np pl pe  <*  ~(P aq nq  ql qe)   = let newnp = combine np pe aq nq (<*) (<$)
+                                               newlp = nat_add pl ql
+                                               newep = pe <* qe
+                                           in  P (mkParser newnp newep) newnp newlp newep
+  P ap np  pl pe  *>  ~(P aq nq ql qe)   = let newnp = combine np pe aq nq (*>)  (flip const)
+                                               newlp = nat_add pl ql
+                                               newep = pe *> qe
+                                           in  P (mkParser newnp newep) newnp newlp newep
+  pure a                                 = P (pure a) Nothing Zero (Just a)
+
+
+ 
+-- ** Parsers are Alternative:  @`<|>`@ and  @`empty`@ 
+instance   Alternative (P   state) where 
+  P ap np  pl pe <|> P aq nq ql qe 
+    =  let (rl, b) = trace' "calling natMin from <|>" (nat_min pl ql 0)
+           Nothing `alt` q  = q
+           p       `alt` Nothing = p
+           Just p  `alt` Just q  = Just (p <|>q)
+       in  let nnp =  (if b then (nq `alt` np) else (np `alt` nq))
+               nep =  if b then trace' "calling pe" pe else trace' "calling qe" qe 
+           in  P (mkParser nnp nep) nnp rl nep
+  empty  =  P  empty empty  Infinite Nothing -- the always failing parser!
+
+-- ** An alternative for the Alternative, which is greedy:  @`<<|>`@
+-- | `<<|>` is the greedy version of `<|>`. If its left hand side parser can make any progress that alternative is committed. 
+-- Can be used to make parsers faster, and even get a complete Parsec equivalent behaviour, with all its (dis)advantages. Use with are!
+
+instance ExtAlternative (P st) where
+  P ap np pl pe <<|> P aq nq ql qe 
+    = let (rl, b) = nat_min pl ql 0
+          bestx :: Steps a -> Steps a -> Steps a
+          bestx = if b then flip best else best
+          choose:: T st a -> T st a -> T st a
+          choose  (T ph pf pr)  (T qh qf qr) 
+             = T  (\ k st -> let left  = norm (ph k st)
+                             in if has_success left then left else left `bestx` qh k st)
+                  (\ k st -> let left  = norm (pf k st)
+                             in if has_success left then left else left `bestx` qf k st) 
+                 (\ k st -> let left  = norm (pr k st)
+                            in if has_success left then left else left  `bestx` qr k st)
+      in   P (choose  ap aq )
+             (maybe np (\nqq -> maybe nq (\npp -> return( choose  npp nqq)) np) nq)
+             rl
+             (pe <|> qe) -- due to the way Maybe is instance of Alternative  the left hand operator gets priority
+  P ap np  pl pe <-|-> P aq nq ql qe 
+    =  let Nothing `alt` q  = q
+           p       `alt` Nothing = p
+           Just p  `alt` Just q  = Just (p <|>q)
+       in  let nnp =  np `alt` nq
+               nep =  pe <|> qe
+           in  P (mkParser nnp nep) nnp pl nep
+
+-- ** Parsers can recognise single tokens:  @`pSym`@ and  @`pSymExt`@
+--   Many parsing libraries do not make a distinction between the terminal symbols of the language recognised 
+--   and the tokens actually constructed from the  input. 
+--   This happens e.g. if we want to recognise an integer or an identifier: 
+--   we are also interested in which integer occurred in the input, or which identifier. 
+--   The function `pSymExt` takes as argument a value of some type `symbol', and returns a value of type `token'.
+--   
+--   The parser will in general depend on some 
+--   state which holds the input. The functional dependency fixes the `token` type, 
+--   based on the `symbol` type and the type of the parser `p`.
+
+-- | Since `pSymExt' is overloaded both the type and the value of a symbol 
+--   determine how to decompose the input in a `token` and the remaining input.
+--   `pSymExt` takes two extra parameters: the first describing the minimal number of tokens recognised, 
+--   and the second telling whether the symbol can recognise the empty string and the value which is to be returned in that case
+  
+pSymExt ::   (Provides state symbol token) => Nat -> Maybe token -> symbol -> P state token
+pSymExt l e a  = P t (Just t) l e
+                 where t = T ( \ k inp -> splitState a k inp)
+                             ( \ k inp -> splitState a (\ t inp' -> push t (k inp')) inp)
+                             ( \ k inp -> splitState a (\ _ inp' -> k inp') inp)
+
+-- | @`pSym`@ covers the most common case of recognsiing a symbol: a single token is removed form the input, 
+-- and it cannot recognise the empty string
+pSym    ::   (Provides state symbol token) =>                       symbol -> P state token
+pSym  s   = pSymExt (Succ Zero) Nothing s 
+
+
+-- ** Parsers are Monads:  @`>>=`@ and  @`return`@
+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+-- %%%%%%%%%%%%% Monads      %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+unParser_h :: P b a -> (a -> b -> Steps r) -> b -> Steps r
+unParser_h (P (T  h   _  _ ) _ _ _ )  =  h
+
+unParser_f :: P b a -> (b -> Steps r) -> b -> Steps (a, r)
+unParser_f (P (T  _   f  _ ) _ _ _ )  =  f
+
+unParser_r :: P b a -> (b -> Steps r) -> b -> Steps r
+unParser_r (P (T  _   _  r ) _ _ _ )  =  r
+          
+-- !! do not move the P constructor behind choices/patern matches
+instance  Monad (P st) where
+       p@(P  ap np lp ep) >>=  a2q = 
+          (P newap newnp (nat_add lp (error "cannot compute minimal length of right hand side of monadic parser")) newep)
+          where (newep, newnp, newap) = case ep of
+                                 Nothing -> (Nothing, t, maybe empty id t) 
+                                 Just a  -> let  P aq nq lq eq = a2q a 
+                                            in  (eq, combine t nq , t `alt` aq)
+                Nothing  `alt` q    = q
+                Just p   `alt` q    = p <|> q
+                t = case np of
+                    Nothing -> Nothing
+                    Just (T h _ _  ) -> Just (T  (  \k -> h (\ a -> unParser_h (a2q a) k))
+                                                 (  \k -> h (\ a -> unParser_f (a2q a) k))
+                                                 (  \k -> h (\ a -> unParser_r (a2q a) k)))
+                combine Nothing     Nothing     = Nothing
+                combine l@(Just _ ) Nothing     =  l
+                combine Nothing     r@(Just _ ) =  r
+                combine (Just l)    (Just r)    = Just (l <|> r)
+       return  = pure 
+
+
+-- * Additional useful combinators
+-- | The parsers build a list of symbols which are expected at a specific point. 
+--   This list is used to report errors.
+--   Quite often it is more informative to get e.g. the name of the non-terminal. 
+--   The @`<?>`@ combinator replaces this list of symbols by it's righ-hand side argument.
+
+(<?>) :: P state a -> String -> P state a
+P  _  np  pl pe <?> label 
+  = let nnp = case np of
+              Nothing -> Nothing
+              Just ((T ph pf  pr)) -> Just(T ( \ k inp -> replaceExpected (norm  ( ph k inp)))
+                                             ( \ k inp -> replaceExpected (norm  ( pf k inp)))
+                                             ( \ k inp -> replaceExpected (norm  ( pr k inp))))
+        replaceExpected :: Steps a -> Steps a
+        replaceExpected (Fail _ c) = (Fail [label] c)
+        replaceExpected others     = others
+    in P (mkParser nnp  pe) nnp pl pe
+
+
+-- | `micro` inserts a `Cost` step into the sequence representing the progress the parser is making; for its use see `Text.ParserCombinators.UU.Examples` 
+micro :: P state a -> Int -> P state a
+P _  np  pl pe `micro` i  
+  = let nnp = case np of
+              Nothing -> Nothing
+              Just ((T ph pf  pr)) -> Just(T ( \ k st -> ph (\ a st -> Micro i (k a st)) st)
+                                             ( \ k st -> pf (Micro i .k) st)
+                                             ( \ k st -> pr (Micro i .k) st))
+    in P (mkParser nnp pe) nnp pl pe
+
+--   For the precise functioning of the combinators we refer to the technical report mentioned in the README file
+--   @`amb`@ converts an ambiguous parser into a parser which returns a list of possible recognitions.
+amb :: P st a -> P st [a]
+amb (P _  np  pl pe) 
+ = let  combinevalues  :: Steps [(a,r)] -> Steps ([a],r)
+        combinevalues lar  =   Apply (\ lar -> (map fst lar, snd (head lar))) lar
+        nnp = case np of
+              Nothing -> Nothing
+              Just ((T ph pf  pr)) -> Just(T ( \k     ->  removeEnd_h . ph (\ a st' -> End_h ([a], \ as -> k as st') noAlts))
+                                             ( \k inp ->  combinevalues . removeEnd_f $ pf (\st -> End_f [k st] noAlts) inp)
+                                             ( \k     ->  removeEnd_h . pr (\ st' -> End_h ([undefined], \ _ -> k  st') noAlts)))
+        nep = (fmap pure pe)
+    in  P (mkParser nnp nep) nnp pl nep
+
+
+-- | `getErrors` retreives the correcting steps made since the last time the function was called. The result can, 
+--   using a monad, be used to control how to proceed with the parsing process.
+
+class state `Stores`  error | state -> error where
+  getErrors    ::  state   -> ([error], state)
+
+-- | The class @`Stores`@ is used by the function @`pErrors`@ which retreives the generated correction spets since the last time it was called.
+--
+pErrors :: Stores st error => P st [error]
+pErrors = let nnp = Just (T ( \ k inp -> let (errs, inp') = getErrors inp in k    errs    inp' )
+                            ( \ k inp -> let (errs, inp') = getErrors inp in push errs (k inp'))
+                            ( \ k inp -> let (errs, inp') = getErrors inp in            k inp' ))
+              nep =  (Just (error "pErrors cannot occur in lhs of bind"))  -- the errors consumed cannot be determined statically!
+          in P (mkParser nnp  Nothing) nnp Zero Nothing
+
+
+-- | @`pPos`@ retreives the correcting steps made since the last time the function was called. The result can, 
+--   using a monad, be used to control how to--    proceed with the parsing process.
+
+class state `HasPosition`  pos | state -> pos where
+  getPos    ::  state   -> pos
+
+pPos :: HasPosition st pos => P st pos
+pPos =  let nnp = Just ( T ( \ k inp -> let pos = getPos inp in k    pos    inp )
+                       ( \ k inp -> let pos = getPos inp in push pos (k inp))
+                       ( \ k inp -> let pos = getPos inp in           k inp ))
+            nep =  Just (error "pPos cannot occur in lhs of bind")  -- the errors consumed cannot be determined statically!
+        in P (mkParser nnp Nothing) nnp Zero Nothing
+
+-- | The function `pEnd` should be called at the end of the parsing process. It deletes any unconsumed input, turning them into error messages
+
+pEnd    :: (Stores st error, Eof st) => P st [error]
+pEnd    = let nnp = Just ( T ( \ k inp ->   let deleterest inp =  case deleteAtEnd inp of
+                                                  Nothing -> let (finalerrors, finalstate) = getErrors inp
+                                                             in k  finalerrors finalstate
+                                                  Just (i, inp') -> Fail []  [const (i,  deleterest inp')]
+                                            in deleterest inp)
+                             ( \ k   inp -> let deleterest inp =  case deleteAtEnd inp of
+                                                  Nothing -> let (finalerrors, finalstate) = getErrors inp
+                                                             in push finalerrors (k finalstate)
+                                                  Just (i, inp') -> Fail [] [const ((i, deleterest inp'))]
+                                            in deleterest inp)
+                             ( \ k   inp -> let deleterest inp =  case deleteAtEnd inp of
+                                                  Nothing -> let (finalerrors, finalstate) = getErrors inp
+                                                             in  (k finalstate)
+                                                  Just (i, inp') -> Fail [] [const (i, deleterest inp')]
+                                            in deleterest inp))
+         in P (mkParser nnp  Nothing) nnp Zero Nothing
+           
+
+-- The function @`parse`@ shows the prototypical way of running a parser on a some specific input
+-- By default we use the future parser, since this gives us access to partal result; future parsers are expected to run in less space.
+
+parse :: (Eof t) => P t a -> t -> a
+parse   (P (T _  pf _) _ _ _)  = fst . eval . pf  (\ rest   -> if eof rest then         Step 0 (Step 0 (Step 0 (Step 0 (error "ambiguous parser?"))))  
+                                                               else error "pEnd missing?")
+parse_h (P (T ph _  _) _ _ _)  = fst . eval . ph  (\ a rest -> if eof rest then push a (Step 0 (Step 0 (Step 0 (Step 0 (error "ambiguous parser?"))))) 
+                                                                           else error "pEnd missing?") 
+
+-- | @`pSwitch`@ takes the current state and modifies it to a different type of state to which its argument parser is applied. 
+--   The second component of the result is a function which  converts the remaining state of this parser back into a valuee of the original type.
+--   For the second argumnet to @`pSwitch`@  (say split) we expect the following to hold:
+--   
+-- >  let (n,f) = split st in f n to be equal to st
+
+pSwitch :: (st1 -> (st2, st2 -> st1)) -> P st2 a -> P st1 a -- we require let (n,f) = split st in f n to be equal to st
+pSwitch split (P _ np pl pe)    
+   = let nnp = fmap (\ (T ph pf pr) ->T (\ k st1 ->  let (st2, back) = split st1
+                                                     in ph (\ a st2' -> k a (back st2')) st2)
+                                        (\ k st1 ->  let (st2, back) = split st1
+                                                     in pf (\st2' -> k (back st2')) st2)
+                                        (\ k st1 ->  let (st2, back) = split st1
+                                                     in pr (\st2' -> k (back st2')) st2)) np
+     in P (mkParser nnp pe) nnp pl pe
+
+-- * Maintaining Progress Information
+-- | The data type @`Steps`@ is the core data type around which the parsers are constructed.
+--   It is a describes a tree structure of streams containing (in an interleaved way) both the online result of the parsing process,
+--   and progress information. Recognising an input token should correspond to a certain amount of @`Progress`@, 
+--   which tells how much of the input state was consumed. 
+--   The @`Progress`@ is used to implement the breadth-first search process, in which alternatives are
+--   examined in a more-or-less synchonised way. The meaning of the various @`Step`@ constructors is as follows:
+--
+--   [@`Step`@] A token was succesfully recognised, and as a result the input was 'advanced' by the distance  @`Progress`@
+--
+--   [@`Apply`@] The type of value represented by the `Steps` changes by applying the function parameter.
+--
+--   [@`Fail`@] A correcting step has to made to the input; the first parameter contains information about what was expected in the input, 
+--   and the second parameter describes the various corrected alternatives, each with an associated `Cost`
+--
+--   [@`Micro`@] A small cost is inserted in the sequence, which is used to disambiguate. Use with care!
+--
+--   The last two alternatives play a role in recognising ambigous non-terminals. For a full description see the technical report referred to from the README file..
+
+type Cost = Int
+type Progress = Int
+type Strings = [String]
+
+data  Steps   a  where
+      Step   ::                 Progress       ->  Steps a                             -> Steps   a
+      Apply  ::  forall a b.    (b -> a)       ->  Steps   b                           -> Steps   a
+      Fail   ::                 Strings        ->  [Strings   ->  (Cost , Steps   a)]  -> Steps   a
+      Micro   ::                Cost           ->  Steps a                             -> Steps   a
+      End_h  ::                 ([a] , [a]     ->  Steps r)    ->  Steps   (a,r)       -> Steps   (a, r)
+      End_f  ::                 [Steps   a]    ->  Steps   a                           -> Steps   a
+
+apply       :: Steps (b -> a, (b, r)) -> Steps (a, r)
+apply       =  Apply (\(b2a, br) -> let (b, r) = br in (b2a b, r)) 
+
+push        :: v -> Steps   r -> Steps   (v, r)
+push v      =  Apply (\ r -> (v, r))
+
+apply2fst   :: (b -> a) -> Steps (b, r) -> Steps (a, r)
+apply2fst f = Apply (\ (b, r) -> (f b, r)) 
+
+succeedAlways :: Steps a
+succeedAlways = let steps = Step 0 steps in steps
+
+failAlways :: Steps a
+failAlways  =  Fail [] [const (0, failAlways)]
+
+noAlts :: Steps a
+noAlts      =  Fail [] []
+
+has_success :: Steps t -> Bool
+has_success (Step _ _) = True
+has_success _        = False 
+
+-- ! @`eval`@ removes the progress information from a sequence of steps, and constructs the value embedded in it.
+--   If you are really desparate to see how your parsers are making progress (e.g. when you have written an ambiguous parser, and you cannot find the cause of
+--   the exponential blow-up of your parsing process, you may switch on the trace in the function @`eval`@
+-- 
+eval :: Steps   a      ->  a
+eval (Step  n    l)     =   {- trace ("Step " ++ show n ++ "\n")-} (eval l)
+eval (Micro  _    l)    =   eval l
+eval (Fail   ss  ls  )  =   trace' ("expecting: " ++ show ss) (eval (getCheapest 3 (map ($ss) ls))) 
+eval (Apply  f   l   )  =   f (eval l)
+eval (End_f   _  _   )  =   error "dangling End_f constructor"
+eval (End_h   _  _   )  =   error "dangling End_h constructor"
+
+
+
+-- | @`norm`@ makes sure that the head of the seqeunce contains progress information. It does so by pushing information about the result (i.e. the @Apply@ steps) backwards.
+--
+norm ::  Steps a ->  Steps   a
+norm     (Apply f (Step   p    l  ))   =   Step  p (Apply f l)
+norm     (Apply f (Micro  c    l  ))   =   Micro c (Apply f l)
+norm     (Apply f (Fail   ss   ls ))   =   Fail ss (applyFail (Apply f) ls)
+norm     (Apply f (Apply  g    l  ))   =   norm (Apply (f.g) l)
+norm     (Apply f (End_f  ss   l  ))   =   End_f (map (Apply f) ss) (Apply f l)
+norm     (Apply f (End_h  _    _  ))   =   error "Apply before End_h"
+norm     steps                         =   steps
+
+applyFail :: (c -> d) -> [a -> (b, c)] -> [a -> (b, d)]
+applyFail f  = map (\ g -> \ ex -> let (c, l) =  g ex in  (c, f l))
+
+-- | The function @best@ compares two streams
+best :: Steps a -> Steps a -> Steps a
+x `best` y =   norm x `best'` norm y
+
+best' :: Steps   b -> Steps   b -> Steps   b
+End_f  as  l            `best'`  End_f  bs r          =   End_f (as++bs)  (l `best` r)
+End_f  as  l            `best'`  r                    =   End_f as        (l `best` r)
+l                       `best'`  End_f  bs r          =   End_f bs        (l `best` r)
+End_h  (as, k_h_st)  l  `best'`  End_h  (bs, _) r     =   End_h (as++bs, k_h_st)  (l `best` r)
+End_h  as  l            `best'`  r                    =   End_h as (l `best` r)
+l                       `best'`  End_h  bs r          =   End_h bs (l `best` r)
+Fail  sl  ll     `best'`  Fail  sr rr     =   Fail (sl ++ sr) (ll++rr)
+Fail  _   _      `best'`  r               =   r   -- <----------------------------- to be refined
+l                `best'`  Fail  _  _      =   l
+Step  n   l      `best'`  Step  m  r
+    | n == m                              =   Step n (l  `best` r)     
+    | n < m                               =   Step n (l  `best`  Step (m - n)  r)
+    | n > m                               =   Step m (Step (n - m)  l  `best` r)
+ls@(Step _  _)    `best'`  Micro _ _        =  ls
+Micro _    _      `best'`  rs@(Step  _ _)   =  rs
+ls@(Micro i l)    `best'`  rs@(Micro j r)  
+    | i == j                               =   Micro i (l `best` r)
+    | i < j                                =   ls
+    | i > j                                =   rs
+l                       `best'`  r         =   error "missing alternative in best'" 
+
+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+-- %%%%%%%%%%%%% getCheapest  %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+getCheapest :: Int -> [(Int, Steps a)] -> Steps a 
+getCheapest _ [] = error "no correcting alternative found"
+getCheapest n l  =  snd $  foldr (\(w,ll) btf@(c, l)
+                               ->    if w < c   -- c is the best cost estimate thus far, and w total costs on this path
+                                     then let new = (traverse n ll w c) 
+                                          in if new < c then (new, ll) else btf
+                                     else btf 
+                               )   (maxBound, error "getCheapest") l
+
+
+traverse :: Int -> Steps a -> Int -> Int  -> Int 
+traverse 0  _            v c  =  trace' ("traverse " ++ show' 0 v c ++ " choosing" ++ show v ++ "\n") v
+traverse n (Step _   l)  v c  =  trace' ("traverse Step   " ++ show' n v c ++ "\n") (traverse (n -  1 ) l (v-n) c)
+traverse n (Micro _  l)  v c  =  trace' ("traverse Micro  " ++ show' n v c ++ "\n") (traverse n         l v     c)
+traverse n (Apply _  l)  v c  =  {- trace' ("traverse Apply  " ++ show n ++ "\n")-} (traverse n         l v     c)
+traverse n (Fail m m2ls) v c  =  trace' ("traverse Fail   " ++ show m ++ show' n v c ++ "\n") 
+                                 (foldr (\ (w,l) c' -> if v + w < c' then traverse (n -  1 ) l (v+w) c'
+                                                       else c') c (map ($m) m2ls)
+                                 )
+traverse n (End_h ((a, lf))    r)  v c =  traverse n (lf a `best` removeEnd_h r) v c
+traverse n (End_f (l      :_)  r)  v c =  traverse n (l `best` r) v c
+
+show' :: (Show a, Show b, Show c) => a -> b -> c -> String
+show' n v c = "n: " ++ show n ++ " v: " ++ show v ++ " c: " ++ show c
+
+
+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+-- %%%%%%%%%%%%% Handling ambiguous paths             %%%%%%%%%%%%%%%%%%%
+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+removeEnd_h     :: Steps (a, r) -> Steps r
+removeEnd_h (Fail  m ls             )  =   Fail m (applyFail removeEnd_h ls)
+removeEnd_h (Step  ps l             )  =   Step  ps (removeEnd_h l)
+removeEnd_h (Apply f l              )  =   error "not in history parsers"
+removeEnd_h (Micro c l              )  =   Micro c (removeEnd_h l)
+removeEnd_h (End_h  (as, k_st  ) r  )  =   k_st as `best` removeEnd_h r 
+
+removeEnd_f      :: Steps r -> Steps [r]
+removeEnd_f (Fail m ls)        =   Fail m (applyFail removeEnd_f ls)
+removeEnd_f (Step ps l)        =   Step ps (removeEnd_f l)
+removeEnd_f (Apply f l)        =   Apply (map' f) (removeEnd_f l) 
+                                   where map' f ~(x:xs)  =  f x : map f xs
+removeEnd_f (Micro c l      )  =   Micro c (removeEnd_f l)
+removeEnd_f (End_f(s:ss) r)    =   Apply  (:(map  eval ss)) s 
+                                                 `best`
+                                          removeEnd_f r
+
+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+-- %%%%%%%%%%%%% Auxiliary Functions and Types        %%%%%%%%%%%%%%%%%%%
+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+-- * Auxiliary functions and types
+-- ** Checking for non-sensical combinations: @`must_be_non_empty`@ and @`must_be_non_empties`@
+-- | The function checks wehther its second argument is a parser which can recognise the mety sequence. If so an error message is given
+--   using the name of the context. If not then the third argument is returned. This is useful in testing for loogical combinations. For its use see
+--   the module Text>parserCombinators.UU.Derived
+
+must_be_non_empty :: [Char] -> P t t1 -> t2 -> t2
+must_be_non_empty msg p@(P _ _ Zero _) _ 
+            = error ("The combinator " ++ msg ++  " requires that it's argument cannot recognise the empty string\n")
+must_be_non_empty _ _  q  = q
+
+-- | This function is similar to the above, but can be used in situations where we recognise a sequence of elements separated by other elements. This does not 
+--   make sense if both parsers can recognise the empty string. Your grammar is then highly ambiguous.
+
+must_be_non_empties :: [Char] -> P t1 t -> P t3 t2 -> t4 -> t4
+must_be_non_empties  msg (P _ _ Zero _) (P _ _ Zero _ ) _ 
+            = error ("The combinator " ++ msg ++  " requires that not both arguments can recognise the empty string\n")
+must_be_non_empties  msg _  _ q = q
+
+
+-- ** The type @`Nat`@ for describing the minimal number of tokens consumed
+-- | The data type @`Nat`@ is used to represent the minimal length of a parser.
+--   Care should be taken in order to not evaluate the right hand side of the binary function @`nat-add`@ more than necesssary.
+
+data Nat = Zero
+         | Succ Nat
+         | Infinite
+         deriving  Show
+
+nat_min :: Nat -> Nat -> Int -> (Nat, Bool)
+nat_min _          Zero      _  = trace' "Right Zero in nat_min\n"    (Zero, False)
+nat_min Zero       _         _  = trace' "Left Zero in nat_min\n"     (Zero, True)
+nat_min Infinite   r         _  = trace' "Left Infinite in nat_min\n" (r,    False) 
+nat_min l          Infinite  _  = trace' "Right Infinite in nat_min\n"    (l,    True) 
+nat_min (Succ ll)  (Succ rr) n  = if n > 1000 then error "problem with comparing lengths" 
+                                  else trace' ("Succ in nat_min " ++ show n ++ "\n")         (let (v, b) = nat_min ll  rr (n+1) in (Succ v, b))
+
+nat_add :: Nat -> Nat -> Nat
+nat_add Infinite  _ = trace' "Infinite in add\n" Infinite
+nat_add Zero      r = trace' "Zero in add\n"     r
+nat_add (Succ l)  r = trace' "Succ in add\n"     (Succ (nat_add l r))
+
+get_length :: P a b -> Nat
+get_length (P _ _  l _) = l
+
+trace' :: String -> b -> b
+trace' m v = {- trace m -}  v 
+
+
+
+
+
+
diff --git a/Text/ParserCombinators/UU/Derived.hs b/Text/ParserCombinators/UU/Derived.hs
new file mode 100644
--- /dev/null
+++ b/Text/ParserCombinators/UU/Derived.hs
@@ -0,0 +1,269 @@
+{-# LANGUAGE  RankNTypes, 
+              GADTs,
+              MultiParamTypeClasses,
+              FunctionalDependencies, 
+              FlexibleInstances, 
+              FlexibleContexts, 
+              UndecidableInstances,
+              NoMonomorphismRestriction #-}
+
+module Text.ParserCombinators.UU.Derived where
+import Text.ParserCombinators.UU.Core
+import Control.Monad
+
+-- | This module contains a large variety of combinators for list-lile structures. the extension @_ng@ indiactes that 
+--   that variant is the non-greedy variant.
+--   See the "Text.ParserCombinators.UU.Examples" module for some exmaples of their use.
+
+-- * Some common combinators for oft occurring constructs
+
+-- | @`pReturn`@ is defined for upwards comptaibility
+--
+pReturn :: a -> P str a
+pReturn  = pure
+
+-- | @`pFail`@ is defined for upwards comptaibility, and is the unit for @<|>@
+--
+pFail :: P str a
+pFail    = empty
+
+infixl 4  <??>
+infixl 2 `opt`
+
+-- | Optionally recognize parser 'p'.
+-- 
+-- If 'p' can be recognized, the return value of 'p' is used. Otherwise,
+-- the value 'v' is used. Note that opt is greedy, if you do not want
+-- this use @... <|> pure v@  instead. Furthermore, 'p' should not
+-- recognise the empty string, since this would make your parser ambiguous!!
+
+opt ::  P st a -> a -> P st a
+p `opt` v       = must_be_non_empty "opt" p (p <<|> pure v) 
+
+-- | @pMaybe@ greedily recognises its argument. If not @Nothing@ is returned.
+--
+pMaybe :: P st a -> P st (Maybe a)
+pMaybe p = must_be_non_empty "pMaybe" p (Just <$> p `opt` Nothing) 
+
+-- | @pEither@ recognises either one of its arguments.
+--
+pEither :: P str a -> P str b -> P str (Either a b)
+pEither p q = Left <$> p <|> Right <$> q
+                                                
+-- | @<$$>@ is the version of @<$>@ which maps on its second argument 
+--
+(<$$>)    ::  (a -> b -> c) -> P st b -> P st (a -> c)
+f <$$> p  =  flip f <$> p
+
+-- | @<??>@ parses an optional postfix element and applies its result to its left hand result
+--
+(<??>) :: P st a -> P st (a -> a) -> P st a
+p <??> q        = must_be_non_empty "<??>" q (p <**> (q `opt` id))
+
+-- | @`pPackes`@ surrounds its third parser with the first and the seond one, keeping only the middle result
+pPacked :: P st b1 -> P st b2 -> P st a -> P st a
+pPacked l r x   =   l *>  x <*   r
+
+-- * The collection of iterating combinators, all in a greedy (default) and a non-greedy variant
+
+pFoldr    :: (a -> a1 -> a1, a1) -> P st a -> P st a1
+pFoldr         alg@(op,e)     p =  must_be_non_empty "pFoldr" p pfm
+                                   where pfm = (op <$> p <*> pfm) `opt` e
+
+pFoldr_ng ::  (a -> a1 -> a1, a1) -> P st a -> P st a1
+pFoldr_ng      alg@(op,e)     p =  must_be_non_empty "pFoldr_ng" p pfm 
+                                   where pfm = (op <$> p <*> pfm)  <|> pure e
+
+
+pFoldr1    :: (v -> b -> b, b) -> P st v -> P st b
+pFoldr1        alg@(op,e)     p =  must_be_non_empty "pFoldr1"    p (op <$> p <*> pFoldr     alg p) 
+
+pFoldr1_ng ::  (v -> b -> b, b) -> P st v -> P st b
+pFoldr1_ng     alg@(op,e)     p =  must_be_non_empty "pFoldr1_ng" p (op <$> p <*> pFoldr_ng  alg p)
+
+pFoldrSep    ::  (v -> b -> b, b) -> P st a -> P st v -> P st b
+pFoldrSep      alg@(op,e) sep p =  must_be_non_empties "pFoldrSep" sep   p
+                                   (op <$> p <*> pFoldr    alg sepp `opt` e)
+                                   where sepp = sep *> p
+pFoldrSep_ng ::  (v -> b -> b, b) -> P st a -> P st v -> P st b
+pFoldrSep_ng   alg@(op,e) sep p =  must_be_non_empties "pFoldrSep" sep   p
+                                   (op <$> p <*> pFoldr_ng alg sepp <|>  pure e)
+                                   where sepp = sep *> p
+
+pFoldr1Sep    ::   (a -> b -> b, b) -> P st a1 ->P st a -> P st b
+pFoldr1Sep     alg@(op,e) sep p =  must_be_non_empties "pFoldr1Sep"    sep   p pfm
+                                   where pfm = op <$> p <*> pFoldr    alg (sep *> p)
+pFoldr1Sep_ng ::   (a -> b -> b, b) -> P st a1 ->P st a -> P st b
+pFoldr1Sep_ng  alg@(op,e) sep p =  must_be_non_empties "pFoldr1Sep_ng" sep   p pfm 
+                                   where pfm = op <$> p <*> pFoldr_ng alg (sep *> p)
+
+list_alg :: (a -> [a] -> [a], [a1])
+list_alg = ((:), [])
+
+pList    ::    P st a -> P st [a]
+pList         p =  must_be_non_empty "pList"    p (pFoldr        list_alg   p)
+pList_ng ::    P st a -> P st [a]
+pList_ng      p =  must_be_non_empty "pList_ng" p (pFoldr_ng     list_alg   p)
+
+pList1    ::   P st a -> P st [a]
+pList1         p =  must_be_non_empty "pList"    p (pFoldr1       list_alg   p)
+pList1_ng ::   P st a -> P st [a]
+pList1_ng      p =  must_be_non_empty "pList_ng" p (pFoldr1_ng    list_alg   p)
+
+
+pListSep    :: P st a1 -> P st a -> P st [a]
+pListSep      sep p = must_be_non_empties "pListSep"    sep   p (pFoldrSep     list_alg sep p)
+pListSep_ng :: P st a1 -> P st a -> P st [a]
+pListSep_ng   sep p = must_be_non_empties "pListSep_ng" sep   p pFoldrSep_ng  list_alg sep p
+
+pList1Sep    :: P st a1 -> P st a -> P st [a]
+pList1Sep     s p =  must_be_non_empties "pListSep"    s   p (pFoldr1Sep    list_alg s p)
+pList1Sep_ng :: P st a1 -> P st a -> P st [a]
+pList1Sep_ng  s p =  must_be_non_empties "pListSep_ng" s   p (pFoldr1Sep_ng list_alg s p)
+
+pChainr    :: P st (c -> c -> c) -> P st c -> P st c
+pChainr    op x    =   must_be_non_empties "pChainr"    op   x r where r = x <??> (flip <$> op <*> r)
+pChainr_ng :: P st (c -> c -> c) -> P st c -> P st c
+pChainr_ng op x    =   must_be_non_empties "pChainr_ng" op   x r where r = x <**> ((flip <$> op <*> r)  <|> pure id)
+
+pChainl    :: P st (c -> c -> c) -> P st c -> P st c
+pChainl   op x    =  must_be_non_empties "pChainl"    op   x (f <$> x <*> pList (flip <$> op <*> x)) 
+                    where  f x [] = x
+                           f x (func:rest) = f (func x) rest
+pChainl_ng :: P st (c -> c -> c) -> P st c -> P st c
+pChainl_ng op x    = must_be_non_empties "pChainl_ng" op   x (f <$> x <*> pList_ng (flip <$> op <*> x))
+                     where f x [] = x
+                           f x (func:rest) = f (func x) rest
+
+-- | Build a parser for each elemnt in its argument list and tries them all.
+pAny :: (a -> P st a1) -> [a] -> P st a1
+pAny  f l =  foldr (<|>) pFail (map f l)
+
+-- | Parses any of the symbols in 'l'.
+pAnySym :: Provides st s s => [s] -> P st s
+pAnySym = pAny pSym 
+
+instance MonadPlus (P st) where
+  mzero = pFail
+  mplus = (<|>)
+
+-- * Merging parsers
+
+infixl 3 <||>
+data Freq p =   AtLeast Int     p
+              | AtMost  Int     p
+              | Between Int Int p
+              | One             p
+              | Many            p
+              | Opt             p
+              | Never           p
+
+instance Functor Freq where
+   fmap f (AtLeast n     p)    = AtLeast n   (f p)
+   fmap f (AtMost  n     p)    = AtMost  n   (f p)
+   fmap f (Between  n m  p)    = Between n m (f p)
+   fmap f (One           p)    = One         (f p)
+   fmap f (Many          p)    = Many        (f p)
+   fmap f (Opt           p)    = Opt         (f p)
+   fmap f (Never         p)    = Never       (f p)
+
+canBeEmpty :: Freq t -> Bool
+canBeEmpty (AtLeast _    p)  = False
+canBeEmpty (AtMost  _    p)  = True
+canBeEmpty (Between n m  p)  = if n==0 then error "wrong use of Between" else False -- safety check
+canBeEmpty (One          p)  = False
+canBeEmpty (Many         p)  = True
+canBeEmpty (Opt          p)  = True
+canBeEmpty (Never        p)  = True
+
+split :: [Freq p] -> ([Freq p] -> [Freq p]) -> [(p, [Freq p])]
+split []     _ = []
+split (x:xs) f = oneAlt (x, f xs): split xs (f.(x:))
+                 where oneAlt  (AtLeast 1   p, others)   = (p, Many                p : others)
+                       oneAlt  (AtLeast n   p, others)   = (p, AtLeast  (n-1)      p : others)
+                       oneAlt  (AtMost  1   p, others)   = (p,                         others)
+                       oneAlt  (AtMost  n   p, others)   = (p, AtMost   (n-1)      p : others)
+                       oneAlt  (Between 1 1 p, others)   = (p,                         others)
+                       oneAlt  (Between 1 m p, others)   = (p, AtMost        (m-1) p : others)
+                       oneAlt  (Between n m p, others)   = (p, Between (n-1) (m-1) p : others)
+                       oneAlt  (One         p, others)   = (p,                         others)
+                       oneAlt  (Many        p, others)   = (p, Many                p : others)
+                       oneAlt  (Opt         p, others)   = (p,                         others)
+
+toParser' :: [ Freq (P st (d -> d)) ]  -> P st (d -> d)
+toParser' []      =  pure id
+toParser' alts    =  let palts = [(.) <$> p <*> toParser'  ps  | (p,ps) <- split alts id]
+                     in if and (map canBeEmpty alts) 
+                        then foldr (<|>) (pure id) palts
+                        else foldr1 (<|>) palts
+
+toParser :: [ Freq (P st (d -> d)) ] -> P st d -> P st d
+toParser []    units  =  units
+toParser alts  units  =  let palts = [p <*> toParser  ps units | (p,ps) <- split alts id]
+                         in if and (map canBeEmpty alts) 
+                            then foldr (<-|->) units palts
+                            else foldr1 (<-|->) palts
+
+
+toParserSep :: [Freq (P st (b -> b))] -> P st a -> P st b -> P st b
+toParserSep alts sep  units  =  let palts = [p <*> toParser  (map (fmap (sep *>)) ps) units | (p,ps) <- split alts id]
+                                in if   and (map canBeEmpty alts) 
+                                   then foldr  (<-|->) units palts
+                                   else foldr1 (<-|->) palts
+
+newtype MergeSpec p = MergeSpec p
+
+(<||>) ::  MergeSpec (d,     [Freq (P st (d     -> d)    )],  e -> d     -> g) 
+        -> MergeSpec (i,     [Freq (P st (i     -> i)    )],  g -> i     -> k) 
+        -> MergeSpec ((d,i), [Freq (P st ((d,i) -> (d,i)))],  e -> (d,i) -> k)
+
+MergeSpec (pe, pp, punp) <||> MergeSpec (qe, qp, qunp)
+ = MergeSpec ( (pe, qe)
+             , map (fmap (mapFst <$>)) pp ++  map (fmap (mapSnd <$>)) qp
+             , \f (x, y) -> qunp (punp f x) y
+             )
+
+pSem :: t -> MergeSpec (t1, t2, t -> t3 -> t4)
+          -> MergeSpec (t1, t2, (t4 -> t5) -> t3 -> t5)
+f `pSem` MergeSpec (units, alts, unp) = MergeSpec  (units, alts, \ g arg -> g ( unp f arg))
+
+pMerge ::  c -> MergeSpec (d, [Freq (P st (d -> d))], c -> d -> e) -> P st e
+sem `pMerge` MergeSpec (units, alts, unp) =  unp sem <$> toParser alts (pure units)
+
+pMergeSep ::  (c, P st a)  -> MergeSpec (d, [Freq (P st (d -> d))], c -> d -> e) -> P st e
+(sem, sep) `pMergeSep` MergeSpec (units, alts, unp) =  unp sem <$> toParserSep alts sep (pure units)
+
+pBetween :: Int -> Int -> P t t1 -> MergeSpec ([a], [Freq (P t ([t1] -> [t1]))], a1 -> a1)
+pBetween  n m p = must_be_non_empty "pOpt"  p 
+                 (if m <n || m <= 0 then         (MergeSpec ([]       ,[                           ], id)) 
+                  else if n==0 then              (MergeSpec ([]       ,[AtMost  m     ((:)   <$> p)], id)) 
+                  else                           (MergeSpec ([]       ,[Between n m   ((:)   <$> p)], id)))
+
+pAtMost :: Int -> P t t1 -> MergeSpec ([a], [Freq (P t ([t1] -> [t1]))], a1 -> a1)
+pAtMost   n   p = must_be_non_empty "pOpt"  p
+                 (if n <= 0         then         (MergeSpec ([]       ,[                           ], id))
+                                    else         (MergeSpec ([]       ,[AtMost  n     ((:)   <$> p)], id)))
+
+pAtLeast :: Int -> P t t1 -> MergeSpec ([a], [Freq (P t ([t1] -> [t1]))], a1 -> a1)
+pAtLeast  n   p = must_be_non_empty "pOpt"  p
+                 (if n <= 0         then         (MergeSpec ([]       ,[Many          ((:)   <$> p)], id))
+                                    else         (MergeSpec ([]       ,[AtLeast n     ((:)   <$> p)], id)))
+
+pMany :: P t t1 -> MergeSpec ([a], [Freq (P t ([t1] -> [t1]))], a1 -> a1)
+pMany p        = must_be_non_empty "pMany" p     (MergeSpec ([]       ,[Many          ((:)   <$> p)], id))
+
+pOpt :: P t t1 -> t11 -> MergeSpec (t11, [Freq (P t (b -> t1))], a -> a)
+pOpt  p v      = must_be_non_empty "pOpt"  p     (MergeSpec (v        ,[Opt           (const <$> p)], id))
+
+pSome :: P t t1 -> MergeSpec ([a], [Freq (P t ([t1] -> [t1]))], a1 -> a1)
+pSome p        = must_be_non_empty "pSome" p     (MergeSpec ([]       ,[AtLeast 1     ((:)   <$> p)], id))
+
+pOne :: P t t1 -> MergeSpec (a, [Freq (P t (b -> t1))], a1 -> a1)
+pOne  p        = must_be_non_empty "pOne"  p     (MergeSpec (undefined,[One           (const <$> p)], id))
+
+mapFst :: (t -> t2) -> (t, t1) -> (t2, t1)
+mapFst f (a, b) = (f a, b)
+
+mapSnd :: (t1 -> t2) -> (t, t1) -> (t, t2)
+mapSnd f (a, b) = (a, f b)
+
diff --git a/Text/ParserCombinators/UU/Parsing.hs b/Text/ParserCombinators/UU/Parsing.hs
new file mode 100644
--- /dev/null
+++ b/Text/ParserCombinators/UU/Parsing.hs
@@ -0,0 +1,5 @@
+module Text.ParserCombinators.UU.Parsing  {-# DEPRECATED "Use Text.ParserCombinators.UU instead" #-}
+        ( module Text.ParserCombinators.UU.Core
+        , module Text.ParserCombinators.UU.Derived) where
+import Text.ParserCombinators.UU.Core
+import Text.ParserCombinators.UU.Derived