{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- Module      : Language.IPA.Class
-- Copyright   : (c) 2021 Rory Tyler Hayford
-- License     : BSD-3-Clause
-- Maintainer  : rory.hayford@protonmail.com
-- Stability   : experimental
-- Portability : GHC
--
-- Typeclass for representing speech sounds in IPA/X-Sampa notation
module Language.IPA.Class
    ( -- * Converting to IPA representations
      ReprIPA(..)
    , ReprXSampa(..)
    ) where

import           Data.Char           ( digitToInt )
import           Data.Function       ( on )
import           Data.Text           ( Text )
import qualified Data.Text           as T

import           Language.IPA.Parser
                 ( parseSegment
                 , parseSegmentXSampa
                 , parseSyllable
                 , parseSyllableXSampa
                 )
import           Language.IPA.Types

-- | Entities representable through IPA transcription
class ReprIPA a where
    -- | Produces an 'IPA' transcription given a valid 'Segment'; a result
    -- of @Nothing@ indicates either an unattested-yet-possible segment, or one
    -- considered impossible
    toIPA :: a -> Maybe IPA

    -- | Parse text in IPA notation
    parseIPA :: Text -> Either IPAException a

-- | Entities representable through X-SAMPA transcription, an ASCII subset
-- of the IPA
class ReprXSampa a where
    -- | Similar to 'toIPA'; produces an 'XSampa' transcription given a valid 'Segment'.
    toXSampa :: a -> Maybe XSampa

    -- | Parse text in X-SAMPA notation
    parseXSampa :: Text -> Either IPAException a

instance MultiSegment t => ReprIPA (Syllable t) where
    toIPA = \case
        Syllable ss
            | null ss -> Nothing
            | otherwise -> foldr1 (<>) <$> traverse toIPA ss
        WithSuprasegmentalFeature feature s ->
            withSuprasegmentalFeature s feature

    parseIPA = parseSyllable

instance MultiSegment t => ReprXSampa (Syllable t) where
    toXSampa = \case
        Syllable ss
            | null ss -> Nothing
            | otherwise -> foldr1 (<>) <$> traverse toXSampa ss
        WithSuprasegmentalFeature feature s ->
            withSuprasegmentalFeatureXSampa s feature

    parseXSampa = parseSyllableXSampa

instance ReprIPA Segment where
    toIPA = \case
        Zero -> mkJustIPA "∅"
        Consonant c -> consonant c
        Vowel v -> vowel v
        WithSegmentalFeature feature s -> withSegmentalFeature s feature
        Optional s -> do
            IPA { .. } <- toIPA s
            return . mkIPA $ "(" <> unIPA <> ")"

    parseIPA = parseSegment

instance ReprXSampa Segment where
    toXSampa = \case
        Zero -> Nothing -- does not appear to have an X-SAMPA encoding
        Vowel v -> vowelXSampa v
        Consonant c -> consonantXSampa c
        WithSegmentalFeature feature s -> withSegmentalFeatureXSampa s feature
        Optional s -> do
            XSampa { .. } <- toXSampa s
            return . XSampa $ "(" <> unXSampa <> ")"

    parseXSampa = parseSegmentXSampa

mkJustIPA :: Text -> Maybe IPA
mkJustIPA = Just . mkIPA

mkIPAOp :: ReprIPA a => (b -> Maybe IPA) -> a -> b -> Maybe IPA
mkIPAOp f x y = (<>) <$> toIPA x <*> f y

withSuprasegmentalFeature
    :: MultiSegment t => Syllable t -> SuprasegmentalFeature -> Maybe IPA
withSuprasegmentalFeature s = \case
    LevelLexicalTone tone -> mkIPAOp ipaTone s tone
      where
        ipaTone = \case
            ExtraHighTone -> mkJustIPA "˥"
            HighTone      -> mkJustIPA "˦"
            MidTone       -> mkJustIPA "˧"
            LowTone       -> mkJustIPA "˨"
            ExtraLowTone  -> mkJustIPA "˩"
            -- Down-step and up-step are not represented with tone characters
            _             -> Nothing

    LevelLexicalToneDiacritic tone -> mkIPAOp ipaTone s tone
      where
        ipaTone = \case
            ExtraHighTone -> mkJustIPA "\x030b" -- ◌̋
            HighTone      -> mkJustIPA "\x0341" -- ◌́
            MidTone       -> mkJustIPA "\x0304" -- ◌̄
            LowTone       -> mkJustIPA "\x0340" -- ◌̀
            ExtraLowTone  -> mkJustIPA "\x030f" -- ◌̏
            DownStep      -> mkJustIPA "ꜜ"
            UpStep        -> mkJustIPA "ꜛ"

    LexicalToneContour tone -> mkIPAOp ipaToneContour s tone
      where
        ipaToneContour = \case
            Rising        -> mkJustIPA "˩˥"
            Falling       -> mkJustIPA "˥˩"
            HighRising    -> mkJustIPA "˧˥"
            LowRising     -> mkJustIPA "˩˧"
            HighFalling   -> mkJustIPA "˥˧"
            LowFalling    -> mkJustIPA "˧˩"
            RisingFalling -> mkJustIPA "˧˦˨"
            FallingRising -> mkJustIPA "˧˨˦"
            GlobalRise    -> mkJustIPA "↗"
            GlobalFall    -> mkJustIPA "↙"

    LexicalToneContourDiacritic tone -> mkIPAOp ipaToneContour s tone
      where
        ipaToneContour = \case
            Rising        -> mkJustIPA "\x0302" -- ◌̂
            Falling       -> mkJustIPA "\x030c" -- ◌̌
            HighRising    -> mkJustIPA "\x1dc9" -- ◌᷉
            LowRising     -> mkJustIPA "\x1dc5" -- ◌᷅
            HighFalling   -> mkJustIPA "\x1dc7" -- ◌᷇
            LowFalling    -> mkJustIPA "\x1dc6" -- ◌᷆
            RisingFalling -> mkJustIPA "\x1dc8" -- ◌᷈
            FallingRising -> mkJustIPA "\x1dc9" -- ◌᷉
            -- 'GlobalRise' and 'GlobalFall' don't have
            -- diacritic representations
            _             -> Nothing

    ToneNumber ns -> (<>) <$> toIPA s <*> mkJustIPA digits
      where
        digits = T.concat $ T.pack <$> (code . digitToInt <$> show ns)

        code   = \case
            0 -> "\x2070"
            1 -> "\x00b9"
            2 -> "\x00b2"
            3 -> "\x00b3"
            4 -> "\x2074"
            5 -> "\x2075"
            6 -> "\x2076"
            7 -> "\x2077"
            8 -> "\x2078"
            9 -> "\x2079"
            _ -> mempty

    Stress stress -> mkIPAOp ipaStress s stress
      where
        ipaStress Primary   = mkJustIPA "ˈ"
        ipaStress Secondary = mkJustIPA "ˌ"

    Break -> (<>) <$> toIPA s <*> mkJustIPA "."

    Linking -> (<>) <$> toIPA s <*> mkJustIPA "‿"

withSegmentalFeature :: Segment -> SegmentalFeature -> Maybe IPA
withSegmentalFeature s = \case
    Voicing v -> mkIPAOp ipaVoicing s v
      where
        ipaVoicing = \case
            Voiceless -> mkJustIPA "\x030a" -- ◌̊
            Voiced    -> mkJustIPA "\x030c" -- ◌̌
    Length l -> mkIPAOp ipaLength s l
      where
        ipaLength = \case
            OverLong   -> mkJustIPA "ːː"
            HalfLong   -> mkJustIPA "ˑ"
            Long       -> mkJustIPA "ː"
            Short      -> mkJustIPA mempty
            ExtraShort -> mkJustIPA "\x0306" -- ◌ ̆
    SecondaryArticulation sa -> mkIPAOp secondaryArticulation s sa
    feature -> (<>) <$> toIPA s <*> case feature of
        Aspirated           -> mkJustIPA "\x02b0" -- ◌ʰ
        MoreRounded         -> mkJustIPA "\x0339" -- ◌̹
        LessRounded         -> mkJustIPA "\x031c" -- ◌̜
        Advanced            -> mkJustIPA "\x031f" -- ◌̟
        Retracted           -> mkJustIPA "\x0320" -- ◌̠
        Centralized         -> mkJustIPA "\x0308" -- ◌̈
        MidCentralized      -> mkJustIPA "\x033d" -- ◌̽
        Compressed          -> mkJustIPA "\x1d5d" -- ◌ᵝ
        Syllabic            -> mkJustIPA "\x0329" -- ◌̩
        NonSyllabic         -> mkJustIPA "\x032f" -- ◌̯
        Rhotacized          -> mkJustIPA "\x02de" -- ◌˞
        BreathyVoice        -> mkJustIPA "\x0324" -- ◌̤
        CreakyVoice         -> mkJustIPA "\x0330" -- ◌̰
        LinguoLabialized    -> mkJustIPA "\x033c" -- ◌̼
        Labialized          -> mkJustIPA "\x02b7" -- ◌ʷ
        Palatalized         -> mkJustIPA "\x02b2" -- ◌ʲ
        Velarized           -> mkJustIPA "\x02e0" -- ◌ˠ
        Pharyngealized      -> mkJustIPA "\x02e4" -- ◌ˤ
        Raised              -> mkJustIPA "\x031d" -- ◌̝
        Lowered             -> mkJustIPA "\x031e" -- ◌̞
        AdvancedTongueRoot  -> mkJustIPA "\x0318" -- ◌̘
        RetractedTongueRoot -> mkJustIPA "\x0319" -- ◌̙
        Dentalized          -> mkJustIPA "\x032a" -- ◌̪
        Apical              -> mkJustIPA "\x033a" -- ◌̺
        Laminal             -> mkJustIPA "\x033b" -- ◌̻
        Nasalized           -> mkJustIPA "\x0303" -- ◌̃
        NasalRelease        -> mkJustIPA "\x207f" -- ◌ⁿ
        LateralRelease      -> mkJustIPA "\x02e1" -- ◌ˡ
        NoAudibleRelease    -> mkJustIPA "\x031a" -- ◌̚
        _                   -> mkJustIPA "" --

doubleArticulated :: Text -> Text -> Text
doubleArticulated x y = x <> breve <> y
  where
    breve = "\x0361"

voiceless :: Bool -- Whether this character is descending or not
          -> Text
          -> Text
voiceless desc = (<> getC desc)
  where
    getC True  = "\x030a"
    getC False = "\x0325"

dentalized :: Text -> Text
dentalized = (<> "\x032a")

raisedMod :: Text -> Text
raisedMod = (<> "\x02d4")

raised :: Text -> Text
raised = (<> "\x031d")

retracted :: Text -> Text
retracted = (<> "\x0320")

flapped :: Text -> Text
flapped = (<> "\x0306")

consonant :: Consonant -> Maybe IPA
consonant = \case
    e@Ejective {} -> ejective e
    i@Implosive {} -> implosive i
    -- Pulmonic consonants
    -- Bilabials
    Pulmonic Voiceless Bilabial Nasal -> toIPA
        $ WithSegmentalFeature (Voicing Voiceless)
                               (PulmonicConsonant Voiced Bilabial Nasal)
    Pulmonic Voiced Bilabial Nasal -> mkJustIPA "m"
    Pulmonic Voiced Bilabial Plosive -> mkJustIPA "b"
    Pulmonic Voiceless Bilabial Plosive -> mkJustIPA "p"
    Pulmonic Voiceless Bilabial (Affricate NonSibilant) ->
        mkJustIPA $ doubleArticulated "p" "ɸ"
    Pulmonic Voiced Bilabial (Affricate NonSibilant) ->
        mkJustIPA $ doubleArticulated "b" "β"
    Pulmonic Voiceless Bilabial (Fricative NonSibilant) -> mkJustIPA "ɸ"
    Pulmonic Voiced Bilabial (Fricative NonSibilant) -> mkJustIPA "β"
    Pulmonic Voiced Bilabial Flap -> toIPA
        $ WithSegmentalFeature Advanced
                               (PulmonicConsonant Voiced LabioDental Flap)
    Pulmonic Voiceless Bilabial Trill -> mkJustIPA $ voiceless False "ʙ"
    Pulmonic Voiced Bilabial Trill -> mkJustIPA "ʙ"

    -- Labio-dentals
    Pulmonic Voiced LabioDental Nasal -> mkJustIPA "ɱ"
    Pulmonic v LabioDental Plosive -> toIPA
        $ WithSegmentalFeature Dentalized
                               (PulmonicConsonant v Bilabial Plosive)

    Pulmonic v LabioDental (Affricate NonSibilant) -> do
        IPA stop <- toIPA $ PulmonicConsonant v LabioDental Plosive
        IPA fricative <- toIPA
            $ PulmonicConsonant v LabioDental (Fricative NonSibilant)
        mkJustIPA $ doubleArticulated stop fricative
    Pulmonic Voiceless LabioDental (Fricative NonSibilant) -> mkJustIPA "f"
    Pulmonic Voiced LabioDental (Fricative NonSibilant) -> mkJustIPA "v"
    Pulmonic Voiced LabioDental Approximant -> mkJustIPA "ʋ"
    Pulmonic Voiced LabioDental Flap -> mkJustIPA "ⱱ"

    -- Linguo-labials
    Pulmonic Voiced LinguoLabial manner
        | manner `elem` [ Nasal, Plosive, Fricative NonSibilant, Flap ] ->
            toIPA
            $ WithSegmentalFeature LinguoLabialized
                                   (PulmonicConsonant Voiced Alveolar manner)
    Pulmonic Voiceless LinguoLabial manner
        | manner `elem` [ Plosive, Fricative NonSibilant ] -> toIPA
            $ WithSegmentalFeature LinguoLabialized
                                   (PulmonicConsonant Voiceless
                                                      Alveolar
                                                      manner)

    -- Dentals
    Pulmonic Voiceless Dental (Affricate NonSibilant) -> mkJustIPA
        $ doubleArticulated (dentalized "t") "θ"
    Pulmonic Voiced Dental (Affricate NonSibilant) -> mkJustIPA
        $ doubleArticulated (dentalized "d") "ð"
    Pulmonic Voiceless Dental (Fricative NonSibilant) -> mkJustIPA "θ"
    Pulmonic Voiced Dental (Fricative NonSibilant) -> mkJustIPA "ð"

    -- Alveolars
    Pulmonic Voiceless Alveolar Nasal -> toIPA
        $ WithSegmentalFeature (Voicing Voiceless)
                               (PulmonicConsonant Voiced Alveolar Nasal)
    Pulmonic Voiced Alveolar Nasal -> mkJustIPA "n"
    Pulmonic Voiceless Alveolar Plosive -> mkJustIPA "t"
    Pulmonic Voiced Alveolar Plosive -> mkJustIPA "d"
    Pulmonic Voiceless Alveolar (Affricate Sibilant) ->
        mkJustIPA $ doubleArticulated "t" "s"
    Pulmonic Voiced Alveolar (Affricate Sibilant) ->
        mkJustIPA $ doubleArticulated "d" "z"
    Pulmonic Voiceless Alveolar (Affricate NonSibilant) -> mkJustIPA
        $ doubleArticulated "t" (raisedMod $ voiceless True "ɹ")
    Pulmonic Voiced Alveolar (Affricate NonSibilant) -> mkJustIPA
        $ doubleArticulated "d" (raisedMod "ɹ")
    Pulmonic Voiceless Alveolar (Fricative Sibilant) -> mkJustIPA "s"
    Pulmonic Voiced Alveolar (Fricative Sibilant) -> mkJustIPA "z"
    Pulmonic Voiced Alveolar Approximant -> mkJustIPA "ɹ"
    Pulmonic Voiceless Alveolar Flap -> mkJustIPA $ voiceless False "ɾ"
    Pulmonic Voiced Alveolar Flap -> mkJustIPA "ɾ"
    Pulmonic Voiceless Alveolar Trill -> toIPA
        $ WithSegmentalFeature (Voicing Voiceless)
                               (PulmonicConsonant Voiced Alveolar Trill)
    Pulmonic Voiced Alveolar Trill -> mkJustIPA "r"
    Pulmonic Voiceless Alveolar LateralAffricate -> mkJustIPA "tɬ"
    Pulmonic Voiced Alveolar LateralAffricate -> mkJustIPA "dɮ"
    Pulmonic Voiceless Alveolar LateralFricative -> mkJustIPA "ɬ"
    Pulmonic Voiced Alveolar LateralFricative -> mkJustIPA "ɮ"
    Pulmonic Voiced Alveolar LateralApproximant -> mkJustIPA "l"
    Pulmonic Voiceless Alveolar LateralFlap -> toIPA
        $ WithSegmentalFeature (Voicing Voiceless)
                               (PulmonicConsonant Voiced Alveolar LateralFlap)
    Pulmonic Voiced Alveolar LateralFlap -> mkJustIPA "ɺ"

    -- Post-alveolars
    Pulmonic Voiceless PostAlveolar (Affricate Sibilant) ->
        mkJustIPA $ doubleArticulated "t" "ʃ"
    Pulmonic Voiced PostAlveolar (Affricate Sibilant) ->
        mkJustIPA $ doubleArticulated "d" "ʒ"
    Pulmonic Voiceless PostAlveolar (Affricate NonSibilant) -> mkJustIPA
        $ doubleArticulated "t" (raisedMod . voiceless True $ retracted "ɹ")
    Pulmonic Voiced PostAlveolar (Affricate NonSibilant) -> mkJustIPA
        $ doubleArticulated "d" (raisedMod $ retracted "ɹ")
    Pulmonic Voiceless PostAlveolar (Fricative Sibilant) -> mkJustIPA "ʃ"
    Pulmonic Voiced PostAlveolar (Fricative Sibilant) -> mkJustIPA "ʒ"
    Pulmonic Voiceless PostAlveolar (Fricative NonSibilant) ->
        mkJustIPA . raisedMod . voiceless True . retracted $ "ɹ"
    Pulmonic Voiced PostAlveolar (Fricative NonSibilant) ->
        mkJustIPA . raisedMod $ retracted "ɹ"

    -- Retroflexes
    Pulmonic Voiceless Retroflex Nasal -> toIPA
        $ WithSegmentalFeature (Voicing Voiceless)
                               (PulmonicConsonant Voiced Retroflex Nasal)
    Pulmonic Voiced Retroflex Nasal -> mkJustIPA "ɳ"
    Pulmonic Voiceless Retroflex Plosive -> mkJustIPA "ʈ"
    Pulmonic Voiced Retroflex Plosive -> mkJustIPA "ɖ"
    Pulmonic Voiceless Retroflex (Affricate Sibilant) ->
        mkJustIPA $ doubleArticulated "ʈ" "ʂ"
    Pulmonic Voiced Retroflex (Affricate Sibilant) ->
        mkJustIPA $ doubleArticulated "ɖ" "ʐ"
    Pulmonic Voiceless Retroflex (Fricative Sibilant) -> mkJustIPA "ʂ"
    Pulmonic Voiced Retroflex (Fricative Sibilant) -> mkJustIPA "ʐ"
    Pulmonic Voiced Retroflex (Fricative NonSibilant) ->
        mkJustIPA $ raisedMod "ɻ"
    Pulmonic Voiced Retroflex Approximant -> mkJustIPA "ɻ"
    Pulmonic Voiceless Retroflex Flap -> toIPA
        $ WithSegmentalFeature (Voicing Voiceless)
                               (PulmonicConsonant Voiced Retroflex Flap)
    Pulmonic Voiced Retroflex Flap -> mkJustIPA "ɽ"
    Pulmonic Voiceless Retroflex Trill ->
        mkJustIPA $ voiceless True "ɽ" <> voiceless False "r"
    Pulmonic Voiced Retroflex Trill -> mkJustIPA "ɽr"
    Pulmonic Voiceless Retroflex LateralAffricate -> mkJustIPA
        $ "ʈ" <> (raisedMod . voiceless True $ "ɭ")
    Pulmonic Voiced Retroflex LateralAffricate ->
        mkJustIPA $ "ɖ" <> raisedMod "ɭ"
    Pulmonic Voiceless Retroflex LateralFricative ->
        mkJustIPA . raisedMod . voiceless True $ "ɭ"
    Pulmonic Voiced Retroflex LateralFricative -> mkJustIPA $ raisedMod "ɭ"
    Pulmonic Voiced Retroflex LateralApproximant -> mkJustIPA "ɭ"
    Pulmonic Voiceless Retroflex LateralFlap ->
        mkJustIPA . voiceless True $ flapped "ɭ"
    Pulmonic Voiced Retroflex LateralFlap -> mkJustIPA $ flapped "ɭ"

    -- Palatals
    Pulmonic Voiceless Palatal Nasal -> toIPA
        $ WithSegmentalFeature (Voicing Voiceless)
                               (PulmonicConsonant Voiced Palatal Nasal)
    Pulmonic Voiced Palatal Nasal -> mkJustIPA "ɲ"
    Pulmonic Voiceless Palatal Plosive -> mkJustIPA "c"
    Pulmonic Voiced Palatal Plosive -> mkJustIPA "ɟ"
    Pulmonic Voiceless Palatal (Affricate Sibilant) ->
        mkJustIPA $ doubleArticulated "t" "ɕ"
    Pulmonic Voiced Palatal (Affricate Sibilant) ->
        mkJustIPA $ doubleArticulated "d" "ʑ"
    Pulmonic Voiceless Palatal (Affricate NonSibilant) ->
        mkJustIPA $ doubleArticulated "c" "ç"
    Pulmonic Voiced Palatal (Affricate NonSibilant) ->
        mkJustIPA $ doubleArticulated "ɟ" "ʝ"
    Pulmonic Voiceless Palatal (Fricative Sibilant) -> mkJustIPA "ɕ"
    Pulmonic Voiced Palatal (Fricative Sibilant) -> mkJustIPA "ʑ"
    Pulmonic Voiceless Palatal (Fricative NonSibilant) -> mkJustIPA "ç"
    Pulmonic Voiced Palatal (Fricative NonSibilant) -> mkJustIPA "ʝ"
    Pulmonic Voiced Palatal Approximant -> mkJustIPA "j"
    Pulmonic Voiceless Palatal LateralAffricate -> mkJustIPA
        $ "c" <> (voiceless True . raised $ "ʎ")
    Pulmonic Voiced Palatal LateralAffricate ->
        mkJustIPA $ "ɟ" <> raised "ʎ"
    Pulmonic Voiceless Palatal LateralFricative ->
        mkJustIPA . raised . voiceless True $ "ʎ"
    Pulmonic Voiced Palatal LateralFricative -> mkJustIPA $ raised "ʎ"
    Pulmonic Voiced Palatal LateralApproximant -> mkJustIPA "ʎ"
    Pulmonic Voiced Palatal LateralFlap -> mkJustIPA $ flapped "ʎ"

    -- Velars
    Pulmonic Voiceless Velar Nasal -> toIPA
        $ WithSegmentalFeature (Voicing Voiceless)
                               (PulmonicConsonant Voiced Velar Nasal)
    Pulmonic Voiced Velar Nasal -> mkJustIPA "ŋ"
    Pulmonic Voiceless Velar Plosive -> mkJustIPA "k"
    Pulmonic Voiced Velar Plosive -> mkJustIPA "g"
    Pulmonic Voiceless Velar (Affricate NonSibilant) ->
        mkJustIPA $ doubleArticulated "k" "x"
    Pulmonic Voiced Velar (Affricate NonSibilant) ->
        mkJustIPA $ doubleArticulated "g" "ɣ"
    Pulmonic Voiceless Velar (Fricative NonSibilant) -> mkJustIPA "x"
    Pulmonic Voiced Velar (Fricative NonSibilant) -> mkJustIPA "ɣ"
    Pulmonic Voiced Velar Approximant -> mkJustIPA "ɰ"
    Pulmonic Voiceless Velar LateralAffricate -> mkJustIPA
        $ "k" <> (raised $ voiceless True "ʟ")
    Pulmonic Voiced Velar LateralAffricate -> mkJustIPA $ "ɡ" <> raised "ʟ"
    Pulmonic Voiceless Velar LateralFricative ->
        mkJustIPA . voiceless True $ raised "ʟ"
    Pulmonic Voiced Velar LateralFricative -> mkJustIPA $ raised "ʟ"
    Pulmonic Voiced Velar LateralApproximant -> mkJustIPA "ʟ"
    Pulmonic Voiced Velar LateralFlap -> mkJustIPA $ flapped "ʟ"

    -- Uvulars
    Pulmonic Voiced Uvular Nasal -> mkJustIPA "ɴ"
    Pulmonic Voiceless Uvular Plosive -> mkJustIPA "q"
    Pulmonic Voiced Uvular Plosive -> mkJustIPA "ɢ"
    Pulmonic Voiceless Uvular (Affricate NonSibilant) ->
        mkJustIPA $ doubleArticulated "q" "χ"
    Pulmonic Voiced Uvular (Affricate NonSibilant) ->
        mkJustIPA $ doubleArticulated "ɢ" "ʁ"
    Pulmonic Voiceless Uvular (Fricative NonSibilant) -> mkJustIPA "χ"
    Pulmonic Voiced Uvular (Fricative NonSibilant) -> mkJustIPA "ʁ"
    Pulmonic Voiced Uvular Flap -> mkJustIPA $ flapped "ɢ"
    Pulmonic Voiceless Uvular Trill -> toIPA
        $ WithSegmentalFeature (Voicing Voiceless)
                               (PulmonicConsonant Voiced Uvular Trill)
    Pulmonic Voiced Uvular Trill -> mkJustIPA "ʀ"
    Pulmonic Voiced Uvular LateralApproximant -> mkJustIPA $ retracted "ʟ"

    -- Pharyngeals
    Pulmonic Voiceless Pharyngeal Plosive -> mkJustIPA "ʡ"
    Pulmonic Voiced Pharyngeal (Affricate NonSibilant) ->
        mkJustIPA $ doubleArticulated "ʡ" "ʢ"
    Pulmonic Voiceless Pharyngeal (Fricative NonSibilant) -> mkJustIPA "ħ"
    Pulmonic Voiced Pharyngeal (Fricative NonSibilant) -> mkJustIPA "ʕ"
    Pulmonic Voiced Pharyngeal Flap -> mkJustIPA $ flapped "ʡ"
    Pulmonic Voiceless Pharyngeal Trill -> mkJustIPA "ʜ"
    Pulmonic Voiced Pharyngeal Trill -> mkJustIPA "ʢ"

    -- Glottals
    Pulmonic Voiceless Glottal Plosive -> mkJustIPA "ʔ"
    Pulmonic Voiceless Glottal (Affricate NonSibilant) ->
        mkJustIPA $ doubleArticulated "ʔ" "h"
    Pulmonic Voiceless Glottal (Fricative NonSibilant) -> mkJustIPA "h"
    Pulmonic Voiced Glottal (Fricative NonSibilant) -> mkJustIPA "ɦ"
    Pulmonic Voiced Glottal Approximant -> mkJustIPA $ "ʔ" <> "\x031e"

    -- Clicks
    Click Bilabial -> mkJustIPA "ʘ"
    Click Dental -> mkJustIPA "ǀ"
    Click Alveolar -> mkJustIPA "ǃ"
    Click PostAlveolar -> mkJustIPA "ǁ"
    Click Palatal -> mkJustIPA "ǂ"

    -- Double articulation
    DoublyArticulated Voiced Bilabial Alveolar Nasal ->
        mkJustIPA $ doubleArticulated "n" "m"
    DoublyArticulated Voiceless Bilabial Alveolar Plosive ->
        mkJustIPA $ doubleArticulated "t" "p"
    DoublyArticulated Voiced Bilabial Alveolar Plosive ->
        mkJustIPA $ doubleArticulated "d" "b"
    DoublyArticulated Voiced Bilabial Velar Nasal ->
        mkJustIPA $ doubleArticulated "ŋ" "m"
    DoublyArticulated Voiceless Bilabial Velar Plosive ->
        mkJustIPA $ doubleArticulated "k" "p"
    DoublyArticulated Voiced Bilabial Velar Plosive ->
        mkJustIPA $ doubleArticulated "g" "b"
    DoublyArticulated Voiceless Uvular Pharyngeal Plosive ->
        mkJustIPA $ doubleArticulated "q" "ʡ"
    DoublyArticulated Voiceless Bilabial Palatal (Fricative NonSibilant) ->
        mkJustIPA $ voiceless True "ɥ"
    DoublyArticulated Voiced Bilabial Palatal Approximant -> mkJustIPA "ɥ"
    DoublyArticulated Voiceless Bilabial Velar (Fricative NonSibilant) ->
        mkJustIPA "ʍ"
    DoublyArticulated Voiced Bilabial Velar Approximant -> mkJustIPA "w"
    DoublyArticulated Voiced Alveolar Velar LateralApproximant ->
        mkJustIPA "ɫ"
    -- The sj-sound in Swedish phonology; actual realization is contested
    -- and appears to vary between dialects
    DoublyArticulated Voiceless PostAlveolar Velar (Fricative Sibilant) ->
        mkJustIPA "ɧ"
    DoublyArticulated Voiceless LabioDental Velar (Fricative Sibilant) ->
        mkJustIPA "ɧ"

    _ -> Nothing

implosive :: Consonant -> Maybe IPA
implosive (Implosive Voiceless place) = toIPA
    $ WithSegmentalFeature (Voicing Voiceless)
                           (ImplosiveConsonant Voiced place)
implosive c = case c of
    Implosive Voiced Bilabial -> mkJustIPA "ɓ"
    Implosive Voiced Alveolar -> mkJustIPA "ɗ"
    Implosive Voiced Retroflex -> mkJustIPA "ᶑ"
    Implosive Voiced Palatal -> mkJustIPA "ʄ"
    Implosive Voiced Velar -> mkJustIPA "ɠ"
    Implosive Voiced Uvular -> mkJustIPA "ʛ"
    Implosive Voiced Dental -> toIPA
        $ WithSegmentalFeature Dentalized (ImplosiveConsonant Voiced Alveolar)
    _ -> Nothing

ejective :: Consonant -> Maybe IPA
ejective c = (<>) <$> getEj c <*> pure ej >>= mkJustIPA
  where
    ej    = "\x02bc"

    getEj = \case
        Ejective Bilabial Plosive -> Just "p"
        Ejective Bilabial (Fricative NonSibilant) -> Just "ɸ"
        Ejective LabioDental (Affricate NonSibilant) -> Just
            $ doubleArticulated (dentalized "p") "f"
        Ejective LabioDental (Fricative NonSibilant) -> Just "f"
        Ejective Dental Plosive -> Just $ dentalized "t"
        Ejective Dental (Affricate NonSibilant) -> Just
            $ doubleArticulated (dentalized "t") "θ"
        Ejective Dental (Fricative NonSibilant) -> Just "θ"
        Ejective Alveolar Plosive -> Just "t"
        Ejective Alveolar (Affricate Sibilant) ->
            Just $ doubleArticulated "t" "s"
        Ejective Alveolar (Fricative Sibilant) -> Just "s"
        Ejective Alveolar LateralAffricate ->
            Just $ doubleArticulated "t" "ɬ"
        Ejective Alveolar LateralFricative -> Just "ɬ"
        Ejective PostAlveolar (Affricate Sibilant) ->
            Just $ doubleArticulated "t" "ʃ"
        Ejective PostAlveolar (Fricative Sibilant) -> Just "ʃ"
        Ejective Retroflex Plosive -> Just "ʈ"
        Ejective Retroflex (Affricate Sibilant) ->
            Just $ doubleArticulated "ʈ" "ʂ"
        Ejective Retroflex (Fricative Sibilant) -> Just "ʂ"
        Ejective Palatal Plosive -> Just "c"
        Ejective Palatal (Affricate Sibilant) ->
            Just $ doubleArticulated "t" "ɕ"
        Ejective Palatal (Fricative Sibilant) -> Just "ɕ"
        Ejective Palatal LateralAffricate -> Just
            $ "c" <> (raised $ voiceless True "ʎ")
        Ejective Velar Plosive -> Just "k"
        Ejective Velar (Affricate NonSibilant) ->
            Just $ doubleArticulated "k" "x"
        Ejective Velar (Fricative NonSibilant) -> Just "x"
        Ejective Velar LateralAffricate -> Just
            $ "k" <> (raised $ voiceless True "ʟ")
        Ejective Uvular Plosive -> Just "q"
        Ejective Uvular (Affricate NonSibilant) ->
            Just $ doubleArticulated "q" "χ"
        Ejective Uvular (Fricative NonSibilant) -> Just "χ"
        Ejective Pharyngeal Plosive -> Just "ʡ"
        _ -> Nothing

vowel :: Vowel -> Maybe IPA
vowel = \case
    Pure Close Front Unrounded -> mkJustIPA "i"
    Pure Close Front Rounded -> mkJustIPA "y"
    Pure Close Central Unrounded -> mkJustIPA "ɨ"
    Pure Close Central Rounded -> mkJustIPA "ʉ"
    Pure Close Back Unrounded -> mkJustIPA "ɯ"
    Pure Close Back Rounded -> mkJustIPA "u"
    Pure NearClose Front Unrounded -> mkJustIPA "ɪ"
    Pure NearClose Front Rounded -> mkJustIPA "ʏ"
    Pure NearClose Back Rounded -> mkJustIPA "ʊ"
    Pure CloseMid Front Unrounded -> mkJustIPA "e"
    Pure CloseMid Front Rounded -> mkJustIPA "ø"
    Pure CloseMid Central Unrounded -> mkJustIPA "ɘ"
    Pure CloseMid Central Rounded -> mkJustIPA "ɵ"
    Pure CloseMid Back Unrounded -> mkJustIPA "ɤ"
    Pure CloseMid Back Rounded -> mkJustIPA "o"
    Pure Mid Front Unrounded -> toIPA
        $ WithSegmentalFeature Lowered (Vowel $ Pure CloseMid Front Unrounded)
    Pure Mid Front Rounded -> toIPA
        $ WithSegmentalFeature Lowered (Vowel $ Pure CloseMid Front Rounded)
    Pure Mid Central Unrounded -> mkJustIPA "ə"
    Pure Mid Back Unrounded -> toIPA
        $ WithSegmentalFeature Lowered (Vowel $ Pure CloseMid Back Unrounded)
    Pure Mid Back Rounded -> toIPA
        $ WithSegmentalFeature Lowered (Vowel $ Pure CloseMid Back Rounded)
    Pure OpenMid Front Unrounded -> mkJustIPA "ɛ"
    Pure OpenMid Front Rounded -> mkJustIPA "œ"
    Pure OpenMid Central Unrounded -> mkJustIPA "ɜ"
    Pure OpenMid Central Rounded -> mkJustIPA "ɞ"
    Pure OpenMid Back Unrounded -> mkJustIPA "ʌ"
    Pure OpenMid Back Rounded -> mkJustIPA "ɔ"
    Pure NearOpen Front Unrounded -> mkJustIPA "æ"
    Pure NearOpen Central Unrounded -> mkJustIPA "ɐ"
    Pure Open Front Unrounded -> mkJustIPA "a"
    Pure Open Front Rounded -> mkJustIPA "ɶ"
    Pure Open Central Unrounded -> mkJustIPA "ä"
    Pure Open Back Unrounded -> mkJustIPA "ɑ"
    Pure Open Back Rounded -> mkJustIPA "ɒ"
    Diphthongized v1@Pure {} v2@Pure {} -> (<>) <$> toIPA (Vowel v1)
        <*> toIPA (Vowel v2)
    Triphthongized v1@Pure {} v2@Pure {} v3@Pure {} -> do
        first <- toIPA $ Vowel v1
        second <- toIPA $ Vowel v2
        third <- toIPA $ Vowel v3
        return $ first <> second <> third
    _ -> Nothing

secondaryArticulation :: Segment -> Maybe IPA
secondaryArticulation = \case
    Consonant c -> case c of
        Pulmonic Voiced Bilabial Nasal -> mkJustIPA "\x1d50"
        Pulmonic Voiced LabioDental Nasal -> mkJustIPA "\x1dac"
        Pulmonic Voiced Alveolar Nasal -> mkJustIPA "\x207f"
        Pulmonic Voiced Retroflex Nasal -> mkJustIPA "\x1daf"
        Pulmonic Voiced Palatal Nasal -> mkJustIPA "\x1dae"
        Pulmonic Voiced Velar Nasal -> mkJustIPA "\x1d51"
        Pulmonic Voiced Uvular Nasal -> mkJustIPA "\x1db0"

        Pulmonic Voiced Bilabial Plosive -> mkJustIPA "\x1d56"
        Pulmonic Voiceless Bilabial Plosive -> mkJustIPA "\x1d47"
        Pulmonic Voiceless Alveolar Plosive -> mkJustIPA "\x1d57"
        Pulmonic Voiced Alveolar Plosive -> mkJustIPA "\x1d48"
        Pulmonic Voiceless Palatal Plosive -> mkJustIPA "\x1d9c"
        Pulmonic Voiced Palatal Plosive -> mkJustIPA "\x1da1"
        Pulmonic Voiceless Velar Plosive -> mkJustIPA "\x1d4f"
        Pulmonic Voiced Velar Plosive -> mkJustIPA "\x1da2"
        Pulmonic Voiceless Glottal Plosive -> mkJustIPA "\x02c0"

        Pulmonic Voiced Bilabial (Fricative NonSibilant) -> mkJustIPA "\x1db2"
        Pulmonic Voiceless Bilabial (Fricative NonSibilant) ->
            mkJustIPA "\x1d5d"
        Pulmonic Voiced LabioDental (Fricative NonSibilant) ->
            mkJustIPA "\x1da0"
        Pulmonic Voiceless LabioDental (Fricative NonSibilant) ->
            mkJustIPA "\x1d5b"
        Pulmonic Voiceless Dental (Fricative NonSibilant) -> mkJustIPA "\x1dbf"
        Pulmonic Voiced Dental (Fricative NonSibilant) -> mkJustIPA "\x1d9e"
        Pulmonic Voiceless Alveolar (Fricative Sibilant) -> mkJustIPA "\x02e2"
        Pulmonic Voiced Alveolar (Fricative Sibilant) -> mkJustIPA "\x1dbb"
        Pulmonic Voiceless PostAlveolar (Fricative Sibilant) ->
            mkJustIPA "\x1db4"
        Pulmonic Voiced PostAlveolar (Fricative Sibilant) -> mkJustIPA "\x1dbe"
        Pulmonic Voiceless Palatal (Fricative Sibilant) -> mkJustIPA "\x1d9d"
        Pulmonic Voiced Palatal (Fricative Sibilant) -> mkJustIPA "\x1dbd"
        Pulmonic Voiceless Palatal (Fricative NonSibilant) ->
            mkJustIPA "\x1d9c\x0327"
        Pulmonic Voiced Palatal (Fricative NonSibilant) -> mkJustIPA "\x1da8"
        Pulmonic Voiceless Velar (Fricative NonSibilant) -> mkJustIPA "\x02e3"
        Pulmonic Voiced Velar (Fricative NonSibilant) -> mkJustIPA "\x02e0"
        Pulmonic Voiceless Uvular (Fricative NonSibilant) -> mkJustIPA "\x1d61"
        Pulmonic Voiced Uvular (Fricative NonSibilant) -> mkJustIPA "\x02b6"
        Pulmonic Voiceless Glottal (Fricative NonSibilant) ->
            mkJustIPA "\x02b0"
        Pulmonic Voiced Glottal (Fricative NonSibilant) -> mkJustIPA "\x02b1"

        Pulmonic Voiced LabioDental Approximant -> mkJustIPA "\x1db9"
        Pulmonic Voiced Alveolar Approximant -> mkJustIPA "\x02b4"
        Pulmonic Voiced Retroflex Approximant -> mkJustIPA "\x02b5"
        Pulmonic Voiced Palatal Approximant -> mkJustIPA "\x02b2"
        Pulmonic Voiceless Velar Approximant -> mkJustIPA "\xab69"
        Pulmonic Voiced Velar Approximant -> mkJustIPA "\x1dad"

        Pulmonic Voiced Alveolar Trill -> mkJustIPA "\x02b3"

        _ -> Nothing

    PureVowel Close Front Unrounded -> mkJustIPA "\x2071"
    PureVowel Close Front Rounded -> mkJustIPA "\x02b8"
    PureVowel Close Central Unrounded -> mkJustIPA "\x1da4"
    PureVowel Close Central Rounded -> mkJustIPA "\x1db6"
    PureVowel Close Back Unrounded -> mkJustIPA "\x1d5a"
    PureVowel Close Back Rounded -> mkJustIPA "\x1d58"
    PureVowel NearClose Front Unrounded -> mkJustIPA "\x1da6"
    PureVowel NearClose Central Unrounded -> mkJustIPA "\x1da7"
    PureVowel NearClose Back Rounded -> mkJustIPA "\x1db7"
    PureVowel Mid Central Unrounded -> mkJustIPA "\x1d4a"
    PureVowel Mid Central Rounded -> mkJustIPA "\x1d4a"
    PureVowel OpenMid Front Unrounded -> mkJustIPA "\x1d4b"
    PureVowel OpenMid Front Rounded -> mkJustIPA "\xa7f9"
    PureVowel OpenMid Central Unrounded -> mkJustIPA "\x1d9f"
    PureVowel OpenMid Back Unrounded -> mkJustIPA "\x1dba"
    PureVowel OpenMid Back Rounded -> mkJustIPA "\x1d53"
    PureVowel NearOpen Front Unrounded -> mkJustIPA "\x1d46"
    PureVowel NearOpen Central Unrounded -> mkJustIPA "\x1d44"
    PureVowel NearOpen Back Unrounded -> mkJustIPA "\x1d45"
    PureVowel NearOpen Back Rounded -> mkJustIPA "\x1d9b"
    PureVowel Open Front Unrounded -> mkJustIPA "\x1d43"
    PureVowel Open Back Rounded -> mkJustIPA "\x1d44"

    _ -> Nothing

-------------------------------------------------------------------------------
--                                  X-SAMPA                                  --
-------------------------------------------------------------------------------
mkXSampaOp :: ReprXSampa a => (b -> Maybe XSampa) -> a -> b -> Maybe XSampa
mkXSampaOp f x y = (<>) <$> toXSampa x <*> f y

doubleArticulatedXSampa :: Text -> Text -> Text
doubleArticulatedXSampa x y = x <> "_" <> y

-- X-SAMPA quite inexplicably uses a backslash as a semantic token
xSlash :: Text -> Text
xSlash = (<> "\\")

rhoticXSampa :: Text -> Text
rhoticXSampa = (<> "`")

vowelXSampa :: Vowel -> Maybe XSampa
vowelXSampa = \case
    Pure Close Front Unrounded -> mkXSampa "i"
    Pure Close Front Rounded -> mkXSampa "y"
    Pure Close Central Unrounded -> mkXSampa "1"
    Pure Close Central Rounded -> mkXSampa "}"
    Pure Close Back Unrounded -> mkXSampa "M"
    Pure Close Back Rounded -> mkXSampa "u"
    Pure NearClose Front Unrounded -> mkXSampa "I"
    Pure NearClose Front Rounded -> mkXSampa "Y"
    Pure NearClose Back Rounded -> mkXSampa "U"
    Pure CloseMid Front Unrounded -> mkXSampa "e"
    Pure CloseMid Front Rounded -> mkXSampa "2"
    Pure CloseMid Central Unrounded -> mkXSampa $ xSlash "@"
    Pure CloseMid Central Rounded -> mkXSampa "8"
    Pure CloseMid Back Unrounded -> mkXSampa "7"
    Pure CloseMid Back Rounded -> mkXSampa "o"
    Pure Mid Front Unrounded -> toXSampa
        $ WithSegmentalFeature Lowered (Vowel $ Pure CloseMid Front Unrounded)
    Pure Mid Front Rounded -> toXSampa
        $ WithSegmentalFeature Lowered (Vowel $ Pure CloseMid Front Rounded)
    Pure Mid Central Unrounded -> mkXSampa "@"
    Pure Mid Back Unrounded -> toXSampa
        $ WithSegmentalFeature Lowered (Vowel $ Pure CloseMid Back Unrounded)
    Pure Mid Back Rounded -> toXSampa
        $ WithSegmentalFeature Lowered (Vowel $ Pure CloseMid Back Unrounded)
    Pure OpenMid Front Unrounded -> mkXSampa "E"
    Pure OpenMid Front Rounded -> mkXSampa "9"
    Pure OpenMid Central Unrounded -> mkXSampa "3"
    Pure OpenMid Central Rounded -> mkXSampa $ xSlash "3"
    Pure OpenMid Back Unrounded -> mkXSampa "V"
    Pure OpenMid Back Rounded -> mkXSampa "O"
    Pure NearOpen Front Unrounded -> mkXSampa "{"
    Pure NearOpen Central Unrounded -> mkXSampa "6"
    Pure Open Front Unrounded -> mkXSampa "a"
    Pure Open Front Rounded -> mkXSampa "&"
    Pure Open Back Unrounded -> mkXSampa "A"
    Pure Open Back Rounded -> mkXSampa "Q"
    Diphthongized v1@Pure {} v2@Pure {} -> (<>) <$> toXSampa (Vowel v1)
        <*> toXSampa (Vowel v2)
    Triphthongized v1@Pure {} v2@Pure {} v3@Pure {} -> do
        first <- toXSampa $ Vowel v1
        second <- toXSampa $ Vowel v2
        third <- toXSampa $ Vowel v3
        return $ first <> second <> third
    _ -> Nothing

consonantXSampa :: Consonant -> Maybe XSampa
consonantXSampa = \case
    e@Ejective {} -> ejectiveXSampa e
    i@Implosive {} -> implosiveXSampa i

    -- Pulmonic consonants
    -- Bilabials
    Pulmonic Voiceless Bilabial Nasal -> toXSampa
        $ WithSegmentalFeature (Voicing Voiceless)
                               (PulmonicConsonant Voiced Bilabial Nasal)
    Pulmonic Voiced Bilabial Nasal -> mkXSampa "m"
    Pulmonic Voiced Bilabial Plosive -> mkXSampa "b"
    Pulmonic Voiceless Bilabial Plosive -> mkXSampa "p"
    Pulmonic Voiceless Bilabial (Fricative NonSibilant) ->
        mkXSampa $ xSlash "p"
    Pulmonic Voiced Bilabial (Fricative NonSibilant) -> mkXSampa "B"
    Pulmonic Voiced Bilabial Trill -> mkXSampa $ xSlash "B"

    -- Labio-dentals
    Pulmonic Voiced LabioDental Nasal -> mkXSampa "F"
    Pulmonic Voiceless LabioDental (Fricative NonSibilant) -> mkXSampa "f"
    Pulmonic Voiced LabioDental (Fricative NonSibilant) -> mkXSampa "v"
    Pulmonic Voiced LabioDental Approximant -> mkXSampa "P"

    -- Dentals
    Pulmonic Voiceless Dental (Fricative NonSibilant) -> mkXSampa "T"
    Pulmonic Voiced Dental (Fricative NonSibilant) -> mkXSampa "D"

    -- Alveolars
    Pulmonic Voiceless Alveolar Nasal -> toXSampa
        $ WithSegmentalFeature (Voicing Voiceless)
                               (PulmonicConsonant Voiced Alveolar Nasal)
    Pulmonic Voiced Alveolar Nasal -> mkXSampa "n"
    Pulmonic Voiceless Alveolar Plosive -> mkXSampa "t"
    Pulmonic Voiced Alveolar Plosive -> mkXSampa "d"
    Pulmonic Voiceless Alveolar (Affricate Sibilant) ->
        mkXSampa $ doubleArticulatedXSampa "t" "s"
    Pulmonic Voiced Alveolar (Affricate Sibilant) ->
        mkXSampa $ doubleArticulatedXSampa "d" "z"
    Pulmonic Voiceless Alveolar (Fricative Sibilant) -> mkXSampa "s"
    Pulmonic Voiced Alveolar (Fricative Sibilant) -> mkXSampa "z"
    Pulmonic Voiced Alveolar Approximant -> mkXSampa $ xSlash "r"
    Pulmonic Voiceless Alveolar Flap -> toXSampa
        $ WithSegmentalFeature (Voicing Voiceless)
                               (PulmonicConsonant Voiced Alveolar Flap)
    Pulmonic Voiced Alveolar Flap -> mkXSampa "4"
    Pulmonic Voiced Alveolar Trill -> mkXSampa "r"
    Pulmonic Voiceless Alveolar Trill -> toXSampa
        $ WithSegmentalFeature (Voicing Voiceless)
                               (PulmonicConsonant Voiced Alveolar Trill)
    Pulmonic Voiceless Alveolar LateralFricative -> mkXSampa "K"
    Pulmonic Voiced Alveolar LateralFricative -> mkXSampa $ xSlash "K"
    Pulmonic Voiced Alveolar LateralApproximant -> mkXSampa "l"

    -- Post-alveolars
    Pulmonic Voiceless PostAlveolar (Affricate Sibilant) ->
        mkXSampa $ doubleArticulatedXSampa "t" "S"
    Pulmonic Voiced PostAlveolar (Affricate Sibilant) ->
        mkXSampa $ doubleArticulatedXSampa "d" "Z"
    Pulmonic Voiceless PostAlveolar (Fricative Sibilant) -> mkXSampa "S"
    Pulmonic Voiced PostAlveolar (Fricative Sibilant) -> mkXSampa "Z"

    -- Retroflexes
    Pulmonic Voiceless Retroflex Nasal -> toXSampa
        $ WithSegmentalFeature (Voicing Voiceless)
                               (PulmonicConsonant Voiced Retroflex Nasal)
    Pulmonic Voiced Retroflex Nasal -> mkXSampa $ rhoticXSampa "n"
    Pulmonic Voiceless Retroflex Plosive -> mkXSampa $ rhoticXSampa "t"
    Pulmonic Voiced Retroflex Plosive -> mkXSampa $ rhoticXSampa "d"
    Pulmonic Voiceless Retroflex (Affricate Sibilant) -> mkXSampa
        $ (doubleArticulatedXSampa `on` rhoticXSampa) "t" "s"
    Pulmonic Voiced Retroflex (Affricate Sibilant) -> mkXSampa
        $ (doubleArticulatedXSampa `on` rhoticXSampa) "d" "z"
    Pulmonic Voiceless Retroflex (Fricative Sibilant) ->
        mkXSampa $ rhoticXSampa "s"
    Pulmonic Voiced Retroflex (Fricative Sibilant) ->
        mkXSampa $ rhoticXSampa "z"
    Pulmonic Voiced Retroflex Approximant ->
        mkXSampa . xSlash $ rhoticXSampa "r"
    Pulmonic Voiceless Retroflex Flap -> toXSampa
        $ WithSegmentalFeature (Voicing Voiceless)
                               (PulmonicConsonant Voiced Retroflex Nasal)
    Pulmonic Voiced Retroflex Flap -> mkXSampa $ rhoticXSampa "r"
    Pulmonic Voiceless Retroflex LateralApproximant -> toXSampa
        $ WithSegmentalFeature (Voicing Voiceless)
                               (PulmonicConsonant Voiced Retroflex Nasal)
    Pulmonic Voiced Retroflex LateralApproximant ->
        mkXSampa $ rhoticXSampa "l"

    -- Palatals
    Pulmonic Voiced Palatal Nasal -> mkXSampa "J"
    Pulmonic Voiceless Palatal Plosive -> mkXSampa "c"
    Pulmonic Voiced Palatal Plosive -> mkXSampa $ xSlash "J"
    Pulmonic Voiceless Palatal (Affricate Sibilant) -> mkXSampa
        $ doubleArticulatedXSampa "t" (xSlash "s")
    Pulmonic Voiced Palatal (Affricate Sibilant) -> mkXSampa
        $ doubleArticulatedXSampa "d" (xSlash "z")
    Pulmonic Voiceless Palatal (Fricative Sibilant) -> mkXSampa $ xSlash "s"
    Pulmonic Voiced Palatal (Fricative Sibilant) -> mkXSampa $ xSlash "z"
    Pulmonic Voiceless Palatal (Fricative NonSibilant) -> mkXSampa "C"
    Pulmonic Voiced Palatal (Fricative NonSibilant) -> mkXSampa $ xSlash "j"
    Pulmonic Voiced Palatal Approximant -> mkXSampa "j"
    Pulmonic Voiced Palatal LateralApproximant -> mkXSampa "L"

    -- Velars
    Pulmonic Voiceless Velar Nasal -> toXSampa
        $ WithSegmentalFeature (Voicing Voiceless)
                               (PulmonicConsonant Voiced Velar Nasal)
    Pulmonic Voiced Velar Nasal -> mkXSampa "N"
    Pulmonic Voiceless Velar Plosive -> mkXSampa "k"
    Pulmonic Voiced Velar Plosive -> mkXSampa "g"
    Pulmonic Voiceless Velar (Affricate NonSibilant) ->
        mkXSampa $ doubleArticulatedXSampa "k" "x"
    Pulmonic Voiced Velar (Affricate NonSibilant) ->
        mkXSampa $ doubleArticulatedXSampa "g" "G"
    Pulmonic Voiceless Velar (Fricative NonSibilant) -> mkXSampa "x"
    Pulmonic Voiced Velar (Fricative NonSibilant) -> mkXSampa "G"
    Pulmonic Voiced Velar Approximant -> mkXSampa $ xSlash "m"
    Pulmonic Voiced Velar LateralApproximant -> mkXSampa $ xSlash "L"

    -- Uvulars
    Pulmonic Voiced Uvular Nasal -> mkXSampa $ xSlash "N"
    Pulmonic Voiceless Uvular Plosive -> mkXSampa "q"
    Pulmonic Voiced Uvular Plosive -> mkXSampa $ xSlash "G"
    Pulmonic Voiceless Uvular (Affricate NonSibilant) ->
        mkXSampa $ doubleArticulatedXSampa "q" "X"
    Pulmonic Voiced Uvular (Affricate NonSibilant) -> mkXSampa
        $ doubleArticulatedXSampa (xSlash "G") "R"
    Pulmonic Voiceless Uvular (Fricative NonSibilant) -> mkXSampa "X"
    Pulmonic Voiced Uvular (Fricative NonSibilant) -> mkXSampa "R"
    Pulmonic Voiceless Uvular Trill -> toXSampa
        $ WithSegmentalFeature (Voicing Voiceless)
                               (PulmonicConsonant Voiced Uvular Trill)
    Pulmonic Voiced Uvular Trill -> mkXSampa $ xSlash "R"

    -- Pharyngeals
    Pulmonic Voiceless Pharyngeal (Fricative NonSibilant) ->
        mkXSampa $ xSlash "X"
    Pulmonic Voiced Pharyngeal (Fricative NonSibilant) ->
        mkXSampa $ xSlash "?"

    -- Glottals
    Pulmonic Voiceless Glottal Plosive -> mkXSampa "?"
    Pulmonic Voiceless Glottal (Affricate NonSibilant) -> mkXSampa
        $ doubleArticulatedXSampa "?" (xSlash "h")
    Pulmonic Voiceless Glottal (Fricative NonSibilant) -> mkXSampa "h"
    Pulmonic Voiced Glottal (Fricative NonSibilant) -> mkXSampa $ xSlash "h"

    -- Implosives
    -- Clicks
    Click Bilabial -> mkXSampa $ xSlash "O"
    Click Dental -> mkXSampa $ xSlash "|"
    Click Alveolar -> mkXSampa $ xSlash "!"
    Click PostAlveolar -> mkXSampa $ xSlash "|" <> xSlash "|"
    Click Palatal -> mkXSampa $ xSlash "="

    -- Double articulation
    DoublyArticulated Voiced Bilabial Alveolar Nasal ->
        mkXSampa $ doubleArticulatedXSampa "n" "m"
    DoublyArticulated Voiceless Bilabial Alveolar Plosive ->
        mkXSampa $ doubleArticulatedXSampa "t" "p"
    DoublyArticulated Voiced Bilabial Alveolar Plosive ->
        mkXSampa $ doubleArticulatedXSampa "d" "b"
    DoublyArticulated Voiced Bilabial Velar Nasal ->
        mkXSampa $ doubleArticulatedXSampa "N" "m"
    DoublyArticulated Voiceless Bilabial Velar Plosive ->
        mkXSampa $ doubleArticulatedXSampa "k" "p"
    DoublyArticulated Voiced Bilabial Velar Plosive ->
        mkXSampa $ doubleArticulatedXSampa "g" "b"
    DoublyArticulated Voiceless Bilabial Palatal (Fricative NonSibilant) ->
        toXSampa
        $ WithSegmentalFeature --
        (Voicing Voiceless)
        (Consonant (DoublyArticulated Voiced Bilabial Palatal Approximant))
    DoublyArticulated Voiced Bilabial Palatal Approximant -> mkXSampa "H"
    DoublyArticulated Voiceless Bilabial Velar (Fricative NonSibilant) ->
        mkXSampa "W"
    DoublyArticulated Voiced Bilabial Velar Approximant -> mkXSampa "w"
    DoublyArticulated Voiceless PostAlveolar Velar (Fricative Sibilant) ->
        mkXSampa $ xSlash "x"
    DoublyArticulated Voiceless LabioDental Velar (Fricative Sibilant) ->
        mkXSampa $ xSlash "x"

    _ -> Nothing

ejectiveXSampa :: Consonant -> Maybe XSampa
ejectiveXSampa c = (<>) <$> getEj c <*> pure ej >>= mkXSampa
  where
    ej    = "_>"

    getEj = \case
        Ejective Bilabial Plosive -> Just "p"
        Ejective Bilabial (Fricative NonSibilant) -> Just $ xSlash "p"
        Ejective Dental (Fricative NonSibilant) -> Just "T"
        Ejective Alveolar Plosive -> Just "t"
        Ejective Alveolar (Affricate Sibilant) ->
            Just $ doubleArticulatedXSampa "t" "s"
        Ejective Alveolar (Fricative Sibilant) -> Just "s"
        Ejective PostAlveolar (Affricate Sibilant) ->
            Just $ doubleArticulatedXSampa "t" "S"
        Ejective PostAlveolar (Fricative Sibilant) -> Just "S"
        Ejective Retroflex Plosive -> Just $ rhoticXSampa "t"
        Ejective Retroflex (Affricate Sibilant) -> Just
            $ (doubleArticulatedXSampa `on` rhoticXSampa) "t" "s"
        Ejective Retroflex (Fricative Sibilant) -> Just $ rhoticXSampa "s"
        Ejective Palatal Plosive -> Just "c"
        Ejective Palatal (Affricate Sibilant) -> Just
            $ doubleArticulatedXSampa "t" (xSlash "s")
        Ejective Palatal (Fricative Sibilant) -> Just $ xSlash "s"
        Ejective Velar Plosive -> Just "k"
        Ejective Velar (Affricate NonSibilant) ->
            Just $ doubleArticulatedXSampa "k" "x"
        Ejective Velar (Fricative NonSibilant) -> Just "x"
        Ejective Uvular Plosive -> Just "q"
        Ejective Uvular (Affricate NonSibilant) ->
            Just $ doubleArticulatedXSampa "q" "X"
        Ejective Uvular (Fricative NonSibilant) -> Just "X"
        _ -> Nothing

implosiveXSampa :: Consonant -> Maybe XSampa
implosiveXSampa (Implosive Voiceless place) = toXSampa
    $ WithSegmentalFeature (Voicing Voiceless)
                           (ImplosiveConsonant Voiced place)
implosiveXSampa c = (<>) <$> getImpl c <*> pure impl >>= mkXSampa
  where
    impl    = "_<"

    getImpl = \case
        Implosive Voiced Bilabial -> Just "b"
        Implosive Voiced Alveolar -> Just "d"
        Implosive Voiced Retroflex -> Just $ rhoticXSampa "d"
        Implosive Voiced Palatal -> Just "f"
        Implosive Voiced Velar -> Just "g"
        Implosive Voiced Uvular -> Just "G"
        _ -> Nothing

withSegmentalFeatureXSampa :: Segment -> SegmentalFeature -> Maybe XSampa
withSegmentalFeatureXSampa s = \case
    Voicing v -> mkXSampaOp xSampaVoicing s v
      where
        xSampaVoicing = \case
            Voiceless -> mkXSampa "_0"
            Voiced    -> mkXSampa "_v"
    Length l -> mkXSampaOp xSampaLength s l
      where
        xSampaLength = \case
            OverLong   -> mkXSampa "::"
            Long       -> mkXSampa ":"
            HalfLong   -> mkXSampa $ xSlash ":"
            Short      -> mkXSampa mempty
            ExtraShort -> mkXSampa "_X"
    SecondaryArticulation _ -> Nothing
    feature -> (<>) <$> toXSampa s <*> case feature of
        Aspirated           -> mkXSampa "_h"
        MoreRounded         -> mkXSampa "_O"
        LessRounded         -> mkXSampa "_c"
        Advanced            -> mkXSampa "_+"
        Retracted           -> mkXSampa "_-"
        Centralized         -> mkXSampa "_\""
        MidCentralized      -> mkXSampa "_x"
        Syllabic            -> mkXSampa "="
        NonSyllabic         -> mkXSampa "_^"
        Rhotacized          -> mkXSampa "`"
        BreathyVoice        -> mkXSampa "_t"
        CreakyVoice         -> mkXSampa "_k"
        Labialized          -> mkXSampa "_w"
        Palatalized         -> mkXSampa "'"
        Velarized           -> mkXSampa "_G"
        Pharyngealized      -> mkXSampa $ xSlash "_?"
        Raised              -> mkXSampa "_r"
        Lowered             -> mkXSampa "_o"
        AdvancedTongueRoot  -> mkXSampa "_A"
        RetractedTongueRoot -> mkXSampa "_q"
        Dentalized          -> mkXSampa "_d"
        Apical              -> mkXSampa "_a"
        Laminal             -> mkXSampa "_m"
        Nasalized           -> mkXSampa "~"
        LateralRelease      -> mkXSampa "_l"
        NoAudibleRelease    -> mkXSampa "_}"
        _                   -> Nothing

withSuprasegmentalFeatureXSampa
    :: MultiSegment t => Syllable t -> SuprasegmentalFeature -> Maybe XSampa
withSuprasegmentalFeatureXSampa s = \case
    LevelLexicalTone tone -> mkXSampaOp xsampaTone s tone
      where
        xsampaTone = \case
            ExtraHighTone -> mkXSampa "_T"
            HighTone      -> mkXSampa "_H"
            MidTone       -> mkXSampa "_M"
            LowTone       -> mkXSampa "_L"
            ExtraLowTone  -> mkXSampa "_B"
            DownStep      -> mkXSampa "!"
            UpStep        -> mkXSampa "^"

    LevelLexicalToneDiacritic tone -> toXSampa
        $ WithSuprasegmentalFeature (LevelLexicalTone tone) s

    LexicalToneContour tone -> mkXSampaOp xsampaToneContour s tone
      where
        xsampaToneContour = \case
            Rising        -> mkXSampa "_R"
            Falling       -> mkXSampa "_F"
            HighRising    -> mkXSampa "_H_T"
            LowRising     -> mkXSampa "_B_L"
            HighFalling   -> mkXSampa "_H_F"
            LowFalling    -> mkXSampa "_L_B"
            RisingFalling -> mkXSampa "_R_F"
            FallingRising -> mkXSampa "_F_R"
            GlobalRise    -> mkXSampa "<R>"
            GlobalFall    -> mkXSampa "<F>"

    LexicalToneContourDiacritic tone -> toXSampa
        $ WithSuprasegmentalFeature (LexicalToneContour tone) s

    Stress stress -> mkXSampaOp xsampaStress s stress
      where
        xsampaStress Primary   = mkXSampa "\""
        xsampaStress Secondary = mkXSampa "%"

    -- Explicit syllable break
    Break -> (<>) <$> toXSampa s <*> mkXSampa "."

    -- Syllable non-break
    Linking -> (<>) <$> toXSampa s <*> mkXSampa (xSlash "-")

    _ -> Nothing