{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module      : Language.IPA
-- Copyright   : (c) 2021 Rory Tyler Hayford
-- License     : BSD-3-Clause
-- Maintainer  : rory.hayford@protonmail.com
-- Stability   : experimental
-- Portability : GHC
--
-- Working with IPA\/X-SAMPA transcriptions and phonetic/phonemic values
module Language.IPA
    (    -- * Utilities
       -- ** Transcription
      transcribe
    , transcribeXSampa
       -- ** Conversion
    , ipaToXSampa
    , xSampaToIpa
      -- ** Construction
    , toIPA'
    , toXSampa'
       -- ** Predicates
    , isValid
    , isValidSegment
    , isValidSyllable
    , isObstruent
    , isSonorant
    , isLabial
    , isCoronal
    , isDorsal
    , isLaryngeal
    , isRhotic
    , isLiquid
      -- * Re-exports
    , module M
    ) where

import           Control.Exception   ( throw )

import           Data.Maybe          ( fromMaybe )
import           Data.Text           ( Text )

import           Language.IPA.Class  as M
import           Language.IPA.Parser as M
import           Language.IPA.QQ     as M
import           Language.IPA.Types  as M

-- | \"Transcribe\" an 'IPA' value by wrapping it in a 'Delimiter'
--
-- >>> s = PulmonicConsonant Voiced Dental (Fricative NonSibilant)
-- >>> transcribe Phonemic <$> toIPA s
-- Just "/ð/"
transcribe :: Delimiter -> IPA -> Text
transcribe :: Delimiter -> IPA -> Text
transcribe Delimiter
delim IPA { Text
unIPA :: IPA -> Text
unIPA :: Text
.. } = Text
start Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
unIPA Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
end
  where
    (Text
start, Text
end) = Delimiter -> (Text, Text)
showDelims Delimiter
delim

-- | As 'transcribe', for 'XSampa' values
transcribeXSampa :: Delimiter -> XSampa -> Text
transcribeXSampa :: Delimiter -> XSampa -> Text
transcribeXSampa Delimiter
delim XSampa { Text
unXSampa :: XSampa -> Text
unXSampa :: Text
.. } = Text
start Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
unXSampa Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
end
  where
    (Text
start, Text
end) = Delimiter -> (Text, Text)
showDelims Delimiter
delim

-- | Convert an 'IPA' value to its equivalent in 'XSampa'; note that several
-- features and segments that can be transcribed in IPA notation are missing
-- from X-SAMPA
ipaToXSampa :: IPA -> Maybe XSampa
ipaToXSampa :: IPA -> Maybe XSampa
ipaToXSampa IPA { Text
unIPA :: Text
unIPA :: IPA -> Text
.. } =
    (IPAException -> Maybe XSampa)
-> (Syllable [] -> Maybe XSampa)
-> Either IPAException (Syllable [])
-> Maybe XSampa
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe XSampa -> IPAException -> Maybe XSampa
forall a b. a -> b -> a
const Maybe XSampa
forall a. Maybe a
Nothing) Syllable [] -> Maybe XSampa
forall a. ReprXSampa a => a -> Maybe XSampa
toXSampa (Text -> Either IPAException (Syllable [])
forall a. ReprIPA a => Text -> Either IPAException a
parseIPA @(Syllable []) Text
unIPA)

-- | Convert an 'XSampa' value to its equivalent in 'IPA'
xSampaToIpa :: XSampa -> Maybe IPA
xSampaToIpa :: XSampa -> Maybe IPA
xSampaToIpa XSampa { Text
unXSampa :: Text
unXSampa :: XSampa -> Text
.. } =
    (IPAException -> Maybe IPA)
-> (Syllable [] -> Maybe IPA)
-> Either IPAException (Syllable [])
-> Maybe IPA
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe IPA -> IPAException -> Maybe IPA
forall a b. a -> b -> a
const Maybe IPA
forall a. Maybe a
Nothing) Syllable [] -> Maybe IPA
forall a. ReprIPA a => a -> Maybe IPA
toIPA (Text -> Either IPAException (Syllable [])
forall a. ReprXSampa a => Text -> Either IPAException a
parseXSampa @(Syllable []) Text
unXSampa)

-- | Partial function for creating an 'IPA'. Useful if you are certain that
-- the sound in question is representable
toIPA' :: ReprIPA a => a -> IPA
toIPA' :: a -> IPA
toIPA' a
x = IPA -> Maybe IPA -> IPA
forall a. a -> Maybe a -> a
fromMaybe (IPAException -> IPA
forall a e. Exception e => e -> a
throw (IPAException -> IPA) -> IPAException -> IPA
forall a b. (a -> b) -> a -> b
$ Text -> IPAException
InvalidIPA Text
"Illegal IPA value") (a -> Maybe IPA
forall a. ReprIPA a => a -> Maybe IPA
toIPA a
x)

-- | Partial function for creating an 'XSampa'. NB: Certain segments that have
-- a defined 'IPA' representation have no 'XSampa' equivalent
toXSampa' :: ReprXSampa a => a -> XSampa
toXSampa' :: a -> XSampa
toXSampa' a
x = XSampa -> Maybe XSampa -> XSampa
forall a. a -> Maybe a -> a
fromMaybe (IPAException -> XSampa
forall a e. Exception e => e -> a
throw (IPAException -> XSampa) -> IPAException -> XSampa
forall a b. (a -> b) -> a -> b
$ Text -> IPAException
InvalidXSampa Text
"Illegal X-SAMPA value")
                        (a -> Maybe XSampa
forall a. ReprXSampa a => a -> Maybe XSampa
toXSampa a
x)

-- | Does a text value in IPA notation represent a valid instance of 'ReprIPA'?
-- Note that you will need @-XTypeApplications@ to use this, and that this just
-- calls 'parseIPA' to determine validity
--
-- >>> isValid @Segment "L"
-- False
-- >>> isValid @Segment "ʟ"
-- True
isValid :: forall a. ReprIPA a => Text -> Bool
isValid :: Text -> Bool
isValid Text
t = (IPAException -> Bool)
-> (a -> Bool) -> Either IPAException a -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> IPAException -> Bool
forall a b. a -> b -> a
const Bool
False) (Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
True) (Text -> Either IPAException a
forall a. ReprIPA a => Text -> Either IPAException a
parseIPA @a Text
t)

-- | Does a text value represent valid individual IPA 'Segment'?
isValidSegment :: Text -> Bool
isValidSegment :: Text -> Bool
isValidSegment = ReprIPA Segment => Text -> Bool
forall a. ReprIPA a => Text -> Bool
isValid @Segment

-- | Is a text value a valid IPA 'Syllable'?
isValidSyllable :: Text -> Bool
isValidSyllable :: Text -> Bool
isValidSyllable = ReprIPA (Syllable []) => Text -> Bool
forall a. ReprIPA a => Text -> Bool
isValid @(Syllable [])

-- | Tests if a 'Segment' is obstruent, i.e. formed by obstructing airflow
isObstruent :: Segment -> Bool
isObstruent :: Segment -> Bool
isObstruent = \case
    PulmonicConsonant Phonation
_ Place
_ Manner
manner -> case Manner
manner of
        Manner
Plosive     -> Bool
True
        Fricative Sibilance
_ -> Bool
True
        Affricate Sibilance
_ -> Bool
True
        Manner
_           -> Bool
False
    Segment
_ -> Bool
False

-- | Tests if 'Segment' is sonorant, i.e. if it is created with an uninterrupted
-- flow of air
isSonorant :: Segment -> Bool
isSonorant :: Segment -> Bool
isSonorant = Bool -> Bool
not (Bool -> Bool) -> (Segment -> Bool) -> Segment -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Segment -> Bool
isObstruent

-- | Tests pulmonic 'Consonant' membership in the labial category, whose
-- active articulator is one or both lips
isLabial :: Consonant -> Bool
isLabial :: Consonant -> Bool
isLabial = \case
    Pulmonic Phonation
_ Place
place Manner
_ -> case Place
place of
        Place
Bilabial     -> Bool
True
        Place
LabioDental  -> Bool
True
        Place
LinguoLabial -> Bool
True
        Place
_            -> Bool
False
    Consonant
_                  -> Bool
False

-- | Tests pulmonic 'Consonant' membership in the coronal class, whose
-- active articulator is the front of the tongue
isCoronal :: Consonant -> Bool
isCoronal :: Consonant -> Bool
isCoronal = \case
    Pulmonic Phonation
_ Place
Palatal (Fricative Sibilance
Sibilant) -> Bool
True
    Pulmonic Phonation
_ Place
place Manner
_ -> case Place
place of
        Place
Dental       -> Bool
True
        Place
Alveolar     -> Bool
True
        Place
PostAlveolar -> Bool
True
        Place
Retroflex    -> Bool
True
        Place
_            -> Bool
False
    Consonant
_ -> Bool
False

-- | Tests pulmonic 'Consonant' membership in the dorsal class, whose
-- active articulator is the dorsum (back of the tongue)
isDorsal :: Consonant -> Bool
isDorsal :: Consonant -> Bool
isDorsal = \case
    Pulmonic Phonation
_ Place
place Manner
_ -> case Place
place of
        Place
Palatal -> Bool
True
        Place
Velar   -> Bool
True
        Place
Uvular  -> Bool
True
        Place
_       -> Bool
False
    Consonant
_                  -> Bool
False

-- | Tests pulmonic 'Consonant' membership in the laryngeal class, whose
-- active articulator is the larynx
isLaryngeal :: Consonant -> Bool
isLaryngeal :: Consonant -> Bool
isLaryngeal = \case
    Pulmonic Phonation
_ Place
place Manner
_ -> case Place
place of
        Place
Pharyngeal -> Bool
True
        Place
Glottal    -> Bool
True
        Place
_          -> Bool
False
    Consonant
_                  -> Bool
False

-- | Tests if 'Consonant' is rhotic, a vague category of R-like sounds typically
-- represented lexicographically by some variant of the Latin letter r
isRhotic :: Consonant -> Bool
isRhotic :: Consonant -> Bool
isRhotic = \case
    Pulmonic Phonation
Voiced Place
Uvular (Fricative Sibilance
NonSibilant) -> Bool
True
    Pulmonic Phonation
_ Place
Uvular Manner
Trill -> Bool
True
    Pulmonic Phonation
_ Place
place Manner
manner
        | Place
place Place -> [Place] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ Place
Alveolar, Place
Retroflex ] -> case Manner
manner of
            Manner
Approximant -> Bool
True
            Manner
Trill       -> Bool
True
            Manner
Flap        -> Bool
True
            Manner
_           -> Bool
False
        | Bool
otherwise -> Bool
False
    Consonant
_ -> Bool
False

-- | Tests if a 'Consonant' is liquid, a category of rhotics and voiced
-- lateral approximants
isLiquid :: Consonant -> Bool
isLiquid :: Consonant -> Bool
isLiquid Consonant
c
    | Consonant -> Bool
isRhotic Consonant
c = Bool
True
    | Bool
otherwise = case Consonant
c of
        Pulmonic Phonation
Voiced Place
_ Manner
LateralApproximant -> Bool
True
        Consonant
_ -> Bool
False

showDelims :: Delimiter -> (Text, Text)
showDelims :: Delimiter -> (Text, Text)
showDelims Delimiter
Phonetic = (Text
"[", Text
"]")
showDelims Delimiter
Phonemic = (Text
"/", Text
"/")