{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- Module      : Language.IPA.Types
-- Copyright   : (c) 2021 Rory Tyler Hayford
-- License     : BSD-3-Clause
-- Maintainer  : rory.hayford@protonmail.com
-- Stability   : experimental
-- Portability : GHC
--
--  Types representing segments representable in the IPA
module Language.IPA.Types
    ( -- * Notation systems
      IPA(..)
    , mkIPA
    , XSampa(..)
    , mkXSampa
      -- * Segments
    , Segment(..)
      -- ** Consonants (pulmonic and non-pulmonic)
    , Consonant(..)
      -- *** Convenience patterns
      -- $pat
    , pattern PulmonicConsonant
    , pattern EjectiveConsonant
    , pattern ClickConsonant
    , pattern ImplosiveConsonant
    , pattern DoublyArticulatedConsonant
      -- *** Consonant features
    , Manner(..)
    , Place(..)
    , Phonation(..)
    , Sibilance(..)
      -- ** Vowels
    , Vowel(..)
      -- *** Convenience patterns
    , pattern PureVowel
    , pattern Diphthong
    , pattern Triphthong
      -- *** Vowel features
    , Height(..)
    , Backness(..)
    , Roundedness(..)
      -- * Suprasegmentals
    , MultiSegment
    , Syllable(..)
      -- ** Suprasegmental features
    , SuprasegmentalFeature(..)
    , ToneContour(..)
    , LevelTone(..)
    , Stress(..)
      -- ** Segmental articulatory features
    , Length(..)
    , SegmentalFeature(..)
      -- * Transcription delimiters
    , Delimiter(..)
      -- * Errors
    , IPAException(..)
    ) where

import           Control.Exception          ( Exception )

import           Data.Char                  ( isAscii )
import           Data.Data                  ( Data )
import           Data.Dynamic               ( Typeable )
import           Data.Text                  ( Text )
import qualified Data.Text                  as T
import           Data.Text.Normalize        ( NormalizationMode(NFC)
                                            , normalize
                                            )

import           GHC.Generics               ( Generic )

import           Language.Haskell.TH.Syntax ( Lift )

-- | Textual representation of a speech segment or grouping of segments, with
-- zero or more articulatory features; encoded in IPA transcription. Note this
-- has a 'Semigroup' instance, so various 'IPA's can conveniently be concatenated
-- with @<>@
newtype IPA = IPA
    { unIPA :: Text
      -- ^ The 'Text' value should be 'normalize'd to 'NFC'
    }
    deriving ( Show, Eq, Generic, Semigroup )

-- | 'normalize's 'Text' value to 'NFC' before wrapping it in 'IPA'. This is to
-- ensure the comparability of 'IPA' values
mkIPA :: Text -> IPA
mkIPA = IPA . normalize NFC

-- | X-SAMPA is an ASCII encoding of the IPA (ca. 1993). Note that fewer
-- transcriptions are possible using X-SAMPA than the IPA, so certain valid
-- 'IPA' 'Segment's have no direct equivalence using 'XSampa'. As with 'IPA',
-- 'XSampa' is an instance of 'Semigroup'
newtype XSampa = XSampa
    { unXSampa :: Text
      -- ^ The wrapped 'Text' should only contain ASCII characters
    }
    deriving ( Show, Eq, Generic, Semigroup )

-- | Wraps a 'Text' value in 'XSampa', provided the text only contains ASCII
-- characters
mkXSampa :: Text -> Maybe XSampa
mkXSampa t
    | T.all isAscii t = Just $ XSampa t
    | otherwise = Nothing

-- | A single segment, or combination of a segment and articulatory feature
data Segment
    = Consonant Consonant -- ^ Pulmonic and non-pulmonic consonants
    | Vowel Vowel -- ^ Monoph-, diph-, and triphthongs
    | Zero -- ^ A null/zero phone
    | WithSegmentalFeature SegmentalFeature Segment -- ^ Various other articulatory features
    | Optional Segment
      -- ^ A segment that is conventionally surrounded by parentheses. This is not an
      -- official part of the IPA, but is nevertheless encountered fairly frequently
      -- in IPA notation in the wild
    deriving ( Show, Eq, Generic, Data, Lift )

-- | Multiple segments, or combination of multiple segments with
-- suprasegmental feature
data Syllable t
    = Syllable (t Segment)
      -- ^ A grouping of segments without extra suprasegmental information
    | WithSuprasegmentalFeature SuprasegmentalFeature (Syllable t)
      -- ^ Articulatory features that affect/encompass the entire syllable
    deriving ( Generic )

deriving instance Show (t Segment) => Show (Syllable t)

deriving instance Eq (t Segment) => Eq (Syllable t)

deriving instance (Data (t Segment), Typeable t) => Data (Syllable t)

deriving instance Lift (t Segment) => Lift (Syllable t)

-- | Constraint synonym for syllable containers
type MultiSegment t = (Applicative t, Traversable t, Monoid (t Segment))

-- | Pulmonic and non-pulmonic consonants
data Consonant
    = Pulmonic Phonation Place Manner
    | Ejective Place Manner
    | Implosive Phonation Place
    | Click Place -- ^ 'PostAlveolar' place represents a lateral click
    | DoublyArticulated Phonation Place Place Manner
    deriving ( Show, Eq, Generic, Data, Lift )

-- $pat
-- These are convenience patterns for creating different types of 'Consonant'
-- 'Segment's, as the nesting of data constructors might otherwise be somewhat
-- tiresome
pattern PulmonicConsonant :: Phonation -> Place -> Manner -> Segment
pattern PulmonicConsonant ph pl m = Consonant (Pulmonic ph pl m)

pattern EjectiveConsonant :: Place -> Manner -> Segment
pattern EjectiveConsonant pl m = Consonant (Ejective pl m)

pattern ClickConsonant :: Place -> Segment
pattern ClickConsonant pl = Consonant (Click pl)

pattern ImplosiveConsonant :: Phonation -> Place -> Segment
pattern ImplosiveConsonant ph pl = Consonant (Implosive ph pl)

pattern DoublyArticulatedConsonant
    :: Phonation -> Place -> Place -> Manner -> Segment
pattern DoublyArticulatedConsonant ph pl1 pl2 m =
    Consonant (DoublyArticulated ph pl1 pl2 m)

-- | Consonantal manner of articulation
data Manner
    = Nasal
    | Plosive
    | Fricative Sibilance
    | Affricate Sibilance
    | Approximant
    | Flap
    | Trill
    | LateralAffricate
    | LateralFricative
    | LateralApproximant
    | LateralFlap
    deriving ( Show, Eq, Generic, Data, Lift )

-- | Consonantal place of articulation
data Place
    = Bilabial
    | LabioDental
    | LinguoLabial
    | Dental
    | Alveolar
    | PostAlveolar
    | Retroflex
    | Palatal
    | Velar
    | Uvular
    | Pharyngeal
    | Glottal
    deriving ( Show, Eq, Generic, Ord, Data, Lift )

-- | Phonation (voicing)
data Phonation = Voiced | Voiceless
    deriving ( Show, Eq, Generic, Data, Lift )

-- | Sibilance for fricative consonants
data Sibilance = Sibilant | NonSibilant
    deriving ( Show, Eq, Generic, Data, Lift )

-- | Vowel type. Note that this type does not prevent the construction of
-- nonsensical vowel values such as @Diphthong (Diphthong ...) (Diphthong ...)@
data Vowel
    = Pure Height Backness Roundedness
    | Diphthongized Vowel Vowel
    | Triphthongized Vowel Vowel Vowel
    deriving ( Show, Eq, Generic, Data, Lift )

pattern PureVowel :: Height -> Backness -> Roundedness -> Segment
pattern PureVowel h b r = Vowel (Pure h b r)

pattern Diphthong :: Vowel -> Vowel -> Segment
pattern Diphthong v1 v2 = Vowel (Diphthongized v1 v2)

pattern Triphthong :: Vowel -> Vowel -> Vowel -> Segment
pattern Triphthong v1 v2 v3 = Vowel (Triphthongized v1 v2 v3)

-- | Vowel height
data Height = Close | NearClose | CloseMid | Mid | OpenMid | NearOpen | Open
    deriving ( Show, Eq, Generic, Data, Lift )

-- | Vowel backness
data Backness = Front | NearFront | Central | NearBack | Back
    deriving ( Show, Eq, Generic, Ord, Data, Lift )

-- | Vowel roundedness
data Roundedness = Rounded | Unrounded
    deriving ( Show, Eq, Generic, Data, Lift )

-- | Lexical tone with Chao-style tone letters
data LevelTone
    = ExtraHighTone
    | HighTone
    | MidTone
    | LowTone
    | ExtraLowTone
    | DownStep
    | UpStep
    deriving ( Show, Eq, Generic, Ord, Data, Lift )

-- | Lexical tone represented as a contour
data ToneContour
    = Rising
    | Falling
    | HighRising
    | LowRising
    | HighFalling
    | LowFalling
    | RisingFalling
    | FallingRising
    | GlobalRise
    | GlobalFall
    deriving ( Show, Eq, Generic, Ord, Data, Lift )

-- | Vowel length; also serves as a notation for consonant gemination in the IPA
data Length
    = OverLong
    | HalfLong
    | Long
    | Short
      -- ^ The default/unmarked length; using this constructor doesn't affect the
      -- default IPA representation of the segment
    | ExtraShort
    deriving ( Show, Eq, Generic, Ord, Data, Lift )

-- | Various articulatory features with a diacritic represenation in the IPA.
-- These can be combined with 'Segment's using the 'WithSegmentalFeature'
-- constructor of that type to produce a 'Segment' annotated with a given
-- articulatory feature, e.g.:
--
-- >>> toIPA $ WithSegmentalFeature (Length Long) (Vowel Close Front Unrounded)
-- Just (IPA "i\720") -- iː
data SegmentalFeature
    = Voicing Phonation
    | Length Length
    | SecondaryArticulation Segment
    | Aspirated
    | MoreRounded
    | LessRounded
    | Advanced
    | Retracted
    | Centralized
    | MidCentralized
    | Compressed
    | Syllabic
    | NonSyllabic
    | Rhotacized
    | BreathyVoice
    | CreakyVoice
    | LinguoLabialized
    | Labialized
    | Palatalized
    | Velarized
    | Pharyngealized
    | Raised
    | Lowered
    | AdvancedTongueRoot
    | RetractedTongueRoot
    | Dentalized
    | Apical
    | Laminal
    | Nasalized
    | NasalRelease
    | LateralRelease
    | NoAudibleRelease
    deriving ( Show, Eq, Generic, Data, Lift )

data Stress = Primary | Secondary
    deriving ( Show, Eq, Generic, Ord, Data, Lift )

data SuprasegmentalFeature
    = LevelLexicalTone LevelTone
      -- ^ Level lexical tones in Chao letters
    | LevelLexicalToneDiacritic LevelTone
      -- ^ Level lexical tones, diacritic. The tone is a combining character
    | LexicalToneContour ToneContour
      -- ^ Lexical tone contours in Chao letters
    | LexicalToneContourDiacritic ToneContour
      -- ^ Lexical tone contours, as diacritics. Each contour is a combining
      -- character
    | ToneNumber Int
    | Stress Stress -- ^ Syllable stress
    | Break -- ^ Explicit syllable break
    | Linking -- ^ Absence of a break
    deriving ( Show, Eq, Generic, Data, Lift )

-- | Transcription delimiters/brackets
data Delimiter
    = Phonetic -- ^ Actual pronunciation, transcribed with square brackets, [ .. ]
    | Phonemic -- ^ Abstract phonemic representation, transcribed with slashes, \/ .. \/
    deriving ( Show, Eq, Generic )

data IPAException = InvalidIPA Text | InvalidXSampa Text
    deriving ( Show, Eq, Generic )

instance Exception IPAException