{-# LANGUAGE StrictData #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Worksheets.Utils.IPA (
  module Worksheets.Utils.IPA,
  module Language.IPA,
) where

import Data.Char qualified as Char
import Data.Text qualified as Text
import Language.IPA
import Worksheets.Utils.JSON qualified as JSON
import Worksheets.Utils.Prelude
import Prelude (error)

toIPA_ :: HasCallStack => ReprIPA a => a -> IPA
toIPA_ = toIPA >>> fromMaybe (error "toIPA_")

instance IsString (Syllable []) where
  fromString "" = Syllable []
  fromString s =
    fromString s
      & parseSyllable @[]
      & either errorShow id
instance Semigroup (Syllable []) where
  WithSuprasegmentalFeature f x <> y = x <> WithSuprasegmentalFeature f y
  Syllable x <> y = mergeSyl x y
    where
      mergeSyl s (WithSuprasegmentalFeature f t) =
        WithSuprasegmentalFeature f (mergeSyl s t)
      mergeSyl s (Syllable t) = Syllable (s <> t)
instance IsString Segment where
  fromString s =
    fromString s
      & parseSegment
      & either (error . show) id

ipaToText :: Syllable [] -> Text
ipaToText = toIPA_ >>> unIPA

type IPAWord = NonEmpty (Syllable [])
data IPAPhon
  = IPAPhonemic (NonEmpty IPAWord)
  | IPAPhonetic (NonEmpty IPAWord)
  | IPAPhonError (Text, [IPAException])
  deriving (Eq, Show)

newtype IPAPhons = IPAPhons {unIPAPhons :: [IPAPhon]}
  deriving (Eq, Show)
  deriving newtype (Semigroup)
  deriving newtype (Monoid)

instance JSON.FromJSON IPAPhons where
  parseJSON v =
    v & JSON.withText "IPAPhons" \(Text.split (== ',') -> ipaSentences) -> do
      let sentencesIPA = ipaSentences <&> (Text.dropAround Char.isSpace >>> textToIPA)
      return $ IPAPhons sentencesIPA
textToIPA :: Text -> IPAPhon
textToIPA t =
  let (errs, wordsIPAs) = words <&> parseSyllables @[] & partitionEithers
  in case wordsIPAs & mapMaybe nonEmpty & nonEmpty of
      Nothing -> IPAPhonError (t, [InvalidIPA "no syllable"])
      Just wordsIPAsNE
        | null errs -> IPAPhonemic wordsIPAsNE
        | otherwise -> IPAPhonError (t, errs)
  where
    words
      | Text.isPrefixOf "[" t || Text.isSuffixOf "]" t =
          t
            & Text.dropAround (\c -> c == '[' || c == ']')
            & Text.words
      | otherwise =
          t
            & Text.dropAround (\c -> c == '\\' || c == '/')
            & Text.words
instance JSON.ToJSON IPAPhons where
  toJSON (IPAPhons ipas) =
    JSON.toJSON $ ipas <&> ipaphonToText
    where
      ipaphonToText :: IPAPhon -> Text
      ipaphonToText = \case
        IPAPhonemic ipaWords -> ipaWords & ipaWordsToText (Just Phonemic)
        IPAPhonetic ipaWords -> ipaWords & ipaWordsToText (Just Phonetic)
        IPAPhonError (t, _err) -> t

ipaWordsToText :: Maybe Delimiter -> NonEmpty IPAWord -> Text
ipaWordsToText delim words =
  start
    <> Text.intercalate
      " "
      [ word & toList <&> toIPA_ & fromList & sconcat & unIPA
      | word <- words & toList
      ]
    <> end
  where
    (start, end) = case delim of
      Nothing -> ("", "")
      Just Phonetic -> ("[", "]")
      Just Phonemic -> ("\\", "\\")

dropSupraSegmentalFeatures :: NonEmpty IPAWord -> NonEmpty IPAWord
dropSupraSegmentalFeatures = fmap (fmap (Syllable . syllableToSegments))

dropSegmentalFeatures :: Segment -> Segment
dropSegmentalFeatures = \case
  WithSegmentalFeature _f seg -> dropSegmentalFeatures seg
  x -> x

isSilent :: Foldable t => Syllable t -> Bool
isSilent = syllableToSegments >>> all (== Zero)

syllableToSegments :: Syllable t -> t Segment
syllableToSegments = \case
  Syllable segs -> segs
  WithSuprasegmentalFeature _feat syl -> syllableToSegments syl

suprasegmentalFeatures :: Syllable t -> [SuprasegmentalFeature]
suprasegmentalFeatures = \case
  Syllable{} -> []
  WithSuprasegmentalFeature feat syl -> feat : suprasegmentalFeatures syl

setSuprasegmentalFeatures :: [SuprasegmentalFeature] -> Syllable t -> Syllable t
setSuprasegmentalFeatures [] = id
setSuprasegmentalFeatures [f] = \case
  s@Syllable{} -> WithSuprasegmentalFeature f s
  WithSuprasegmentalFeature g syl
    | f == g -> WithSuprasegmentalFeature f syl
    | otherwise -> WithSuprasegmentalFeature g $ setSuprasegmentalFeatures [f] syl
setSuprasegmentalFeatures (f : fs) =
  setSuprasegmentalFeatures [f] . (setSuprasegmentalFeatures fs)