diff --git a/Generics/Instant.hs b/Generics/Instant.hs deleted file mode 100644 --- a/Generics/Instant.hs +++ /dev/null @@ -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 () diff --git a/Generics/Instant/Base.hs b/Generics/Instant/Base.hs deleted file mode 100644 --- a/Generics/Instant/Base.hs +++ /dev/null @@ -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 - -} diff --git a/Generics/Instant/Functions.hs b/Generics/Instant/Functions.hs deleted file mode 100644 --- a/Generics/Instant/Functions.hs +++ /dev/null @@ -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 diff --git a/Generics/Instant/Functions/Empty.hs b/Generics/Instant/Functions/Empty.hs deleted file mode 100644 --- a/Generics/Instant/Functions/Empty.hs +++ /dev/null @@ -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 diff --git a/Generics/Instant/Functions/Eq.hs b/Generics/Instant/Functions/Eq.hs deleted file mode 100644 --- a/Generics/Instant/Functions/Eq.hs +++ /dev/null @@ -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 diff --git a/Generics/Instant/Functions/Show.hs b/Generics/Instant/Functions/Show.hs deleted file mode 100644 --- a/Generics/Instant/Functions/Show.hs +++ /dev/null @@ -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] diff --git a/Generics/Instant/Functions/Update.hs b/Generics/Instant/Functions/Update.hs deleted file mode 100644 --- a/Generics/Instant/Functions/Update.hs +++ /dev/null @@ -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 diff --git a/Generics/Instant/GDiff.hs b/Generics/Instant/GDiff.hs deleted file mode 100644 --- a/Generics/Instant/GDiff.hs +++ /dev/null @@ -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))) diff --git a/Generics/Instant/Instances.hs b/Generics/Instant/Instances.hs deleted file mode 100644 --- a/Generics/Instant/Instances.hs +++ /dev/null @@ -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? diff --git a/Generics/Instant/TH.hs b/Generics/Instant/TH.hs deleted file mode 100644 --- a/Generics/Instant/TH.hs +++ /dev/null @@ -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) diff --git a/HarmTrace.cabal b/HarmTrace.cabal --- a/HarmTrace.cabal +++ b/HarmTrace.cabal @@ -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. - - -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. + + +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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/MIR/GeneratedInstances/GeneratedInstance0.hs b/MIR/GeneratedInstances/GeneratedInstance0.hs deleted file mode 100644 --- a/MIR/GeneratedInstances/GeneratedInstance0.hs +++ /dev/null @@ -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 diff --git a/MIR/GeneratedInstances/GeneratedInstance1.hs b/MIR/GeneratedInstances/GeneratedInstance1.hs deleted file mode 100644 --- a/MIR/GeneratedInstances/GeneratedInstance1.hs +++ /dev/null @@ -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 diff --git a/MIR/GeneratedInstances/GeneratedInstance10.hs b/MIR/GeneratedInstances/GeneratedInstance10.hs deleted file mode 100644 --- a/MIR/GeneratedInstances/GeneratedInstance10.hs +++ /dev/null @@ -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 diff --git a/MIR/GeneratedInstances/GeneratedInstance11.hs b/MIR/GeneratedInstances/GeneratedInstance11.hs deleted file mode 100644 --- a/MIR/GeneratedInstances/GeneratedInstance11.hs +++ /dev/null @@ -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 diff --git a/MIR/GeneratedInstances/GeneratedInstance12.hs b/MIR/GeneratedInstances/GeneratedInstance12.hs deleted file mode 100644 --- a/MIR/GeneratedInstances/GeneratedInstance12.hs +++ /dev/null @@ -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 diff --git a/MIR/GeneratedInstances/GeneratedInstance13.hs b/MIR/GeneratedInstances/GeneratedInstance13.hs deleted file mode 100644 --- a/MIR/GeneratedInstances/GeneratedInstance13.hs +++ /dev/null @@ -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 diff --git a/MIR/GeneratedInstances/GeneratedInstance14.hs b/MIR/GeneratedInstances/GeneratedInstance14.hs deleted file mode 100644 --- a/MIR/GeneratedInstances/GeneratedInstance14.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TypeFamilies #-} - -module MIR.GeneratedInstances.GeneratedInstance14 where - -import MIR.Instances () diff --git a/MIR/GeneratedInstances/GeneratedInstance2.hs b/MIR/GeneratedInstances/GeneratedInstance2.hs deleted file mode 100644 --- a/MIR/GeneratedInstances/GeneratedInstance2.hs +++ /dev/null @@ -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 diff --git a/MIR/GeneratedInstances/GeneratedInstance3.hs b/MIR/GeneratedInstances/GeneratedInstance3.hs deleted file mode 100644 --- a/MIR/GeneratedInstances/GeneratedInstance3.hs +++ /dev/null @@ -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 diff --git a/MIR/GeneratedInstances/GeneratedInstance4.hs b/MIR/GeneratedInstances/GeneratedInstance4.hs deleted file mode 100644 --- a/MIR/GeneratedInstances/GeneratedInstance4.hs +++ /dev/null @@ -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 diff --git a/MIR/GeneratedInstances/GeneratedInstance5.hs b/MIR/GeneratedInstances/GeneratedInstance5.hs deleted file mode 100644 --- a/MIR/GeneratedInstances/GeneratedInstance5.hs +++ /dev/null @@ -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 diff --git a/MIR/GeneratedInstances/GeneratedInstance6.hs b/MIR/GeneratedInstances/GeneratedInstance6.hs deleted file mode 100644 --- a/MIR/GeneratedInstances/GeneratedInstance6.hs +++ /dev/null @@ -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 diff --git a/MIR/GeneratedInstances/GeneratedInstance7.hs b/MIR/GeneratedInstances/GeneratedInstance7.hs deleted file mode 100644 --- a/MIR/GeneratedInstances/GeneratedInstance7.hs +++ /dev/null @@ -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 diff --git a/MIR/GeneratedInstances/GeneratedInstance8.hs b/MIR/GeneratedInstances/GeneratedInstance8.hs deleted file mode 100644 --- a/MIR/GeneratedInstances/GeneratedInstance8.hs +++ /dev/null @@ -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 diff --git a/MIR/GeneratedInstances/GeneratedInstance9.hs b/MIR/GeneratedInstances/GeneratedInstance9.hs deleted file mode 100644 --- a/MIR/GeneratedInstances/GeneratedInstance9.hs +++ /dev/null @@ -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 diff --git a/MIR/GeneratedInstances/GeneratedInstances.hs b/MIR/GeneratedInstances/GeneratedInstances.hs deleted file mode 100644 --- a/MIR/GeneratedInstances/GeneratedInstances.hs +++ /dev/null @@ -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() diff --git a/MIR/HarmGram/MIR.hs b/MIR/HarmGram/MIR.hs deleted file mode 100644 --- a/MIR/HarmGram/MIR.hs +++ /dev/null @@ -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 - ] diff --git a/MIR/HarmGram/ParserChord.hs b/MIR/HarmGram/ParserChord.hs deleted file mode 100644 --- a/MIR/HarmGram/ParserChord.hs +++ /dev/null @@ -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... diff --git a/MIR/HarmGram/ShowChord.hs b/MIR/HarmGram/ShowChord.hs deleted file mode 100644 --- a/MIR/HarmGram/ShowChord.hs +++ /dev/null @@ -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 ']' diff --git a/MIR/HarmGram/Tokenizer.hs b/MIR/HarmGram/Tokenizer.hs deleted file mode 100644 --- a/MIR/HarmGram/Tokenizer.hs +++ /dev/null @@ -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) diff --git a/MIR/HarmGram/TypeLevel.hs b/MIR/HarmGram/TypeLevel.hs deleted file mode 100644 --- a/MIR/HarmGram/TypeLevel.hs +++ /dev/null @@ -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) diff --git a/MIR/Instances.hs b/MIR/Instances.hs deleted file mode 100644 --- a/MIR/Instances.hs +++ /dev/null @@ -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) diff --git a/MIR/Matching/GDiff.hs b/MIR/Matching/GDiff.hs deleted file mode 100644 --- a/MIR/Matching/GDiff.hs +++ /dev/null @@ -1,4 +0,0 @@ - -module MIR.Matching.GDiff (module Generics.Instant.GDiff) where - -import Generics.Instant.GDiff diff --git a/MIR/Matching/Standard.hs b/MIR/Matching/Standard.hs deleted file mode 100644 --- a/MIR/Matching/Standard.hs +++ /dev/null @@ -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 diff --git a/MIR/Run.hs b/MIR/Run.hs deleted file mode 100644 --- a/MIR/Run.hs +++ /dev/null @@ -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 diff --git a/Main.hs b/Main.hs deleted file mode 100644 --- a/Main.hs +++ /dev/null @@ -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] diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 diff --git a/Text/ParserCombinators/UU.hs b/Text/ParserCombinators/UU.hs deleted file mode 100644 --- a/Text/ParserCombinators/UU.hs +++ /dev/null @@ -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 - - diff --git a/Text/ParserCombinators/UU/BasicInstances.hs b/Text/ParserCombinators/UU/BasicInstances.hs deleted file mode 100644 --- a/Text/ParserCombinators/UU/BasicInstances.hs +++ /dev/null @@ -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 diff --git a/Text/ParserCombinators/UU/BasicInstances/List.hs b/Text/ParserCombinators/UU/BasicInstances/List.hs deleted file mode 100644 --- a/Text/ParserCombinators/UU/BasicInstances/List.hs +++ /dev/null @@ -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 diff --git a/Text/ParserCombinators/UU/BasicInstances/String.hs b/Text/ParserCombinators/UU/BasicInstances/String.hs deleted file mode 100644 --- a/Text/ParserCombinators/UU/BasicInstances/String.hs +++ /dev/null @@ -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) diff --git a/Text/ParserCombinators/UU/Core.hs b/Text/ParserCombinators/UU/Core.hs deleted file mode 100644 --- a/Text/ParserCombinators/UU/Core.hs +++ /dev/null @@ -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 - - - - - - diff --git a/Text/ParserCombinators/UU/Derived.hs b/Text/ParserCombinators/UU/Derived.hs deleted file mode 100644 --- a/Text/ParserCombinators/UU/Derived.hs +++ /dev/null @@ -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 p)], id)) - else (MergeSpec ([] ,[Between n m ((:) <$> p)], id))) - -pAtMost :: Int -> P t t1 -> MergeSpec ([a], [Freq (P t ([t1] -> [t1]))], a1 -> a1) -pAtMost n p = must_be_non_empty "pOpt" p - (if n <= 0 then (MergeSpec ([] ,[ ], id)) - else (MergeSpec ([] ,[AtMost n ((:) <$> p)], id))) - -pAtLeast :: Int -> P t t1 -> MergeSpec ([a], [Freq (P t ([t1] -> [t1]))], a1 -> a1) -pAtLeast n p = must_be_non_empty "pOpt" p - (if n <= 0 then (MergeSpec ([] ,[Many ((:) <$> p)], id)) - else (MergeSpec ([] ,[AtLeast n ((:) <$> p)], id))) - -pMany :: P t t1 -> MergeSpec ([a], [Freq (P t ([t1] -> [t1]))], a1 -> a1) -pMany p = must_be_non_empty "pMany" p (MergeSpec ([] ,[Many ((:) <$> p)], id)) - -pOpt :: P t t1 -> t11 -> MergeSpec (t11, [Freq (P t (b -> t1))], a -> a) -pOpt p v = must_be_non_empty "pOpt" p (MergeSpec (v ,[Opt (const <$> p)], id)) - -pSome :: P t t1 -> MergeSpec ([a], [Freq (P t ([t1] -> [t1]))], a1 -> a1) -pSome p = must_be_non_empty "pSome" p (MergeSpec ([] ,[AtLeast 1 ((:) <$> p)], id)) - -pOne :: P t t1 -> MergeSpec (a, [Freq (P t (b -> t1))], a1 -> a1) -pOne p = must_be_non_empty "pOne" p (MergeSpec (undefined,[One (const <$> p)], id)) - -mapFst :: (t -> t2) -> (t, t1) -> (t2, t1) -mapFst f (a, b) = (f a, b) - -mapSnd :: (t1 -> t2) -> (t, t1) -> (t, t2) -mapSnd f (a, b) = (a, f b) - diff --git a/Text/ParserCombinators/UU/Parsing.hs b/Text/ParserCombinators/UU/Parsing.hs deleted file mode 100644 --- a/Text/ParserCombinators/UU/Parsing.hs +++ /dev/null @@ -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 diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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]