Instances.hs

{-# OPTIONS_GHC -Wall -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 GADTs                  #-}
{-# LANGUAGE DataKinds              #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  HarmTrace.Models.Simple.Instances
-- Copyright   :  (c) 2010-2012 Universiteit Utrecht, 2012 University of Oxford
-- License     :  GPL3
--
-- Maintainer  :  bash@cs.uu.nl, jpm@cs.ox.ac.uk
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Summary: Adhoc instances for the Simple model
--------------------------------------------------------------------------------

module HarmTrace.Models.Simple.Instances where

-- Generics stuff
import Generics.Instant.TH

-- Parser stuff
import Text.ParserCombinators.UU hiding ((<$$>), (<**>))
import Text.ParserCombinators.UU.BasicInstances

-- Music stuff
import HarmTrace.Models.Collect
import HarmTrace.Models.Parser
import HarmTrace.Models.Generator
import HarmTrace.Models.Simple.Model
import HarmTrace.HAnTree.Tree
import HarmTrace.HAnTree.ToHAnTree
import HarmTrace.HAnTree.HAn
import HarmTrace.Models.ChordTokens as CT
import HarmTrace.Base.MusicRep

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

instance ( ToDegree deg, ToClass clss
         ) => ParseG (Surface_Chord deg clss) where
  parseG = pChord deg clss
    where deg = toDegree (Proxy :: Proxy deg)
          clss = toClass (Proxy :: Proxy clss)
          
-- generic ad-hoc parser that forms the bridge between the type-level and
-- value-level representation        
pChord :: ScaleDegree -> ClassType -> PMusic (Surface_Chord deg clss)
-- Do not parse Imp degrees
pChord (Note _ Imp) _clss = empty
-- General case
pChord deg clss = setStatus <$> pSatisfy recognize insertion where
  {-# INLINE recognize #-}
  recognize ct = deg == root ct && clss == classType ct
  
  {-# INLINE setStatus #-}
  setStatus c = case status c of
    NotParsed -> Surface_Chord c {status = Parsed}
    _         -> Surface_Chord c 
  
  insertion = Insertion "ChordToken" (ChordToken deg clss [] CT.Inserted 1 0) 5

--------------------------------------------------------------------------------
-- The non-generic part of the collector
--------------------------------------------------------------------------------

instance CollectG (Phrase mode) ChordToken where collectG = collectGdefault
instance CollectG (Ton    mode) ChordToken where collectG = collectGdefault
instance CollectG (SDom   mode) ChordToken where collectG = collectGdefault
instance CollectG (Dom    mode) ChordToken where collectG = collectGdefault

instance CollectG (Surface_Chord deg clss) ChordToken where
  collectG (Surface_Chord x) = [x]

--------------------------------------------------------------------------------
-- The non-generic part of the generator
--------------------------------------------------------------------------------

instance ( ToDegree deg, ToClass clss
         ) => GenerateG (Surface_Chord deg clss) where
  genG _ _ = genChord deg clss
    where deg = toDegree (Proxy :: Proxy deg)
          clss = toClass (Proxy :: Proxy clss)

genChord :: ScaleDegree -> ClassType -> Maybe (Gen (Surface_Chord deg clss))
genChord (Note _ Imp) _    = Nothing
genChord deg          clss = Just . return . Surface_Chord
                           $ ChordToken deg clss [] CT.Parsed 1 0

--------------------------------------------------------------------------------
-- The non-generic part of the GTree wrapper
--------------------------------------------------------------------------------

instance GTree Piece where -- we take the children to skip a "list node"
  gTree (Piece p) = [Node (HAnFunc P) (gTree p) Nothing]

instance GTree (Surface_Chord deg clss) where
  gTree (Surface_Chord c) = [Node (HAnChord c) [] Nothing]

--------------------------------------------------------------------------------
-- Instances of Representable for music datatypes
--------------------------------------------------------------------------------

deriveAllL allTypes

$(fmap join $ mapM (\t -> gadtInstance ''ParseG t 'parseG 'parseGdefault)
  allTypes)

$(fmap join $ mapM (\t -> gadtInstance ''GenerateG t 'genG 'genGdefault)
  allTypes)

$(fmap join $ mapM (\t -> simplInstance ''GTree t 'gTree 'gTreeDefault)
  allTypes)

--------------------------------------------------------------------------------
-- ChordToken as tokens
--------------------------------------------------------------------------------

instance IsLocationUpdatedBy Int ChordToken where 
  advance p c = p + chordNumReps c