HarmTrace 0.3 → 0.4
raw patch · 43 files changed
+4290/−1 lines, 43 files
Files
- Generics/Instant.hs +21/−0
- Generics/Instant/Base.hs +84/−0
- Generics/Instant/Functions.hs +23/−0
- Generics/Instant/Functions/Empty.hs +109/−0
- Generics/Instant/Functions/Eq.hs +66/−0
- Generics/Instant/Functions/Show.hs +89/−0
- Generics/Instant/Functions/Update.hs +63/−0
- Generics/Instant/GDiff.hs +257/−0
- Generics/Instant/Instances.hs +111/−0
- Generics/Instant/TH.hs +332/−0
- HarmTrace.cabal +47/−1
- MIR/GeneratedInstances/GeneratedInstance0.hs +24/−0
- MIR/GeneratedInstances/GeneratedInstance1.hs +24/−0
- MIR/GeneratedInstances/GeneratedInstance10.hs +24/−0
- MIR/GeneratedInstances/GeneratedInstance11.hs +24/−0
- MIR/GeneratedInstances/GeneratedInstance12.hs +24/−0
- MIR/GeneratedInstances/GeneratedInstance13.hs +24/−0
- MIR/GeneratedInstances/GeneratedInstance14.hs +8/−0
- MIR/GeneratedInstances/GeneratedInstance2.hs +24/−0
- MIR/GeneratedInstances/GeneratedInstance3.hs +24/−0
- MIR/GeneratedInstances/GeneratedInstance4.hs +24/−0
- MIR/GeneratedInstances/GeneratedInstance5.hs +24/−0
- MIR/GeneratedInstances/GeneratedInstance6.hs +24/−0
- MIR/GeneratedInstances/GeneratedInstance7.hs +24/−0
- MIR/GeneratedInstances/GeneratedInstance8.hs +24/−0
- MIR/GeneratedInstances/GeneratedInstance9.hs +24/−0
- MIR/GeneratedInstances/GeneratedInstances.hs +21/−0
- MIR/HarmGram/MIR.hs +339/−0
- MIR/HarmGram/ParserChord.hs +86/−0
- MIR/HarmGram/ShowChord.hs +83/−0
- MIR/HarmGram/Tokenizer.hs +247/−0
- MIR/HarmGram/TypeLevel.hs +38/−0
- MIR/Instances.hs +532/−0
- MIR/Matching/GDiff.hs +4/−0
- MIR/Matching/Standard.hs +15/−0
- MIR/Run.hs +249/−0
- Text/ParserCombinators/UU.hs +26/−0
- Text/ParserCombinators/UU/BasicInstances.hs +167/−0
- Text/ParserCombinators/UU/BasicInstances/List.hs +38/−0
- Text/ParserCombinators/UU/BasicInstances/String.hs +25/−0
- Text/ParserCombinators/UU/Core.hs +600/−0
- Text/ParserCombinators/UU/Derived.hs +269/−0
- Text/ParserCombinators/UU/Parsing.hs +5/−0
+ Generics/Instant.hs view
@@ -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 ()
+ Generics/Instant/Base.hs view
@@ -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 + -}
+ Generics/Instant/Functions.hs view
@@ -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
+ Generics/Instant/Functions/Empty.hs view
@@ -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
+ Generics/Instant/Functions/Eq.hs view
@@ -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
+ Generics/Instant/Functions/Show.hs view
@@ -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]
+ Generics/Instant/Functions/Update.hs view
@@ -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
+ Generics/Instant/GDiff.hs view
@@ -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)))
+ Generics/Instant/Instances.hs view
@@ -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?
+ Generics/Instant/TH.hs view
@@ -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)
HarmTrace.cabal view
@@ -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,
+ MIR/GeneratedInstances/GeneratedInstance0.hs view
@@ -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
+ MIR/GeneratedInstances/GeneratedInstance1.hs view
@@ -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
+ MIR/GeneratedInstances/GeneratedInstance10.hs view
@@ -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
+ MIR/GeneratedInstances/GeneratedInstance11.hs view
@@ -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
+ MIR/GeneratedInstances/GeneratedInstance12.hs view
@@ -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
+ MIR/GeneratedInstances/GeneratedInstance13.hs view
@@ -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
+ MIR/GeneratedInstances/GeneratedInstance14.hs view
@@ -0,0 +1,8 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TypeFamilies #-} + +module MIR.GeneratedInstances.GeneratedInstance14 where + +import MIR.Instances ()
+ MIR/GeneratedInstances/GeneratedInstance2.hs view
@@ -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
+ MIR/GeneratedInstances/GeneratedInstance3.hs view
@@ -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
+ MIR/GeneratedInstances/GeneratedInstance4.hs view
@@ -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
+ MIR/GeneratedInstances/GeneratedInstance5.hs view
@@ -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
+ MIR/GeneratedInstances/GeneratedInstance6.hs view
@@ -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
+ MIR/GeneratedInstances/GeneratedInstance7.hs view
@@ -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
+ MIR/GeneratedInstances/GeneratedInstance8.hs view
@@ -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
+ MIR/GeneratedInstances/GeneratedInstance9.hs view
@@ -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
+ MIR/GeneratedInstances/GeneratedInstances.hs view
@@ -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()
+ MIR/HarmGram/MIR.hs view
@@ -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+ ]
+ MIR/HarmGram/ParserChord.hs view
@@ -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...
+ MIR/HarmGram/ShowChord.hs view
@@ -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 ']'
+ MIR/HarmGram/Tokenizer.hs view
@@ -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)
+ MIR/HarmGram/TypeLevel.hs view
@@ -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)
+ MIR/Instances.hs view
@@ -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)
+ MIR/Matching/GDiff.hs view
@@ -0,0 +1,4 @@+ +module MIR.Matching.GDiff (module Generics.Instant.GDiff) where + +import Generics.Instant.GDiff
+ MIR/Matching/Standard.hs view
@@ -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
+ MIR/Run.hs view
@@ -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
+ Text/ParserCombinators/UU.hs view
@@ -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++
+ Text/ParserCombinators/UU/BasicInstances.hs view
@@ -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
+ Text/ParserCombinators/UU/BasicInstances/List.hs view
@@ -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
+ Text/ParserCombinators/UU/BasicInstances/String.hs view
@@ -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)
+ Text/ParserCombinators/UU/Core.hs view
@@ -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 ++++++
+ Text/ParserCombinators/UU/Derived.hs view
@@ -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)+
+ Text/ParserCombinators/UU/Parsing.hs view
@@ -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