{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeApplications #-}

-- |
module Main where

import           Data.Either   ( isLeft )
import           Data.Foldable ( for_, traverse_ )
import           Data.Maybe    ( isNothing )

import           Language.IPA

import           Test.Hspec    ( describe
                               , hspec
                               , it
                               , shouldBe
                               , shouldSatisfy
                               )

{- HLINT ignore "Redundant do" -}
main :: IO ()
main = ipa >> xsampa >> parser >> parserXSampa >> qq >> delim

ipa :: IO ()
ipa = hspec $ do
    describe "Segments" $ do
        it "Rejects nonsense segments" $ do
            let phones = toIPA
                    <$> [ PulmonicConsonant Voiceless
                                            Uvular
                                            (Fricative Sibilant)
                        , PulmonicConsonant Voiced Velar Flap
                        , PulmonicConsonant Voiced Pharyngeal Plosive
                        , PulmonicConsonant Voiceless Glottal Trill
                        , PureVowel NearClose Central Unrounded
                        , PureVowel NearOpen Back Rounded
                        ]
            traverse_ (`shouldSatisfy` isNothing) phones

    describe "Segmental features" $ do
        it "Correctly makes 'Short' a noop" $ do
            let vcfu   = PureVowel Close Front Unrounded
                i      = toIPA' vcfu
                iShort = toIPA' $ WithSegmentalFeature (Length Short) vcfu

            i `shouldBe` iShort

        it "Chains articulatory features" $ do
            let vowel       = PureVowel Close Back Unrounded
                IPA chained = toIPA'
                    $ WithSegmentalFeature (Length OverLong)
                                           (WithSegmentalFeature Compressed
                                                                 vowel)
            chained `shouldBe` "ɯᵝːː"

    describe "Suprasegmentals" $ do
        it "Preserves individual segments and order" $ do
            let segments = [ ImplosiveConsonant Voiced Bilabial
                           , PureVowel CloseMid Back Unrounded
                           ]
                IPA syll = toIPA' $ Syllable segments
            syll `shouldBe` "ɓɤ"

    describe "Suprasegmental features" $ do
        it "Chains articulatory features" $ do
            let segments    = [ PulmonicConsonant Voiced Alveolar Plosive
                              , PureVowel CloseMid Back Rounded
                              ]
                syll        = Syllable segments
                tone        = LexicalToneContour Rising
                IPA chained = toIPA'
                    $ WithSuprasegmentalFeature --
                    (Stress Primary)
                    (WithSuprasegmentalFeature tone syll)
            chained `shouldBe` "do˩˥ˈ"

    describe "IPA normalization" $ do
        it "Normalizes IPA values to NFC" $ do
            let oRisingNFD     = "o\x0301" -- decomposed form
                IPA oRisingIPA = mkIPA oRisingNFD
            oRisingIPA `shouldBe` "\x00f3"

xsampa :: IO ()
xsampa = hspec $ do
    describe "Suprasegmentals" $ do
        it "Preserves individual segments and order" $ do
            let segments    = [ ImplosiveConsonant Voiced Bilabial
                              , PureVowel CloseMid Back Unrounded
                              ]
                XSampa syll = toXSampa' $ Syllable segments
            syll `shouldBe` "b_<7"

    describe "Segmental features" $ do
        it "Correctly makes 'Short' a noop" $ do
            let vcfu   = PureVowel Close Front Unrounded
                i      = toXSampa' vcfu
                iShort = toXSampa' $ WithSegmentalFeature (Length Short) vcfu

            i `shouldBe` iShort

        it "Chains articulatory features" $ do
            let vowel          = PureVowel Close Back Unrounded
                XSampa chained = toXSampa'
                    $ WithSegmentalFeature (Length OverLong)
                                           (WithSegmentalFeature Lowered vowel)
            chained `shouldBe` "M_o::"

    describe "Segments" $ do
        it "Rejects nonsense segments" $ do
            let phones = toXSampa
                    <$> [ PulmonicConsonant Voiceless
                                            Uvular
                                            (Fricative Sibilant)
                        , PulmonicConsonant Voiced Velar Flap
                        , PulmonicConsonant Voiced Pharyngeal Plosive
                        , PulmonicConsonant Voiceless Glottal Trill
                        , PureVowel NearClose Central Unrounded
                        , PureVowel NearOpen Back Rounded
                        ]
            traverse_ (`shouldSatisfy` isNothing) phones

    describe "Suprasegmental features" $ do
        it "Chains articulatory features" $ do
            let segments       = [ PulmonicConsonant Voiced Alveolar Plosive
                                 , PureVowel CloseMid Back Rounded
                                 ]
                syll           = Syllable segments
                tone           = LexicalToneContour Rising
                XSampa chained = toXSampa'
                    $ WithSuprasegmentalFeature --
                    (Stress Primary)
                    (WithSuprasegmentalFeature tone syll)
            chained `shouldBe` "do_R\""

parser :: IO ()
parser = hspec $ do
    describe "Segment parser" $ do
        it "Parses individual segments" $ do
            let char   = "β"
                parsed = parseIPA char
            parsed
                `shouldBe` Right --
                (PulmonicConsonant Voiced Bilabial (Fricative NonSibilant))

        it "Rejects multiple adjacent segments" $ do
            let char   = "ββ"
                parsed = parseIPA @Segment char
            parsed `shouldSatisfy` isLeft

        it "Parses segmental features" $ do
            let char   = "oʲ"
                parsed = parseIPA @Segment char
                j      = PulmonicConsonant Voiced Palatal Approximant
                o      = PureVowel CloseMid Back Rounded
            parsed
                `shouldBe` Right --
                (WithSegmentalFeature (SecondaryArticulation j) o)

        it "Parses multiple segmental features" $ do
            let char   = "ãͪ"
                parsed = parseIPA char
                a      = PureVowel Open Front Unrounded
            parsed
                `shouldBe` Right --
                (WithSegmentalFeature Nasalized
                                      (WithSegmentalFeature Aspirated a))

        it "Parses specific phones first" $ do
            let chars  = [ "k", "k͡x", "k͡xʼ" ]
                parsed = parseIPA <$> chars

                phones = [ PulmonicConsonant Voiceless Velar Plosive
                         , PulmonicConsonant Voiceless
                                             Velar
                                             (Affricate NonSibilant)
                         , EjectiveConsonant Velar (Affricate NonSibilant)
                         ]
            for_ (zip parsed phones) $ \(p, ph) -> p `shouldBe` Right ph

        it "Rejects invalid segments" $ do
            let chars  = [ "L", "Z", "C", "0" ]
                parsed = parseIPA @Segment <$> chars
            traverse_ (`shouldSatisfy` isLeft) parsed

    describe "Syllable parser" $ do
        it "Parses syllables" $ do
            let syll   = "ɣa"
                parsed = parseIPA syll
                gamma  =
                    PulmonicConsonant Voiced Velar (Fricative NonSibilant)
                a      = PureVowel Open Front Unrounded
            parsed `shouldBe` Right (Syllable [ gamma, a ])

        it "Parses suprasegmental features" $ do
            let syll   = "o˨"
                parsed = parseIPA syll
                o      = PureVowel CloseMid Back Rounded
                tone   = LevelLexicalTone LowTone
            parsed
                `shouldBe` Right --
                (WithSuprasegmentalFeature tone (Syllable [ o ]))

        it "Parses multiple suprasegmental features" $ do
            let syll   = "ˈő"
                parsed = parseIPA syll
                tone   = LevelLexicalToneDiacritic ExtraHighTone
                o      = PureVowel CloseMid Back Rounded
            parsed
                `shouldBe` Right --
                (WithSuprasegmentalFeature --
                 tone
                 (WithSuprasegmentalFeature (Stress Primary) (Syllable [ o ])))

        it "Rejects invalid syllables" $ do
            let syll   = "aL"
                parsed = parseIPA @(Syllable []) syll
            parsed `shouldSatisfy` isLeft

        it "Rejects multiple adjacent syllables" $ do
            let syll   = "aw.a"
                parsed = parseIPA @(Syllable []) syll
            parsed `shouldSatisfy` isLeft

        it "Parses multiple syllables" $ do
            let sylls  = "bɤ bɤ"
                parsed = parseSyllables sylls
                syll   = [ PulmonicConsonant Voiced Bilabial Plosive
                         , PureVowel CloseMid Back Unrounded
                         ]
            parsed `shouldBe` Right [ Syllable syll, Syllable syll ]

parserXSampa :: IO ()
parserXSampa = hspec $ do
    describe "Segment parser" $ do
        it "Parses individual segments" $ do
            let char   = "B"
                parsed = parseXSampa char
            parsed
                `shouldBe` Right --
                (PulmonicConsonant Voiced Bilabial (Fricative NonSibilant))

        it "Rejects multiple adjacent segments" $ do
            let char   = "BB"
                parsed = parseIPA @Segment char
            parsed `shouldSatisfy` isLeft

        it "Parses segmental features" $ do
            let char   = "o_G"
                parsed = parseXSampa @Segment char
                o      = PureVowel CloseMid Back Rounded
            parsed `shouldBe` Right (WithSegmentalFeature Velarized o)

        it "Parses multiple segmental features" $ do
            let char   = "a~_h"
                parsed = parseXSampa char
                a      = PureVowel Open Front Unrounded
            parsed
                `shouldBe` Right --
                (WithSegmentalFeature Nasalized
                                      (WithSegmentalFeature Aspirated a))

        it "Parses specific phones first" $ do
            let chars  = [ "k", "k_x", "k_x_>" ]
                parsed = parseXSampa <$> chars

                phones = [ PulmonicConsonant Voiceless Velar Plosive
                         , PulmonicConsonant Voiceless
                                             Velar
                                             (Affricate NonSibilant)
                         , EjectiveConsonant Velar (Affricate NonSibilant)
                         ]
            for_ (zip parsed phones) $ \(p, ph) -> p `shouldBe` Right ph

    describe "Syllable parser" $ do
        it "Parses syllables" $ do
            let syll   = "Ga"
                parsed = parseXSampa syll
                gamma  =
                    PulmonicConsonant Voiced Velar (Fricative NonSibilant)
                a      = PureVowel Open Front Unrounded
            parsed `shouldBe` Right (Syllable [ gamma, a ])

        it "Parses suprasegmental features" $ do
            let syll   = "o_L"
                parsed = parseXSampa syll
                o      = PureVowel CloseMid Back Rounded
                tone   = LevelLexicalTone LowTone
            parsed
                `shouldBe` Right --
                (WithSuprasegmentalFeature tone (Syllable [ o ]))

        it "Parses multiple suprasegmental features" $ do
            let syll   = "'o_T"
                parsed = parseXSampa syll
                tone   = LevelLexicalTone ExtraHighTone
                o      = PureVowel CloseMid Back Rounded
            parsed
                `shouldBe` Right --
                (WithSuprasegmentalFeature --
                 tone
                 (WithSuprasegmentalFeature (Stress Primary) (Syllable [ o ])))

        it "Rejects multiple adjacent syllables" $ do
            let syll   = "aw.a"
                parsed = parseXSampa @(Syllable []) syll
            parsed `shouldSatisfy` isLeft

        it "Parses multiple syllables" $ do
            let sylls  = "b7 b7"
                parsed = parseSyllablesXSampa sylls
                syll   = [ PulmonicConsonant Voiced Bilabial Plosive
                         , PureVowel CloseMid Back Unrounded
                         ]
            parsed `shouldBe` Right [ Syllable syll, Syllable syll ]

qq :: IO ()
qq = hspec $ do
    describe "Quasi-quoter" $ do
        it "Works for individual segments" $ do
            let segQQ = [segment|β|]
                beta  =
                    PulmonicConsonant Voiced Bilabial (Fricative NonSibilant)
            segQQ `shouldBe` beta

        it "Works for syllables" $ do
            let syllQQ  = [syllable|e˧˥|]
                syll    = Syllable [ Vowel (Pure CloseMid Front Unrounded) ]
                contour =
                    WithSuprasegmentalFeature (LexicalToneContour HighRising)

            syllQQ `shouldBe` contour syll

        it "Works with X-SAMPA" $ do
            let syllsQQ = [syllablesXS|?\ |]
                fric    = Consonant (Pulmonic Voiced
                                              Pharyngeal
                                              (Fricative NonSibilant))

            syllsQQ `shouldBe` [ Syllable [ fric ] ]

delim :: IO ()
delim = hspec $ do
    it "Transcribes segments" $ do
        let v              = PureVowel Close Back Unrounded
            asIPA          = toIPA' v
            asXSampa       = toXSampa' v
            phoneticIPA    = transcribe Phonetic asIPA
            phonemicIPA    = transcribe Phonemic asIPA
            phoneticXSampa = transcribeXSampa Phonetic asXSampa
            phonemicXSampa = transcribeXSampa Phonemic asXSampa

        phoneticIPA `shouldBe` "[ɯ]"
        phonemicIPA `shouldBe` "/ɯ/"
        phoneticXSampa `shouldBe` "[M]"
        phonemicXSampa `shouldBe` "/M/"