HarmTrace 0.4 → 0.5
raw patch · 47 files changed
+300/−4514 lines, 47 filesdep +binarydep +instant-genericsdep −containersdep −ghc-primdep −sybdep ~basedep ~template-haskellsetup-changed
Dependencies added: binary, instant-generics
Dependencies removed: containers, ghc-prim, syb
Dependency ranges changed: base, template-haskell
Files
- Generics/Instant.hs +0/−21
- Generics/Instant/Base.hs +0/−84
- Generics/Instant/Functions.hs +0/−23
- Generics/Instant/Functions/Empty.hs +0/−109
- Generics/Instant/Functions/Eq.hs +0/−66
- Generics/Instant/Functions/Show.hs +0/−89
- Generics/Instant/Functions/Update.hs +0/−63
- Generics/Instant/GDiff.hs +0/−257
- Generics/Instant/Instances.hs +0/−111
- Generics/Instant/TH.hs +0/−332
- HarmTrace.cabal +46/−91
- LICENSE +1/−1
- MIR/GeneratedInstances/GeneratedInstance0.hs +0/−24
- MIR/GeneratedInstances/GeneratedInstance1.hs +0/−24
- MIR/GeneratedInstances/GeneratedInstance10.hs +0/−24
- MIR/GeneratedInstances/GeneratedInstance11.hs +0/−24
- MIR/GeneratedInstances/GeneratedInstance12.hs +0/−24
- MIR/GeneratedInstances/GeneratedInstance13.hs +0/−24
- MIR/GeneratedInstances/GeneratedInstance14.hs +0/−8
- MIR/GeneratedInstances/GeneratedInstance2.hs +0/−24
- MIR/GeneratedInstances/GeneratedInstance3.hs +0/−24
- MIR/GeneratedInstances/GeneratedInstance4.hs +0/−24
- MIR/GeneratedInstances/GeneratedInstance5.hs +0/−24
- MIR/GeneratedInstances/GeneratedInstance6.hs +0/−24
- MIR/GeneratedInstances/GeneratedInstance7.hs +0/−24
- MIR/GeneratedInstances/GeneratedInstance8.hs +0/−24
- MIR/GeneratedInstances/GeneratedInstance9.hs +0/−24
- MIR/GeneratedInstances/GeneratedInstances.hs +0/−21
- MIR/HarmGram/MIR.hs +0/−339
- MIR/HarmGram/ParserChord.hs +0/−86
- MIR/HarmGram/ShowChord.hs +0/−83
- MIR/HarmGram/Tokenizer.hs +0/−247
- MIR/HarmGram/TypeLevel.hs +0/−38
- MIR/Instances.hs +0/−532
- MIR/Matching/GDiff.hs +0/−4
- MIR/Matching/Standard.hs +0/−15
- MIR/Run.hs +0/−249
- Main.hs +0/−173
- Setup.hs +6/−6
- Text/ParserCombinators/UU.hs +0/−26
- Text/ParserCombinators/UU/BasicInstances.hs +0/−167
- Text/ParserCombinators/UU/BasicInstances/List.hs +0/−38
- Text/ParserCombinators/UU/BasicInstances/String.hs +0/−25
- Text/ParserCombinators/UU/Core.hs +0/−600
- Text/ParserCombinators/UU/Derived.hs +0/−269
- Text/ParserCombinators/UU/Parsing.hs +0/−5
- src/Main.hs +247/−0
− Generics/Instant.hs
@@ -1,21 +0,0 @@------------------------------------------------------------------------------ --- | --- 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
@@ -1,84 +0,0 @@-{-# 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
@@ -1,23 +0,0 @@--------------------------------------------------------------------------------- |--- 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
@@ -1,109 +0,0 @@-{-# 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
@@ -1,66 +0,0 @@-{-# 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
@@ -1,89 +0,0 @@-{-# 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
@@ -1,63 +0,0 @@-{-# 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
@@ -1,257 +0,0 @@-{-# 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
@@ -1,111 +0,0 @@-{-# 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
@@ -1,332 +0,0 @@-{-# 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,91 +1,46 @@-name: HarmTrace-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- Chords Entities- .- This is the first public release of HarmTrace, a system- for automatically analysing the harmony of music- sequences. HarmTrace is described in the paper:- .- * José Pedro Magalhães and W. Bas de Haas.- /Experience Report: Functional Modelling of Musical Harmony./- International Conference on Functional Programming,- 2011.- <http://dreixel.net/research/pdf/fmmh.pdf>--copyright: (c) 2010--2011 Universiteit Utrecht-license: OtherLicense-license-file: LICENSE-author: W. Bas de Haas and José Pedro Magalhães-stability: experimental-maintainer: bash@cs.uu.nl, jpm@cs.uu.nl-category: Music-build-type: Simple-cabal-version: >= 1.6-tested-with: GHC == 7.0.3--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, - regex-tdfa == 1.1.*, process >= 1.0,- uu-parsinglib == 2.7.1, ListLike >= 3.0.1,- vector == 0.7.*, deepseq,- -- temporary- containers, syb, ghc-prim- ghc-options: -Wall- -O2 -fno-spec-constr-count -funbox-strict-fields- -fcontext-stack=50- -threaded -feager-blackholing -rtsopts-- ghc-prof-options: -auto-all+name: HarmTrace +version: 0.5 +synopsis: Harmony Analysis and Retrieval of Music +description: HarmTrace: Harmony Analysis and Retrieval of Music + with Type-level Representations of Abstract + Chords Entities + . + We present HarmTrace, a system + for automatically analysing the harmony of music + sequences. HarmTrace is described in the paper: + . + * José Pedro Magalhães and W. Bas de Haas. + /Experience Report: Functional Modelling of Musical Harmony./ + International Conference on Functional Programming, + 2011. + <http://dreixel.net/research/pdf/fmmh.pdf> + +copyright: (c) 2010--2011 Universiteit Utrecht +license: OtherLicense +license-file: LICENSE +author: W. Bas de Haas and José Pedro Magalhães +stability: experimental +maintainer: bash@cs.uu.nl, jpm@cs.uu.nl +homepage: http://www.cs.uu.nl/wiki/GenericProgramming/HarmTrace +category: Music +build-type: Simple +cabal-version: >= 1.6 +tested-with: GHC == 7.0.3 + +executable harmtrace + hs-source-dirs: src + main-is: Main.hs + build-depends: base >= 4.3 && < 4.4, template-haskell >=2.5 && <2.6, + mtl, directory, filepath, array, parallel >= 3, + Diff == 0.1.*, parseargs >= 0.1.3.2, + regex-tdfa == 1.1.*, process >= 1.0, + uu-parsinglib == 2.7.1, ListLike >= 3.0.1, + vector == 0.7.*, deepseq, + instant-generics >= 0.3.1 && < 0.4, binary == 0.5.* + + ghc-options: -Wall + -O2 -fno-spec-constr-count -funbox-strict-fields + -fcontext-stack=50 + -threaded -feager-blackholing -rtsopts + + ghc-prof-options: -auto-all
LICENSE view
@@ -1,1 +1,1 @@-This work is licensed under the Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported License. To view a copy of this license, visit http://creativecommons.org/licenses/by-nc-sa/3.0/ or send a letter to Creative Commons, 444 Castro Street, Suite 900, Mountain View, California, 94041, USA.+This work is licensed under the Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported License. To view a copy of this license, visit http://creativecommons.org/licenses/by-nc-sa/3.0/ or send a letter to Creative Commons, 444 Castro Street, Suite 900, Mountain View, California, 94041, USA.
− MIR/GeneratedInstances/GeneratedInstance0.hs
@@ -1,24 +0,0 @@-{-# 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
@@ -1,24 +0,0 @@-{-# 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
@@ -1,24 +0,0 @@-{-# 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
@@ -1,24 +0,0 @@-{-# 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
@@ -1,24 +0,0 @@-{-# 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
@@ -1,24 +0,0 @@-{-# 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
@@ -1,8 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TypeFamilies #-} - -module MIR.GeneratedInstances.GeneratedInstance14 where - -import MIR.Instances ()
− MIR/GeneratedInstances/GeneratedInstance2.hs
@@ -1,24 +0,0 @@-{-# 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
@@ -1,24 +0,0 @@-{-# 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
@@ -1,24 +0,0 @@-{-# 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
@@ -1,24 +0,0 @@-{-# 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
@@ -1,24 +0,0 @@-{-# 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
@@ -1,24 +0,0 @@-{-# 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
@@ -1,24 +0,0 @@-{-# 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
@@ -1,24 +0,0 @@-{-# 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
@@ -1,21 +0,0 @@-{-# 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
@@ -1,339 +0,0 @@-{-# 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
@@ -1,86 +0,0 @@-{-# 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
@@ -1,83 +0,0 @@-{-# 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
@@ -1,247 +0,0 @@-{-# 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
@@ -1,38 +0,0 @@-{-# 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
@@ -1,532 +0,0 @@-{-# 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
@@ -1,4 +0,0 @@- -module MIR.Matching.GDiff (module Generics.Instant.GDiff) where - -import Generics.Instant.GDiff
− MIR/Matching/Standard.hs
@@ -1,15 +0,0 @@- -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
@@ -1,249 +0,0 @@-{-# 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
− Main.hs
@@ -1,173 +0,0 @@-{-# OPTIONS_GHC -Wall #-}--module Main where---- Libs-import System.Console.ParseArgs hiding (args) -- cabal install parseargs-import System.FilePath-import System.IO-import Data.Maybe (isJust, fromJust)-import Data.List (unzip4)-import Control.Monad (when)---- Music stuff-import MIR.Run---- Parallelism-import Control.Parallel.Strategies------------------------------------------------------------------------------------- Command-line arguments-----------------------------------------------------------------------------------data MyArgs = SourceInputString | SourceInputFile | TargetInputFile - | InputDir | OpMode | Print | MaxErrorRate | WriteGT- deriving (Eq, Ord, Show)--myArgs :: [Arg MyArgs]-myArgs = [- Arg { argIndex = MaxErrorRate,- argAbbr = Just 'e',- argName = Just "max-error",- argData = argDataOptional "float" ArgtypeFloat,- argDesc = "Ignore pieces with higher error rate for diff"- },- Arg { argIndex = SourceInputString,- argAbbr = Just 'c',- argName = Just "chords",- argData = argDataOptional "string" ArgtypeString,- argDesc = "Input Chord Sequence to parse"- },- Arg { argIndex = SourceInputFile,- argAbbr = Just '1',- argName = Just "sfile",- argData = argDataOptional "filepath" ArgtypeString,- argDesc = "Input file (source for diff)"- },- Arg { argIndex = TargetInputFile,- argAbbr = Just '2',- argName = Just "tfile",- argData = argDataOptional "filepath" ArgtypeString,- argDesc = "Input file (target for diff)"- },- Arg { argIndex = InputDir,- argAbbr = Just 'd',- argName = Just "dir",- argData = argDataOptional "directory" ArgtypeString,- argDesc = "Input directory (to process all files within)"- },- Arg { argIndex = OpMode,- argAbbr = Just 'm',- argName = Just "mode",- argData = argDataRequired "parse|gdiff|stdiff"- ArgtypeString,- argDesc = "One of \"parse\", \"diff\", or \"stdiff\""- },- Arg { argIndex = Print,- argAbbr = Just 'p',- argName = Just "print",- argData = Nothing,- argDesc = "Set this flag to generate a .png for an input file"- },- Arg { argIndex = WriteGT,- argAbbr = Just 'g',- argName = Just "writegt",- argData = argDataOptional "filepath" ArgtypeString,- argDesc = "Write ground truth to file"- }- ]------------------------------------------------------------------------------------- Main------------------------------------------------------------------------------------data MatchMode = STDiff | GDiff- deriving (Eq, Ord, Show)--err1, err2, err3 :: String-err1 = "Use a source file, or a directory."-err2 = "Use a source file and a target file, or a directory."-err3 = "Use a source file and optionally a target file."--main :: IO ()-main = do args <- parseArgsIO ArgsComplete myArgs- let mode = getRequiredArg args OpMode- prnt = gotArg args Print- case mode of- "parse" -> mainParse prnt- "gdiff" -> mainDiff False GDiff -- diffs cannot be printed- "stdiff" -> mainDiff False STDiff- s -> usageError args ("Unknown mode: " ++ s)--mainParse :: Bool -> IO ()-mainParse p = do args <- parseArgsIO ArgsComplete myArgs- -- cdir <- getCurrentDirectory- let cStr = getArgString args SourceInputString- mf1 = getArgString args SourceInputFile- mf2 = getArgString args TargetInputFile- mdir = getArgString args InputDir- case (cStr, mf1,mf2,mdir, p) of- -- parse a string of chords- (Just c, Nothing, Nothing, Nothing , False) - -> parseTree c- -- Parse one file, show full output- (Nothing, Just f1, Nothing, Nothing , False) - -> readFile' f1 >>= parseTree- -- Parse all files in one dir, show condensed output- (Nothing, Nothing, Nothing, Just dir, False) - -> testDir dir- _ -> usageError args err1 -- - -mainDiff :: Bool -> MatchMode -> IO ()-mainDiff p m =- do args <- parseArgsIO ArgsComplete myArgs- let mf1 = getArg args SourceInputFile- mf2 = getArg args TargetInputFile- mdir = getArg args InputDir- me = getArg args MaxErrorRate- gt = getArg args WriteGT- case (mf1,mf2,mdir,p) of- -- Parse source and target file, show full output- (Just f1, Just f2, Nothing, False) -> diff m f1 f2- -- Diff all files in one dir, show condensed output- (Nothing, Nothing, Just dir, False) -> testDirMatch m me gt dir - _ -> usageError args err2--diff :: MatchMode -> String -> String -> IO ()-diff m f1 f2 = do (toks1, ts1, _, _) <- readFile' f1 >>= return . string2PieceC- (toks2, ts2, _, _) <- readFile' f2 >>= return . string2PieceC- case m of- STDiff -> putStrLn (diffChords toks1 toks2)- GDiff -> print (diffPiece (head ts1) (head ts2))- - -filterNonQuery :: [FilePath] -> [FilePath] -filterNonQuery = concat . map snd . filter ((>1) . length . snd) . getClassSizes--testDirMatch :: MatchMode -> Maybe Float -> Maybe FilePath -> FilePath -> IO ()-testDirMatch m me od fp = - do fs <- readDataDir fp- let process f = do s <- readFile' (fp </> f)- let (toks, ps, _, errs) = string2PieceC s- return (f, toks, head ps, errorRatio errs toks)- (fs', toks, ps, errs) <- fmap unzip4 (mapM process fs)- when (isJust od) $ writeGroundTruth fs' (fromJust od)- let fsq = filterNonQuery fs'- putStr "true\ntrue\n"- mapM_ (putStr . (++ "\t")) fsq- putChar '\n'- mapM_ (putStr . (++ "\t"). getId) fs'- putStrLn ""- let runDiff df l = [ [ df me ex ey x y | (y,ey) <- l ]- | ((x,ex),i) <- zip l (map getId fs'), i `elem` fsq ]- printLine l = putStrLn (foldr (\a b -> showFloat a ++ "\t" ++ b) "" l)- >> hFlush stdout- undf = error "stdiff should not inspect parsing results"- let r = case m of- STDiff -> runDiff diffChordsLen (zip toks (repeat undf))- GDiff -> runDiff diffPieceLen (zip ps errs)- `using` parList rdeepseq- sequence_ [ printLine x | x <- r]
Setup.hs view
@@ -1,6 +1,6 @@-module Main (main) where--import Distribution.Simple--main :: IO ()-main = defaultMain+module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMainWithHooks simpleUserHooks
− Text/ParserCombinators/UU.hs
@@ -1,26 +0,0 @@--- | 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
@@ -1,167 +0,0 @@-{-# 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
@@ -1,38 +0,0 @@-{-# 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
@@ -1,25 +0,0 @@-{-# 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
@@ -1,600 +0,0 @@-{-# 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
@@ -1,269 +0,0 @@-{-# 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
@@ -1,5 +0,0 @@-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
+ src/Main.hs view
@@ -0,0 +1,247 @@+{-# OPTIONS_GHC -Wall #-} + +module Main where + +-- Libs +import System.Console.ParseArgs hiding (args) -- cabal install parseargs +import System.FilePath +import System.IO +import Data.Maybe (isJust, fromJust) +import Data.Binary + +-- Music stuff +import HarmTrace.HarmTrace +import HarmTrace.Base.MusicRep +import HarmTrace.IO.Main +import HarmTrace.IO.Errors +import HarmTrace.Matching.GuptaNishimuraEditMatch +import HarmTrace.Matching.Standard +import HarmTrace.Matching.Matching +import HarmTrace.IO.PrintTree +import HarmTrace.HAnTree.Tree (Tree) +import HarmTrace.HAnTree.HAn +import HarmTrace.Matching.Sim (selfSim) + +-- Parallelism +import Control.Parallel.Strategies + +-------------------------------------------------------------------------------- +-- Command-line arguments +-------------------------------------------------------------------------------- + +data MyArgs = SourceInputString | SourceInputFile | TargetInputFile + | InputDir | OpMode | Print | MaxErrorRate | BinaryOut | BinaryIn + deriving (Eq, Ord, Show) + +myArgs :: [Arg MyArgs] +myArgs = [ + Arg { argIndex = MaxErrorRate, + argAbbr = Just 'e', + argName = Just "max-error", + argData = argDataOptional "float" ArgtypeFloat, + argDesc = "Ignore pieces with higher error rate for diff" + }, + Arg { argIndex = SourceInputString, + argAbbr = Just 'c', + argName = Just "chords", + argData = argDataOptional "string" ArgtypeString, + argDesc = "Input Chord Sequence to parse" + }, + Arg { argIndex = SourceInputFile, + argAbbr = Just '1', + argName = Just "sfile", + argData = argDataOptional "filepath" ArgtypeString, + argDesc = "Input file (source for diff)" + }, + Arg { argIndex = TargetInputFile, + argAbbr = Just '2', + argName = Just "tfile", + argData = argDataOptional "filepath" ArgtypeString, + argDesc = "Input file (target for diff)" + }, + Arg { argIndex = InputDir, + argAbbr = Just 'd', + argName = Just "dir", + argData = argDataOptional "directory" ArgtypeString, + argDesc = "Input directory (to process all files within)" + }, + Arg { argIndex = OpMode, + argAbbr = Just 'm', + argName = Just "mode", + argData = argDataRequired "parse|stdiff|lces|bpm" + ArgtypeString, + argDesc = "One of \"parse\", \"lces\", \"stdiff\", "++ + "or \"bpm\"" + }, + Arg { argIndex = Print, + argAbbr = Just 'p', + argName = Just "print", + argData = Nothing, + argDesc = "Set this flag to generate a .png for an input file" + }, + Arg { argIndex = BinaryOut, + argAbbr = Just 'o', + argName = Just "out", + argData = argDataOptional "filepath" ArgtypeString, + argDesc = "Output binary file for parsing results" + }, + Arg { argIndex = BinaryIn, + argAbbr = Just 'i', + argName = Just "in", + argData = argDataOptional "filepath" ArgtypeString, + argDesc = "Input binary file for matching" + } + ] + +-------------------------------------------------------------------------------- +-- Main +-------------------------------------------------------------------------------- + + +data MatchMode = STDiff | LCES | BPMatch + deriving (Eq, Ord, Show) + +err1, err2, err3 :: String +err1 = "Use a source file, or a directory." +err2 = "Use a source file and a target file, or a directory." +err3 = "Use a source file and optionally a target file." + +main :: IO () +main = do args <- parseArgsIO ArgsComplete myArgs + let mode = getRequiredArg args OpMode + prnt = gotArg args Print + case mode of + "parse" -> mainParse prnt + "stdiff" -> mainMatch False STDiff + "bpm" -> mainMatch prnt BPMatch + "lces" -> mainMatch prnt LCES + s -> usageError args ("Unknown mode: " ++ s) + +mainParse :: Bool -> IO () +mainParse p = do args <- parseArgsIO ArgsComplete myArgs + let cStr = getArgString args SourceInputString + mf1 = getArgString args SourceInputFile + mf2 = getArgString args TargetInputFile + bOut = getArgString args BinaryOut + mdir = getArgString args InputDir + case (cStr, mf1,mf2,mdir, p) of + -- parse a string of chords + (Just c, Nothing, Nothing, Nothing , False) -> + parseTree c >> return () + (Just c, Nothing, Nothing, Nothing , True) -> + do ts <- parseTree c + printTreeHAnF ts (trimFilename c) >> return () + -- Parse one file, show full output + (Nothing, Just f1, Nothing, Nothing , False) -> + do ts <- readFile f1 >>= parseTreeVerb + mapM_ print ts + (Nothing, Just f1, Nothing, Nothing , True ) -> + --with post processing + do ts <- readFile f1 >>= parseTree + printTreeHAnF ts f1 >> return () + -- Parse all files in one dir, show condensed output + (Nothing, Nothing, Nothing, Just dir, False) -> + parseDir dir bOut + _ -> usageError args err1 + +trimFilename :: String -> String +trimFilename = filter (\x -> not (elem x ":*")) . concat . words . take 20 + +mainMatch :: Bool -> MatchMode -> IO () +mainMatch p m = + do args <- parseArgsIO ArgsComplete myArgs + let cStr = getArgString args SourceInputString + mf1 = getArg args SourceInputFile + mf2 = getArg args TargetInputFile + mdir = getArg args InputDir + bIn = getArgString args BinaryIn + me = getArg args MaxErrorRate + case (cStr,mf1,mf2,mdir,p) of + -- Parse source and target file, show full output + (_,Just f1, Just f2, Nothing, prnt) -> + do c1 <- readFile' f1 + c2 <- readFile' f2 + matchFiles m prnt c1 c2 f1 f2 + (Just c, Just f1, Nothing, Nothing, True) -> + matchFiles m True c f1 (trimFilename c) (trimFilename f1) + -- match all files in one dir, show condensed output + (_,Nothing, Nothing, Just dir, False) -> testDirMatch bIn m me dir + _ -> usageError args err2 + +printSelfSims :: Tree HAn -> Tree HAn -> IO() +printSelfSims a b = putStrLn (str a ++ str b) where + str x = "self similarity" ++ (show $ selfSim x) + +matchFiles :: MatchMode -> Bool -> String -> String -> String -> String -> IO () +matchFiles m prnt f1 f2 _n1 _n2 = + let (toks1, _, ts1, te1, pe1) = string2PieceCPostProc f1 + (toks2, _, ts2, te2, pe2) = string2PieceCPostProc f2 + in + do if not $ null te1 then showErrors "tokenizer 1: " te1 else putStr "" + if not $ null te2 then showErrors "tokenizer 2: " te2 else putStr "" + if not $ null pe1 then showErrors "parser 1: " pe1 else putStr "" + if not $ null pe2 then showErrors "parser 2: " pe2 else putStr "" + case (m,prnt) of + (STDiff,_) -> print (diffChordsLen toks1 toks2) + (BPMatch,True) -> printBPM 2 (head ts1) (head ts2) + (BPMatch,False) -> error "Unimplemented." -- putStrLn ( "score: " ++ show (getMatch 2 ts1 ts2)) + (LCES,False) -> do + printSelfSims (head ts1) (head ts2) + putStrLn ("1vs2\n" ++show lcesab ++ "\nscore: " ++ show scoreab) + putStrLn ("2vs1\n" ++show lcesba ++ "\nscore: " ++ show scoreba) + putStrLn ("self Simlarity 1: " ++ (show . selfSim $ head ts1)) + putStrLn ("self Simlarity 2: " ++ (show . selfSim $ head ts2)) where + (lcesab,lcesba,scoreab,scoreba) = matchTwo (head ts1) (head ts2) + (LCES,True) -> do + {- printTreeHAnF (show ts1) ( n1 <.> "png") >> return () + printTreeHAnF (show ts2) ( n2 <.> "png") >> return () + printTreeHAn (show lcesab) ("match1vs2" <.> "png") + >> return () + printTreeHAn (show lcesba) ("match2vs1" <.> "png") + >> return () + printSelfSims ts1 ts2 -} + putStrLn ("refactor me"); + +matchTwo :: Tree HAn -> Tree HAn -> ([Tree HAn], [Tree HAn], Float, Float) +matchTwo ta tb = (lcesab,lcesba,scoreab,scoreba) where + (lcesab, scoreab) = getWeightLCES ta tb + (lcesba, scoreba) = getWeightLCES tb ta + +-- filters the songs that have multiple versions and can be used as query +filterNonQuery :: [FilePath] -> [FilePath] +filterNonQuery = concatMap snd . filter ((>1) . length . snd) . getClassSizes + +-- matches a directory of chord description files +testDirMatch :: Maybe FilePath -> MatchMode -> Maybe Float -> FilePath -> IO () +testDirMatch bIn m me fp = + do fs <- readDataDir fp + let process s = let (tks, _, ts, _, e2) = string2PieceCPostProc s + in (tks, head ts, errorRatio e2 tks) + filterError = if isJust me + then filter (\(_,_,e) -> e <= fromJust me) else id + pss <- mapM (\f -> readFile' (fp </> f)) fs + (tks, ps) <- case bIn of + Just bp -> decodeFile bp :: IO ([[ChordLabel]],[Tree HAn]) + Nothing -> let (toks, ps', _) = unzip3 (filterError + (map process pss)) + in return (toks, ps' `using` parList rdeepseq) + let fsq = filterNonQuery fs + putStr "true\n" + if (m == LCES || m == BPMatch) then putStr "false\n" else putStr "true\n" + mapM_ (putStr . (++ "\t")) fsq + putChar '\n' + mapM_ (putStr . (++ "\t"). getId) fs + putStrLn "" + let match sim l = [ [ sim x y | y <- l ] + | (x,i) <- zip l (map getId fs), i `elem` fsq ] + printLine l = putStrLn (foldr (\a b -> showFloat a ++ "\t" ++ b) "" l) + >> hFlush stdout + let r = (case m of + STDiff -> match diffChordsLen tks + LCES -> match getSimLCES ps + BPMatch -> match (getMatch 2) ps) + -- we could use nr-of-cores threads to pars nr-of-cores chunks... + -- `using` parListChunk numCapabilities rdeepseq + -- ... but this is just faster + `using` parList rdeepseq + sequence_ [ printLine x | x <- r]