{-# 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

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 syllable = toIPA' $ Syllable segments
            syllable `shouldBe` "ɓɤ"

    describe "Suprasegmental features" $ do
        it "Chains articulatory features" $ do
            let segments    = [ PulmonicConsonant Voiced Alveolar Plosive
                              , PureVowel CloseMid Back Rounded
                              ]
                syllable    = Syllable segments
                tone        = LexicalToneContour Rising
                IPA chained = toIPA'
                    $ WithSuprasegmentalFeature --
                    (Stress Primary)
                    (WithSuprasegmentalFeature tone syllable)
            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 syllable = toXSampa' $ Syllable segments
            syllable `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
                                 ]
                syllable       = Syllable segments
                tone           = LexicalToneContour Rising
                XSampa chained = toXSampa'
                    $ WithSuprasegmentalFeature --
                    (Stress Primary)
                    (WithSuprasegmentalFeature tone syllable)
            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 syllable = "ɣa"
                parsed   = parseIPA syllable
                gamma    =
                    PulmonicConsonant Voiced Velar (Fricative NonSibilant)
                a        = PureVowel Open Front Unrounded
            parsed `shouldBe` Right (Syllable [ gamma, a ])

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

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

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

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

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

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 syllable = "Ga"
                parsed   = parseXSampa syllable
                gamma    =
                    PulmonicConsonant Voiced Velar (Fricative NonSibilant)
                a        = PureVowel Open Front Unrounded
            parsed `shouldBe` Right (Syllable [ gamma, a ])

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

        it "Parses multiple suprasegmental features" $ do
            let syllable = "'o_T"
                parsed   = parseXSampa syllable
                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 syllable = "aw.a"
                parsed   = parseXSampa @(Syllable []) syllable
            parsed `shouldSatisfy` isLeft

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