src/Worksheets/Utils/IPA.hs

   1 {-# LANGUAGE StrictData #-}
   2 {-# OPTIONS_GHC -Wno-orphans #-}
   3
   4 module Worksheets.Utils.IPA (
   5   module Worksheets.Utils.IPA,
   6   module Language.IPA,
   7 ) where
   8
   9 import Data.Char qualified as Char
  10 import Data.Text qualified as Text
  11 import Language.IPA
  12 import Worksheets.Utils.JSON qualified as JSON
  13 import Worksheets.Utils.Prelude
  14 import Prelude (error)
  15
  16 toIPA_ :: HasCallStack => ReprIPA a => a -> IPA
  17 toIPA_ = toIPA >>> fromMaybe (error "toIPA_")
  18
  19 instance IsString (Syllable []) where
  20   fromString "" = Syllable []
  21   fromString s =
  22     fromString s
  23       & parseSyllable @[]
  24       & either errorShow id
  25 instance Semigroup (Syllable []) where
  26   WithSuprasegmentalFeature f x <> y = x <> WithSuprasegmentalFeature f y
  27   Syllable x <> y = mergeSyl x y
  28     where
  29       mergeSyl s (WithSuprasegmentalFeature f t) =
  30         WithSuprasegmentalFeature f (mergeSyl s t)
  31       mergeSyl s (Syllable t) = Syllable (s <> t)
  32 instance IsString Segment where
  33   fromString s =
  34     fromString s
  35       & parseSegment
  36       & either (error . show) id
  37
  38 ipaToText :: Syllable [] -> Text
  39 ipaToText = toIPA_ >>> unIPA
  40
  41 type IPAWord = NonEmpty (Syllable [])
  42 data IPAPhon
  43   = IPAPhonemic (NonEmpty IPAWord)
  44   | IPAPhonetic (NonEmpty IPAWord)
  45   | IPAPhonError (Text, [IPAException])
  46   deriving (Eq, Show)
  47
  48 newtype IPAPhons = IPAPhons {unIPAPhons :: [IPAPhon]}
  49   deriving (Eq, Show)
  50   deriving newtype (Semigroup)
  51   deriving newtype (Monoid)
  52
  53 instance JSON.FromJSON IPAPhons where
  54   parseJSON v =
  55     v & JSON.withText "IPAPhons" \(Text.split (== ',') -> ipaSentences) -> do
  56       let sentencesIPA = ipaSentences <&> (Text.dropAround Char.isSpace >>> textToIPA)
  57       return $ IPAPhons sentencesIPA
  58 textToIPA :: Text -> IPAPhon
  59 textToIPA t =
  60   let (errs, wordsIPAs) = words <&> parseSyllables @[] & partitionEithers
  61   in case wordsIPAs & mapMaybe nonEmpty & nonEmpty of
  62       Nothing -> IPAPhonError (t, [InvalidIPA "no syllable"])
  63       Just wordsIPAsNE
  64         | null errs -> IPAPhonemic wordsIPAsNE
  65         | otherwise -> IPAPhonError (t, errs)
  66   where
  67     words
  68       | Text.isPrefixOf "[" t || Text.isSuffixOf "]" t =
  69           t
  70             & Text.dropAround (\c -> c == '[' || c == ']')
  71             & Text.words
  72       | otherwise =
  73           t
  74             & Text.dropAround (\c -> c == '\\' || c == '/')
  75             & Text.words
  76 instance JSON.ToJSON IPAPhons where
  77   toJSON (IPAPhons ipas) =
  78     JSON.toJSON $ ipas <&> ipaphonToText
  79     where
  80       ipaphonToText :: IPAPhon -> Text
  81       ipaphonToText = \case
  82         IPAPhonemic ipaWords -> ipaWords & ipaWordsToText (Just Phonemic)
  83         IPAPhonetic ipaWords -> ipaWords & ipaWordsToText (Just Phonetic)
  84         IPAPhonError (t, _err) -> t
  85
  86 ipaWordsToText :: Maybe Delimiter -> NonEmpty IPAWord -> Text
  87 ipaWordsToText delim words =
  88   start
  89     <> Text.intercalate
  90       " "
  91       [ word & toList <&> toIPA_ & fromList & sconcat & unIPA
  92       | word <- words & toList
  93       ]
  94     <> end
  95   where
  96     (start, end) = case delim of
  97       Nothing -> ("", "")
  98       Just Phonetic -> ("[", "]")
  99       Just Phonemic -> ("\\", "\\")
 100
 101 dropSupraSegmentalFeatures :: NonEmpty IPAWord -> NonEmpty IPAWord
 102 dropSupraSegmentalFeatures = fmap (fmap (Syllable . syllableToSegments))
 103
 104 dropSegmentalFeatures :: Segment -> Segment
 105 dropSegmentalFeatures = \case
 106   WithSegmentalFeature _f seg -> dropSegmentalFeatures seg
 107   x -> x
 108
 109 isSilent :: Foldable t => Syllable t -> Bool
 110 isSilent = syllableToSegments >>> all (== Zero)
 111
 112 syllableToSegments :: Syllable t -> t Segment
 113 syllableToSegments = \case
 114   Syllable segs -> segs
 115   WithSuprasegmentalFeature _feat syl -> syllableToSegments syl
 116
 117 suprasegmentalFeatures :: Syllable t -> [SuprasegmentalFeature]
 118 suprasegmentalFeatures = \case
 119   Syllable{} -> []
 120   WithSuprasegmentalFeature feat syl -> feat : suprasegmentalFeatures syl
 121
 122 setSuprasegmentalFeatures :: [SuprasegmentalFeature] -> Syllable t -> Syllable t
 123 setSuprasegmentalFeatures [] = id
 124 setSuprasegmentalFeatures [f] = \case
 125   s@Syllable{} -> WithSuprasegmentalFeature f s
 126   WithSuprasegmentalFeature g syl
 127     | f == g -> WithSuprasegmentalFeature f syl
 128     | otherwise -> WithSuprasegmentalFeature g $ setSuprasegmentalFeatures [f] syl
 129 setSuprasegmentalFeatures (f : fs) =
 130   setSuprasegmentalFeatures [f] . (setSuprasegmentalFeatures fs)