{-# LANGUAGE TypeOperators, OverloadedStrings, GeneralizedNewtypeDeriving #-}

-------------------------------------------------------------------------------------
-- |
-- Copyright   : (c) Hans Hoglund 2012
--
-- License     : BSD-style
--
-- Maintainer  : hans@hanshoglund.se
-- Stability   : experimental
-- Portability : portable
--
-- A Haskell representation and parser for ABC notation. Based on the 2.1 standard.
--
-- For more information see <http://abcnotation.com>.
--
-------------------------------------------------------------------------------------

-- TODO compare https://github.com/sergi/abcnode/blob/master/parser.pegjs

module Music.Abc (

        ----------------------------------------------------------------------

        -- * Abc format
        -- ** Files
        AbcFile(..),

        -- *** File header
        FileHeader(..),
        Element(..),

        -- ** Tunes
        AbcTune(..),
        TuneHeader(..),
        TuneBody(..),

        ----------------------------------------------------------------------

        -- * Music
        Music(..),
        Chord(..),
        Barline(..),
        Annotation(..),
        ChordSymbol(..),
        Decoration(..),
        Dynamic(..),

        -- ** Time
        Duration(..),
        Meter(..),
        Tempo(..),

        -- ** Pitch
        PitchClass(..),
        Accidental(..),
        Octave(..),
        Pitch(..),
        Key(..),
        StemDirection(..),
        Clef(..),
        Mode(..),

        ----------------------------------------------------------------------

        -- * Information
        Information(..),
        Directive(..),
        VoiceProperties(..),

        ----------------------------------------------------------------------

        -- * Import and export
        readAbc,
        showAbc
  ) where

import Data.Maybe
import Data.Ratio
import Data.Char
import Data.Semigroup
import Text.Pretty hiding (Mode)


--------------------------------------------------------------------------------

-- File structure


-- | A full ABC file (2.2).
data AbcFile
    = AbcFile
        (Maybe String)
        (Maybe FileHeader)
        [Element]
    deriving (Eq, Ord, Show)

instance Pretty AbcFile where
    pretty (AbcFile version header elements) = mempty
        <> "%abc-" <> string (fromMaybe "2.1" version) <> "\n"
        <> pretty header <> "\n"
        <> sepBy "\n" (fmap pretty elements) <> "\n"
    
    
-- | File header (2.2.2).
data FileHeader
    = FileHeader
        [Information]
        [Directive]
    deriving (Eq, Ord, Show)

instance Pretty FileHeader where
    pretty (FileHeader info directives) = mempty
        <> sepBy "\n" (fmap pretty info) <> "\n"
        <> sepBy "\n" (fmap pretty directives)


-- | Either a tune, free text or typeset text (2.2.3).
data Element
    = Tune
        AbcTune                         -- ^ An Abc tune.
    | FreeText
        String                          -- ^ Free text (2.2.3).
    | TypesetText
        String                          -- ^ Typeset text (2.2.3).
    deriving (Eq, Ord, Show)

instance Pretty Element where
    pretty (Tune a)         = pretty a
    pretty (FreeText a)     = string a
    pretty (TypesetText a)  = string a


data AbcTune
    = AbcTune
        TuneHeader
        TuneBody
    deriving (Eq, Ord, Show)

instance Pretty AbcTune where
    pretty (AbcTune header elements) = mempty
        <> pretty header <> "\n"
        <> sepBy "\n" (fmap pretty elements) <> "\n"


data TuneHeader
    = TuneHeader
        [Information]
    deriving (Eq, Ord, Show)

instance Pretty TuneHeader where
    pretty (TuneHeader info) =
        sepBy "\n" (fmap pretty info)


-- | One line of music code.
type TuneBody 
    = [Music]


--------------------------------------------------------------------------------

-- Music


-- | One line of music code.
data Music
    = Chord Chord
    | Barline Barline
    | Tie Music
    | Slur Music
    | Beam Music
    | Grace Music
    | Tuplet Duration Music
    | Decorate Decoration Music
    | Annotate Annotation Music
    | ChordSymbol ChordSymbol Music
    | Sequence [Music] -- beam? music
    deriving (Eq, Ord, Show)

instance Pretty Music where
    pretty = go
        where
            go (Chord a) = pretty a
    -- FIXME


data Annotation
    = AnnotateLeft String
    | AnnotateRight String
    | AnnotateAbove String
    | AnnotateBelow String
    | AnnotateUnspecified String
    deriving (Eq, Ord, Show)
    
-- TODO clefs and transposition (4.6)
-- TODO redifinable symbols (4.16)
-- TODO symbol lines (4.15)
-- TODO symbol lyrics

-- Note (4.20) 
newtype Chord = Chord_ { getChord :: (
        [Pitch],
        (Maybe Duration)
    ) }
    deriving (Eq, Ord, Show)

instance Pretty Chord where
    -- TODO skip duration if zero
    pretty (Chord_ ([], dur))       = ""
    pretty (Chord_ ([pitch], dur))  =
        pretty pitch <> pretty dur
    pretty (Chord_ (pitches, dur))  =
        brackets (sepBy "" (fmap pretty pitches)) <> pretty dur


type ChordSymbol 
    = String

-- | Barline, including special barlines and repeats.
data Barline
    = SingleBarline
    | DoubleBarline Bool Bool           -- thick? thick?
    | Repeat Int Bool Bool              -- times end? begin?
    | DottedBarline Barline
    | InvisibleBarline Barline
    deriving (Eq, Ord, Show)

-- TODO first and second repeats (4.9)
-- TODO variant endings (4.10)


-- | Decorations (4.14)
data Decoration
    = Trill                   -- "tr" (trill mark)
    | TrillBegin              -- start of an extended trill
    | TrillEnd                -- end of an extended trill
    | Lowermordent            -- short squiggle with a vertical line through it
    | Uppermordent            -- short squiggle
    | Roll                    -- a roll mark (arc) as used in Irish music
    | Turn                    -- a turn mark (also known as gruppetto)
    | Turnx                   -- a turn mark with a line through it
    | Invertedturn            -- an inverted turn mark
    | Invertedturnx           -- an inverted turn mark with a line through it
    | Arpeggio                -- vertical squiggle
    | Accent                  -- accent mark
    | Fermata Bool            -- fermata or hold (arc above dot), inverted?
    | Tenuto                  -- horizontal line to indicate holding note for full duration
    | Fingering Int           -- fingerings
    | Plus                    -- left-hand pizzicato, or rasp for French horns
    | Snap                    -- snap-pizzicato mark, visually similar to !thumb!
    | Slide                   -- slide up to a note, visually similar to a half slur
    | Wedge                   -- small filled-in wedge mark
    | Upbow                   -- V mark
    | Downbow                 -- squared n mark
    | Open                    -- small circle above note indicating open string or harmonic
    | Thumb                   -- cello thumb symbol
    | Breath                  -- a breath mark (apostrophe-like) after note
    | Dynamic Dynamic         -- Dynamics
    | Crescendo               -- start of a crescendo mark
    | EndCrescendo            -- end of a crescendo mark, placed after the last note
    | Diminuendo              -- start of a diminuendo mark
    | EndDiminuendo           -- end of a diminuendo mark, placed after the last note
    | Segno                   -- ornate s-like symbols separated by a diagonal line
    | Coda                    -- a ring with a cross in it
    | DaSegno                 -- the letters D.S. (=Da Segno)
    | DaCapo                  -- the letters D.C. (=either Da Coda or Da Capo)
    | Dacoda                  -- the word "Da" followed by a Coda sign
    | Fine                    -- the word "fine"
    | Shortphrase             -- vertical line on the upper part of the staff
    | Mediumphrase            -- same, but extending down to the centre line
    | Longphrase              -- same, but extending 3/4 of the way down
    deriving (Eq, Ord, Show)

data Dynamic
    = PPPP
    | PPP
    | PP
    | P_
    | MP
    | MF
    | F_
    | FF
    | FFF
    | FFFF
    | SFZ
    deriving (Eq, Ord, Show)


--------------------------------------------------------------------------------

-- Information


-- | An information field (3).
data Information
    = Area String
    | Book String
    | Composer String
    | Discography String
    | FileUrl String
    | Group String
    | History String
    | Instruction Directive
    | Key Key
    | UnitNoteLength Duration
    | Meter Meter            
    | Macro                             -- ^ Macro (not supported)
    | Notes String                      -- ^ Notes
    | Origin String                     -- ^ Origin of tune.
    | Parts
    | Tempo Tempo                       -- ^ Tempo of tune.
    | Rhythm String                     -- ^ Rhythm type of tune.
    | Remark                            -- ^ Remarks (not supported)
    | Source String                     -- ^ Source material.
    | SymbolLine
    | Title String                      -- ^ Title of tune.
    | UserDefined                       -- ^ User defined (not supported)
    | Voice VoiceProperties
    | Words String
    | ReferenceNumber Integer
    | Transcription String
    deriving (Eq, Ord, Show)

instance Pretty Information where
    pretty a = string $ fieldName a ++ ": " ++ showField a


fieldName :: Information -> String
fieldName = go
    where
        go (Area _)                 = "A"
        go (Book _)                 = "B"
        go (Composer _)             = "C"
        go (Discography _)          = "D"
        go (FileUrl _)              = "F"
        go (Group _)                = "G"
        go (History _)              = "H"
        go (Instruction _)          = "I"
        go (Key _)                  = "K"
        go (UnitNoteLength _)       = "L"
        go (Meter _)                = "M"
        go Macro                    = "m"
        go (Notes _)                = "N"
        go (Origin _)               = "O"
        go Parts                    = "O"
        go (Tempo _)                = "Q"
        go (Rhythm _)               = "R"
        go Remark                   = "r"
        go (Source _)               = "S"
        go SymbolLine               = "s"
        go (Title _)                = "T"
        go UserDefined              = "U"
        go (Voice _)                = "V"
        go (Words _)                = "W"
        go (ReferenceNumber _)      = "X"
        go (Transcription _)        = "Z"

-- (file header, tune header, tune body, inline)
fieldAllowed :: Information -> (Bool, Bool, Bool, Bool)
fieldAllowed = go
    where
        go (Area _)                 = (True, True, False, False)
        go (Book _)                 = (True, True, False, False)
        go (Composer _)             = (True, True, False, False)
        go (Discography _)          = (True, True, False, False)
        go (FileUrl _)              = (True, True, False, False)
        go (Group _)                = (True, True, False, False)
        go (History _)              = (True, True, False, False)
        
        go (Instruction _)          = (True, True, True, True)
        go (Key _)                  = (False, True{-last-}, True, True)
        go (UnitNoteLength _)       = (True, True, True, True)
        go (Meter _)                = (True, True, True, True)
        go Macro                    = (True, True, True, True)
        go (Notes _)                = (True, True, True, True)
        
        go (Origin _)               = (True, True, False, False)
        go Parts                    = (False, True, True, True)
        go (Tempo _)                = (False, True, True, True)
        go (Rhythm _)               = (True, True, True, True)
        go Remark                   = (True, True, True, True)
        
        go (Source _)               = (True, True, False, False)
        go SymbolLine               = (False, False, True, False)
        go (Title _)                = (False, True{-second-}, True, False)
        
        go UserDefined              = (True, True, True, True)
        go (Voice _)                = (False, True, True, True)
        go (Words _)                = (False, True, True, False)
        go (ReferenceNumber _)      = (False, True{-first-}, True, False)
        go (Transcription _)        = (True, True, False, False)

fieldAllowedInFileHeader a = r where (r,_,_,_) = fieldAllowed a
fieldAllowedInTuneHeader a = r where (_,r,_,_) = fieldAllowed a
fieldAllowedInTuneBody   a = r where (_,_,r,_) = fieldAllowed a
fieldAllowedInline       a = r where (_,_,_,r) = fieldAllowed a

showField :: Information -> String
showField = go
    where
        go (Area a)                 = a
        go (Book a)                 = a
        go (Composer a)             = a
        go (Discography a)          = a
        go (FileUrl a)              = a
        go (Group a)                = a
        go (History a)              = a
        go (Instruction a)          = show $ pretty a
        go (Key a)                  = show $ pretty a
        go (UnitNoteLength a)       = show $ pretty a
        go (Meter a)                = show $ pretty a
        go Macro                    = ""
        go (Notes a)                = a
        go (Origin a)               = a
        go Parts                    = "" -- TODO
        go (Tempo a)                = show $ pretty a
        go (Rhythm a)               = a
        go Remark                   = "" -- TODO
        go (Source a)               = a
        go SymbolLine               = "" -- TODO
        go (Title a)                = a
        go UserDefined              = "" -- TODO
        go (Voice a)                = show $ pretty a
        go (Words a)                = a
        go (ReferenceNumber a)      = show a
        go (Transcription a)        = a
        

--------------------------------------------------------------------------------

-- Base types

-- | Pitch (4.1, 4.2).
newtype Pitch = Pitch { getPitch :: (PitchClass, Maybe Accidental, Octave) }
    deriving (Eq, Ord, Show)

instance Pretty Pitch where
    pretty (Pitch (cl, acc, oct)) = pretty acc <> (string $
        (if oct <= 0 then id else fmap toLower) (show cl)
        ++ replicate (negate (fromIntegral oct) `max` 0) ','
        ++ replicate (fromIntegral (oct - 1) `max` 0) '\'')

-- | Pitch class (4.1).
data PitchClass = C | D | E | F | G | A | B
    deriving (Eq, Ord, Show, Enum, Bounded)

-- | Accidentals (4.2).
data Accidental = DoubleFlat | Flat | Natural | Sharp | DoubleSharp
    deriving (Eq, Ord, Show, Enum, Bounded)

instance Pretty Accidental where
    pretty = go
        where
            go DoubleFlat   = "__"
            go Flat         = "_"
            go Natural      = "="
            go Sharp        = "^"
            go DoubleSharp  = "^^"

-- | Octaves (4.1).
newtype Octave = Octave { getOctave :: Int }
    deriving (Eq, Ord, Show, Enum, Num, Real, Integral)






-- | Duration (4.3).
newtype Duration = Duration { getDuration :: Rational }
    deriving (Eq, Ord, Show, Enum, Num, Real, Fractional, RealFrac)

instance Pretty Duration where
    pretty = string . showRatio . getDuration

            
data Meter
    = NoMeter
    | Common
    | Cut
    | Simple Rational
    | Compound [Integer] Integer
    deriving (Eq, Ord, Show)

instance Pretty Meter where
    pretty = go
        where
            go Common           = "C"
            go Cut              = "C|"
            go (Simple a)       = string $ showRatio a
            go (Compound as a)  = sepBy "+" (fmap integer as) <> "/" <> integer a








newtype Key = Key_ (Integer, Mode)
    deriving (Eq, Ord, Show)

instance Pretty Key where
    pretty (Key_ (tonic, mode)) = prettyTonic tonic <+> pretty mode
        where
            prettyTonic a = case a of
                0 -> "C"

data Mode
    = Major
    | Minor
    | Ionian
    | Dorian
    | Phrygian
    | Lydian
    | Mixolydian
    | Aeolian
    | Locrian
    deriving (Eq, Ord, Show)

instance Pretty Mode where
    pretty = go
        where
            go Major        = ""
            go Minor        = "minor"
            go Ionian       = "ionian"
            go Dorian       = "dorian"
            go Phrygian     = "phrygian"
            go Lydian       = "lydian"
            go Mixolydian   = "mixolydian"
            go Aeolian      = "aeolian"
            go Locrian      = "locrian"




-- | Optional string, numerators, frequency (3.1.8)
newtype Tempo = Tempo_ { getTempo :: (Maybe String, [Duration], Duration) }
    deriving (Eq, Ord, Show)

instance Pretty Tempo where
    pretty (Tempo_ (str, durs, bpm)) = 
        pretty str <+> (hsep (fmap pretty durs) <> "=" <> pretty bpm)

data VoiceProperties
    = VoiceProperties
        (Maybe String)
        (Maybe String)
        (Maybe StemDirection)
        (Maybe Clef)
    deriving (Eq, Ord, Show)

instance Pretty VoiceProperties where
    pretty _ = "{VoiceProperties}"
    -- FIXME

data StemDirection = Up | Down
    deriving (Eq, Ord, Show, Enum, Bounded)

data Clef = NoClef | Treble | Alto | Tenor | Bass | Perc
    deriving (Eq, Ord, Show, Enum, Bounded)


-- | Abc directive.
newtype Directive = Directive { getDirective :: (String, String) }
    deriving (Eq, Ord, Show)

instance Pretty Directive where
    pretty _ = "{Directive}"
    -- FIXME



--------------------------------------------------------------------------------

-- Utility

readAbc :: String -> AbcFile
readAbc = error "Not impl"

showAbc :: AbcFile -> String
showAbc = error "Not impl"


--------------------------------------------------------------------------------

-- Tests

{-
    
    X:19004
    T:Silent Night
    T:Stille Nacht! Heilige Nacht!
    R:Air
    C:Franz Xaver Gruber, 1818
    O:Austria
    Z:Paul Hardy's Xmas Tunebook 2012 (see www.paulhardy.net). Creative Commons cc by-nc-sa licenced.
    M:6/8
    L:1/8
    Q:3/8=60
    K:C
    "C"G>A G E3|G>A G E2z|"G"d2 d B3|"C"c2 c G2z|
    "F"A2 A c>B A|"C"G>A G E2z|"F"A2 A c>B A|"C"G>A G E2z|
    "G7"d2 d f>d B|"C"c3 e2z|cGE "G7"G>F D|"C"C3-C3|]
    W:Silent night, holy night
    W:All is calm, all is bright
    W:Round yon Virgin Mother and Child
    W:Holy Infant so tender and mild
    W:Sleep in heavenly peace
    W:Sleep in heavenly peace
    W:
    W:(Josef Mohr, 1818, Trans by John Young, 1819)
    
-}
test = AbcFile 
    (Just "1.2")
    (Just $ FileHeader [
        Title "Collection"        
    ] []) 
    [
        Tune (AbcTune 
            (TuneHeader [
                ReferenceNumber     19004,
                Title               "Silent Night",
                Title               "Stille Nacht! Heilige Nacht!",
                Rhythm              "Air",
                Composer            "Franz Xaver Gruber, 1818",
                Origin              "Austria",
                Source              "Paul Hardy's Xmas Tunebook 2012",
                Meter               (Simple $ 6/8),
                UnitNoteLength      (1/8),
                Tempo               (Tempo_ (Just "Andante", [3/8], 60)),
                Key                 (Key_ (0, Minor)),            

                Words               "Silent night, holy night",
                Words               "All is calm, all is bright",
                Words               "Round yon Virgin Mother and Child",
                Words               "Holy Infant so tender and mild",
                Words               "Sleep in heavenly peace",
                Words               "Sleep in heavenly peace"
            ]) 
            [
                Chord (Chord_ ([(Pitch (C,Just Sharp,0))], Just 1))
            ])

    ]

main = (putStrLn . show . pretty) test






showRatio :: (Integral a, Show a) => Ratio a -> String
showRatio x
    | denominator x == 1  = show (numerator x)
    | otherwise           = (show $ numerator x) ++ "/" ++ (show $ denominator x)