Parser.hs

{-# LANGUAGE TypeOperators          #-}
{-# LANGUAGE TypeSynonymInstances   #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE OverlappingInstances   #-}
{-# LANGUAGE ScopedTypeVariables    #-}

-- Semi-generic parser for chords
module HarmTrace.Model.Parser where


-- Parser stuff
import Text.ParserCombinators.UU
import Text.ParserCombinators.UU.BasicInstances

-- Generics stuff
import Generics.Instant.Base as G

-- Music stuff
import HarmTrace.Tokenizer.Tokens


--------------------------------------------------------------------------------
-- The generic part of the parser
--------------------------------------------------------------------------------

type PMusic a = P (Str ChordToken [ChordToken] Int) a

class Parse' f where
   parse' :: PMusic f

instance Parse' U where
  parse' = pure U

instance (ParseG a) => Parse' (Rec a) where
  parse' = Rec <$> parseG

-- Not really necessary because TH is not generating any Var, but anyway
instance (ParseG a) => Parse' (Var a) where
  parse' = Var <$> parseG

instance (Constructor c, Parse' f) => Parse' (G.CEq c p p f) where
  parse' = G.C <$> parse' <?> "Constructor " ++ conName (undefined :: C c f)

instance                              Parse' (G.CEq c p q f) where 
  parse' = empty

instance (Parse' f, Parse' g) => Parse' (f :+: g) where
  parse' = L <$> parse' <|> R <$> parse'

instance (Parse' f, Parse' g) => Parse' (f :*: g) where
  parse' = (:*:) <$> parse' <*> parse'


class ParseG a where
  parseG :: PMusic a

instance (ParseG a) => ParseG [a] where
  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
  parseG = pMaybe parseG

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