{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- |
-- Module      : Harmonic.Rules.Import.CSV
-- Description : CSV parsing for YCACL corpus ingestion
--
-- Parses Yale Classical Archives Corpus data from CSV format into
-- typed Haskell records for downstream transformation and graph storage.

module Harmonic.Rules.Import.CSV (
    -- * Corpus rows
    YCACLRow(..),

    -- * Nested corpus map
    ComposerId, PieceId, YCACLData,

    -- * Loading
    loadYCACLData,
) where

import           Harmonic.Rules.Import.Types
import qualified Data.Csv as Csv
import qualified Data.ByteString.Lazy as BL
import qualified Data.Vector as V
import           Data.Csv ((.:))
import           Control.Monad (mzero)
import qualified Data.Text as T
import qualified Data.Map.Strict as Map
import           Data.List (foldl', sortOn)
import           Text.Read (readMaybe)

-- | One row of the YCACL artifact exported by @scripts\/export_ycacl.R@.
--
-- The CSV carries pitches as a space-separated string in a single column; the
-- 'Csv.FromNamedRecord' instance splits and parses that into 'yrPitches'.
data YCACLRow = YCACLRow
  { YCACLRow -> ComposerId
yrComposer    :: !T.Text   -- ^ composer name as it appears in the corpus
  , YCACLRow -> ComposerId
yrPiece       :: !T.Text   -- ^ piece identifier, unique within a composer
  , YCACLRow -> Int
yrOrder       :: !Int      -- ^ position of this slice within the piece
  , YCACLRow -> [Int]
yrPitches     :: ![Int]    -- ^ MIDI pitches sounding at this slice
  , YCACLRow -> Int
yrFundamental :: !Int      -- ^ fundamental detected for the slice
  } deriving (Int -> YCACLRow -> ShowS
[YCACLRow] -> ShowS
YCACLRow -> [Char]
(Int -> YCACLRow -> ShowS)
-> (YCACLRow -> [Char]) -> ([YCACLRow] -> ShowS) -> Show YCACLRow
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> YCACLRow -> ShowS
showsPrec :: Int -> YCACLRow -> ShowS
$cshow :: YCACLRow -> [Char]
show :: YCACLRow -> [Char]
$cshowList :: [YCACLRow] -> ShowS
showList :: [YCACLRow] -> ShowS
Show, YCACLRow -> YCACLRow -> Bool
(YCACLRow -> YCACLRow -> Bool)
-> (YCACLRow -> YCACLRow -> Bool) -> Eq YCACLRow
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: YCACLRow -> YCACLRow -> Bool
== :: YCACLRow -> YCACLRow -> Bool
$c/= :: YCACLRow -> YCACLRow -> Bool
/= :: YCACLRow -> YCACLRow -> Bool
Eq)

instance Csv.FromNamedRecord YCACLRow where
  parseNamedRecord :: NamedRecord -> Parser YCACLRow
parseNamedRecord NamedRecord
m = do
    ComposerId
composer <- NamedRecord
m NamedRecord -> ByteString -> Parser ComposerId
forall a. FromField a => NamedRecord -> ByteString -> Parser a
.: ByteString
"composer"
    ComposerId
piece    <- NamedRecord
m NamedRecord -> ByteString -> Parser ComposerId
forall a. FromField a => NamedRecord -> ByteString -> Parser a
.: ByteString
"piece"
    Int
orderVal <- NamedRecord
m NamedRecord -> ByteString -> Parser Int
forall a. FromField a => NamedRecord -> ByteString -> Parser a
.: ByteString
"order"
    ComposerId
pitchTxt :: T.Text <- NamedRecord
m NamedRecord -> ByteString -> Parser ComposerId
forall a. FromField a => NamedRecord -> ByteString -> Parser a
.: ByteString
"pitches"
    [Int]
pitches  <- ComposerId -> Parser [Int]
forall {m :: * -> *} {b}.
(Read b, MonadPlus m) =>
ComposerId -> m [b]
parsePitchList ComposerId
pitchTxt
    Int
fund     <- NamedRecord
m NamedRecord -> ByteString -> Parser Int
forall a. FromField a => NamedRecord -> ByteString -> Parser a
.: ByteString
"fundamental"
    YCACLRow -> Parser YCACLRow
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ComposerId -> ComposerId -> Int -> [Int] -> Int -> YCACLRow
YCACLRow ComposerId
composer ComposerId
piece Int
orderVal [Int]
pitches Int
fund)
    where
      parsePitchList :: ComposerId -> m [b]
parsePitchList ComposerId
txt =
        let tokens :: [ComposerId]
tokens = ComposerId -> [ComposerId]
T.words ComposerId
txt
        in (ComposerId -> m b) -> [ComposerId] -> m [b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ComposerId -> m b
forall {a} {f :: * -> *}.
(Read a, MonadPlus f) =>
ComposerId -> f a
toInt [ComposerId]
tokens
      toInt :: ComposerId -> f a
toInt ComposerId
chunk =
        case [Char] -> Maybe a
forall a. Read a => [Char] -> Maybe a
readMaybe (ComposerId -> [Char]
T.unpack ComposerId
chunk) of
          Just a
n  -> a -> f a
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
n
          Maybe a
Nothing -> f a
forall a. f a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

-- | Composer name, used as the outer key of 'YCACLData'. Case is preserved
-- here; composer /matching/ is case-insensitive and happens downstream.
type ComposerId = T.Text

-- | Piece identifier, unique within one composer.
type PieceId = T.Text

-- | The whole corpus, grouped composer then piece, with each piece reduced to
-- its ordered list of slices.
type YCACLData = Map.Map ComposerId (Map.Map PieceId [ChordSlice])

-- |Load YCACL artifact (composer, piece, order, pitches, fundamental) into nested maps.
loadYCACLData :: FilePath -> IO YCACLData
loadYCACLData :: [Char] -> IO YCACLData
loadYCACLData [Char]
fp = do
  ByteString
csvData <- [Char] -> IO ByteString
BL.readFile [Char]
fp
  case ByteString -> Either [Char] (Header, Vector YCACLRow)
forall a.
FromNamedRecord a =>
ByteString -> Either [Char] (Header, Vector a)
Csv.decodeByName ByteString
csvData of
    Left [Char]
err ->
      [Char] -> IO YCACLData
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO YCACLData) -> [Char] -> IO YCACLData
forall a b. (a -> b) -> a -> b
$ [Char]
"YCACL artifact parse error: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
err
    Right (Header
_, Vector YCACLRow
rows) ->
      let grouped :: Map ComposerId (Map ComposerId [(Int, ChordSlice)])
grouped = (Map ComposerId (Map ComposerId [(Int, ChordSlice)])
 -> YCACLRow -> Map ComposerId (Map ComposerId [(Int, ChordSlice)]))
-> Map ComposerId (Map ComposerId [(Int, ChordSlice)])
-> [YCACLRow]
-> Map ComposerId (Map ComposerId [(Int, ChordSlice)])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map ComposerId (Map ComposerId [(Int, ChordSlice)])
-> YCACLRow -> Map ComposerId (Map ComposerId [(Int, ChordSlice)])
accumulate Map ComposerId (Map ComposerId [(Int, ChordSlice)])
forall k a. Map k a
Map.empty (Vector YCACLRow -> [YCACLRow]
forall a. Vector a -> [a]
V.toList Vector YCACLRow
rows)
       in YCACLData -> IO YCACLData
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (YCACLData -> IO YCACLData) -> YCACLData -> IO YCACLData
forall a b. (a -> b) -> a -> b
$ (Map ComposerId [(Int, ChordSlice)] -> Map ComposerId [ChordSlice])
-> Map ComposerId (Map ComposerId [(Int, ChordSlice)]) -> YCACLData
forall a b. (a -> b) -> Map ComposerId a -> Map ComposerId b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([(Int, ChordSlice)] -> [ChordSlice])
-> Map ComposerId [(Int, ChordSlice)]
-> Map ComposerId [ChordSlice]
forall a b. (a -> b) -> Map ComposerId a -> Map ComposerId b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Int, ChordSlice)] -> [ChordSlice]
forall {a} {b}. Ord a => [(a, b)] -> [b]
finalize) Map ComposerId (Map ComposerId [(Int, ChordSlice)])
grouped
  where
    accumulate :: Map ComposerId (Map ComposerId [(Int, ChordSlice)])
-> YCACLRow -> Map ComposerId (Map ComposerId [(Int, ChordSlice)])
accumulate Map ComposerId (Map ComposerId [(Int, ChordSlice)])
acc YCACLRow
row =
      -- Each CSV row already has de-duplicated pitches and a trusted
      -- fundamental pitch class from the exporter; we simply preserve
      -- ordering information so pieces can be replayed in sequence.
      let composer :: ComposerId
composer = YCACLRow -> ComposerId
yrComposer YCACLRow
row
          piece :: ComposerId
piece    = YCACLRow -> ComposerId
yrPiece YCACLRow
row
          chord :: [Int]
chord    = YCACLRow -> [Int]
yrPitches YCACLRow
row
          fund :: Int
fund     = YCACLRow -> Int
yrFundamental YCACLRow
row
          slice :: ChordSlice
slice    = [Int] -> Int -> ChordSlice
ChordSlice [Int]
chord Int
fund
          orderVal :: Int
orderVal = YCACLRow -> Int
yrOrder YCACLRow
row
          updatePiece :: Maybe [(Int, ChordSlice)] -> Maybe [(Int, ChordSlice)]
updatePiece Maybe [(Int, ChordSlice)]
Nothing      = [(Int, ChordSlice)] -> Maybe [(Int, ChordSlice)]
forall a. a -> Maybe a
Just [(Int
orderVal, ChordSlice
slice)]
          updatePiece (Just [(Int, ChordSlice)]
items) = [(Int, ChordSlice)] -> Maybe [(Int, ChordSlice)]
forall a. a -> Maybe a
Just ((Int
orderVal, ChordSlice
slice)(Int, ChordSlice) -> [(Int, ChordSlice)] -> [(Int, ChordSlice)]
forall a. a -> [a] -> [a]
:[(Int, ChordSlice)]
items)
          updateComposer :: Maybe (Map ComposerId [(Int, ChordSlice)])
-> Maybe (Map ComposerId [(Int, ChordSlice)])
updateComposer Maybe (Map ComposerId [(Int, ChordSlice)])
Nothing   = Map ComposerId [(Int, ChordSlice)]
-> Maybe (Map ComposerId [(Int, ChordSlice)])
forall a. a -> Maybe a
Just (ComposerId
-> [(Int, ChordSlice)] -> Map ComposerId [(Int, ChordSlice)]
forall k a. k -> a -> Map k a
Map.singleton ComposerId
piece [(Int
orderVal, ChordSlice
slice)])
          updateComposer (Just Map ComposerId [(Int, ChordSlice)]
pieceMap) = Map ComposerId [(Int, ChordSlice)]
-> Maybe (Map ComposerId [(Int, ChordSlice)])
forall a. a -> Maybe a
Just ((Maybe [(Int, ChordSlice)] -> Maybe [(Int, ChordSlice)])
-> ComposerId
-> Map ComposerId [(Int, ChordSlice)]
-> Map ComposerId [(Int, ChordSlice)]
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe [(Int, ChordSlice)] -> Maybe [(Int, ChordSlice)]
updatePiece ComposerId
piece Map ComposerId [(Int, ChordSlice)]
pieceMap)
       in (Maybe (Map ComposerId [(Int, ChordSlice)])
 -> Maybe (Map ComposerId [(Int, ChordSlice)]))
-> ComposerId
-> Map ComposerId (Map ComposerId [(Int, ChordSlice)])
-> Map ComposerId (Map ComposerId [(Int, ChordSlice)])
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe (Map ComposerId [(Int, ChordSlice)])
-> Maybe (Map ComposerId [(Int, ChordSlice)])
updateComposer ComposerId
composer Map ComposerId (Map ComposerId [(Int, ChordSlice)])
acc
    finalize :: [(a, b)] -> [b]
finalize [(a, b)]
entries =
      -- Rows were appended as we streamed the CSV, so we re-sort by the
      -- original `order` column before dropping the index and returning
      -- the slice payloads.
      let ordered :: [(a, b)]
ordered = ((a, b) -> a) -> [(a, b)] -> [(a, b)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (a, b) -> a
forall a b. (a, b) -> a
fst [(a, b)]
entries
       in ((a, b) -> b) -> [(a, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> b
forall a b. (a, b) -> b
snd [(a, b)]
ordered