ParserChord.hs

{-# 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...