diff --git a/CHANGELOG.org b/CHANGELOG.org --- a/CHANGELOG.org +++ b/CHANGELOG.org @@ -1,3 +1,6 @@ +* 0.3.1 ++ ~Delimiter~ type added along with ~transcribe~ and ~transcribeXSampa~ functions; these wrap values in IPA transcriptions delimiters ++ Various ~QuasiQuoter~ s added to make it easier to construct ~Syllable~ and ~Segment~ values in IPA notation * 0.3 + Breaking changes: - ~parseIPA~ method added to ~ReprIPA~ typeclass to parse values from text in IPA diff --git a/README.org b/README.org --- a/README.org +++ b/README.org @@ -18,6 +18,15 @@ message = T.putStrLn "Invalid or unrepresentable segment!" #+end_src +A ~QuasiQuoter~ can be used to construct values as well. You can provide text in IPA or X-SAMPA notation, to be transformed at compile time into ~Segment~ or ~Syllable~ values. For example: +#+begin_src haskell +{-# LANGUAGE QuasiQuotes #-} + +ezIPA :: Segment +ezIPA = [segment|x|] +-- Consonant (Pulmonic Voiceless Velar (Fricative NonSibilant)) + +#+end_src ~Segment~ and ~Syllable~ values can be adorned with additional articulatory information as well, and can further be nested to created more complex structures, e.g.: #+begin_src haskell someComplexVowel :: Segment @@ -54,8 +63,8 @@ This library is distributed under the BSD 3-Clause revised license. ** TODO TODO - [ ] Export constant values for common segments -- [ ] Convenience functions for wrapping IPA values in different transcription delimiters (phonemic, phonetic, etc...) +- [X] Convenience functions for wrapping IPA values in different transcription delimiters (phonemic, phonetic, etc...) - [X] Support for X-SAMPA transcription - [X] Support for IPA <-> X-SAMPA conversion - [X] Parsing and validation of user-supplied IPA and XSampa literals -- [ ] Quasi quoter for making segment construction somewhat less painful +- [X] Quasi quoter for making segment construction somewhat less painful diff --git a/ipa.cabal b/ipa.cabal --- a/ipa.cabal +++ b/ipa.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: ipa -version: 0.3 +version: 0.3.1 synopsis: Internal Phonetic Alphabet (IPA) description: See the README at https://gitlab.com/ngua/ipa-hs license: BSD-3-Clause @@ -29,15 +29,17 @@ library import: common-options, common-extensions build-depends: - , attoparsec ^>=0.13.2 - , base >=4.10 && <=5 - , text ^>=1.2.4 + , attoparsec ^>=0.13 + , base >=4.11 && <5 + , template-haskell >=2.14 && <2.18 + , text ^>=1.2 , unicode-transforms ^>=0.3.7 exposed-modules: Language.IPA Language.IPA.Class Language.IPA.Parser + Language.IPA.QQ Language.IPA.Types hs-source-dirs: src @@ -48,10 +50,10 @@ type: exitcode-stdio-1.0 hs-source-dirs: test build-depends: - , base - , hspec + , base >=4.13 && <5 + , hspec >=2.0 && <3.0 , ipa - , text + , text ^>=1.2 main-is: Main.hs default-language: Haskell2010 diff --git a/src/Language/IPA.hs b/src/Language/IPA.hs --- a/src/Language/IPA.hs +++ b/src/Language/IPA.hs @@ -15,9 +15,12 @@ -- -- Working with IPA\/X-SAMPA transcriptions and phonetic/phonemic values module Language.IPA - ( -- * Utilities - -- ** Conversion - ipaToXSampa + ( -- * Utilities + -- ** Transcription + transcribe + , transcribeXSampa + -- ** Conversion + , ipaToXSampa , xSampaToIpa -- ** Construction , toIPA' @@ -45,8 +48,25 @@ 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 delim IPA { .. } = start <> unIPA <> end + where + (start, end) = showDelims delim + +-- | As 'transcribe', for 'XSampa' values +transcribeXSampa :: Delimiter -> XSampa -> Text +transcribeXSampa delim XSampa { .. } = start <> unXSampa <> end + where + (start, end) = showDelims 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 @@ -172,3 +192,7 @@ | otherwise = case c of Pulmonic Voiced _ LateralApproximant -> True _ -> False + +showDelims :: Delimiter -> (Text, Text) +showDelims Phonetic = ("[", "]") +showDelims Phonemic = ("/", "/") diff --git a/src/Language/IPA/QQ.hs b/src/Language/IPA/QQ.hs new file mode 100644 --- /dev/null +++ b/src/Language/IPA/QQ.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + +-- | +module Language.IPA.QQ + ( -- * IPA + syllable + , segment + , syllables + -- * X-SAMPA + , segmentXS + , syllableXS + , syllablesXS + ) where + +import Control.Exception ( displayException ) + +import Data.Text ( Text ) +import qualified Data.Text as T + +import Language.Haskell.TH.Quote ( QuasiQuoter(..) ) +import Language.Haskell.TH.Syntax ( Lift(lift) ) +import Language.IPA.Parser + ( parseSegment + , parseSegmentXSampa + , parseSyllable + , parseSyllableXSampa + , parseSyllables + , parseSyllablesXSampa + ) +import Language.IPA.Types ( IPAException ) + +-- | Construct a compile-time 'Language.IPA.Types.Segment' using IPA notation +-- +-- >>> [segment|ɣ|] +-- Consonant (Pulmonic Voiced Velar (Fricative NonSibilant)) +segment :: QuasiQuoter +segment = liftQQ parseSegment + +-- | Construct a compile-time 'Language.IPA.Types.Syllable' using IPA notation +-- +-- >>> [syllable|ɣa˧˨|] +-- WithSuprasegmentalFeature (LexicalToneContour LowFalling) +-- (Syllable [ Consonant (Pulmonic Voiced Velar (Fricative NonSibilant)) +-- , Vowel (Pure Open Front Unrounded) +-- ]) +syllable :: QuasiQuoter +syllable = liftQQ (parseSyllable @[]) + +-- | Construct a compile-time @['Language.IPA.Types.Syllable']@ using IPA notation +syllables :: QuasiQuoter +syllables = liftQQ (parseSyllables @[]) + +-- | Construct a compile-time 'Language.IPA.Types.Segment' using X-SAMPA notation. +-- This may be more convenient than using text values - X-SAMPA inexplicably chose +-- to use backslashes as semantic tokens, which of course must be escaped +-- +-- >>> [segmentXS|?\|] +-- Consonant (Pulmonic Voiced Pharyngeal (Fricative NonSibilant)) +segmentXS :: QuasiQuoter +segmentXS = liftQQ parseSegmentXSampa + +-- | Construct a compile-time 'Language.IPA.Types.Syllable' using X-SAMPA notation +syllableXS :: QuasiQuoter +syllableXS = liftQQ (parseSyllableXSampa @[]) + +-- | Construct a compile-time @['Language.IPA.Types.Syllable']@ using +-- X-SAMPA notation +syllablesXS :: QuasiQuoter +syllablesXS = liftQQ (parseSyllablesXSampa @[]) + +liftQQ :: Lift a => (Text -> Either IPAException a) -> QuasiQuoter +liftQQ f = QuasiQuoter { .. } + where + quoteExp str = either (fail . displayException) lift (f $ T.pack str) + + quotePat _ = fail errorMsg + + quoteType _ = fail errorMsg + + quoteDec _ = fail errorMsg + + errorMsg = "Unsupported" diff --git a/src/Language/IPA/Types.hs b/src/Language/IPA/Types.hs --- a/src/Language/IPA/Types.hs +++ b/src/Language/IPA/Types.hs @@ -1,7 +1,10 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} @@ -58,19 +61,27 @@ -- ** Segmental articulatory features , Length(..) , SegmentalFeature(..) + -- * Transcription delimiters + , Delimiter(..) -- * Errors , IPAException(..) ) where -import Control.Exception ( Exception ) +import Control.Exception ( Exception ) -import Data.Char ( isAscii ) -import Data.Text ( Text ) -import qualified Data.Text as T -import Data.Text.Normalize ( NormalizationMode(NFC), normalize ) +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 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 @@ -113,7 +124,7 @@ -- ^ 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 ) + deriving ( Show, Eq, Generic, Data, Lift ) -- | Multiple segments, or combination of multiple segments with -- suprasegmental feature @@ -128,6 +139,10 @@ 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)) @@ -138,7 +153,7 @@ | Implosive Phonation Place | Click Place -- ^ 'PostAlveolar' place represents a lateral click | DoublyArticulated Phonation Place Place Manner - deriving ( Show, Eq, Generic ) + deriving ( Show, Eq, Generic, Data, Lift ) -- $pat -- These are convenience patterns for creating different types of 'Consonant' @@ -174,7 +189,7 @@ | LateralFricative | LateralApproximant | LateralFlap - deriving ( Show, Eq, Generic ) + deriving ( Show, Eq, Generic, Data, Lift ) -- | Consonantal place of articulation data Place @@ -190,23 +205,23 @@ | Uvular | Pharyngeal | Glottal - deriving ( Show, Eq, Generic, Ord ) + deriving ( Show, Eq, Generic, Ord, Data, Lift ) -- | Phonation (voicing) data Phonation = Voiced | Voiceless - deriving ( Show, Eq, Generic ) + deriving ( Show, Eq, Generic, Data, Lift ) -- | Sibilance for fricative consonants data Sibilance = Sibilant | NonSibilant - deriving ( Show, Eq, Generic ) + deriving ( Show, Eq, Generic, Data, Lift ) -- | Vowel type. Note that this type does not prevent the construction of --- non-sensical vowel values such as @Diphthong (Diphthong ...) (Diphthong ...)@ +-- 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 ) + deriving ( Show, Eq, Generic, Data, Lift ) pattern PureVowel :: Height -> Backness -> Roundedness -> Segment pattern PureVowel h b r = Vowel (Pure h b r) @@ -219,15 +234,15 @@ -- | Vowel height data Height = Close | NearClose | CloseMid | Mid | OpenMid | NearOpen | Open - deriving ( Show, Eq, Generic ) + deriving ( Show, Eq, Generic, Data, Lift ) -- | Vowel backness data Backness = Front | NearFront | Central | NearBack | Back - deriving ( Show, Eq, Generic, Ord ) + deriving ( Show, Eq, Generic, Ord, Data, Lift ) -- | Vowel roundedness data Roundedness = Rounded | Unrounded - deriving ( Show, Eq, Generic ) + deriving ( Show, Eq, Generic, Data, Lift ) -- | Lexical tone with Chao-style tone letters data LevelTone @@ -238,7 +253,7 @@ | ExtraLowTone | DownStep | UpStep - deriving ( Show, Eq, Generic, Ord ) + deriving ( Show, Eq, Generic, Ord, Data, Lift ) -- | Lexical tone represented as a contour data ToneContour @@ -252,7 +267,7 @@ | FallingRising | GlobalRise | GlobalFall - deriving ( Show, Eq, Generic, Ord ) + deriving ( Show, Eq, Generic, Ord, Data, Lift ) -- | Vowel length; also serves as a notation for consonant gemination in the IPA data Length @@ -263,7 +278,7 @@ -- ^ The default/unmarked length; using this constructor doesn't affect the -- default IPA representation of the segment | ExtraShort - deriving ( Show, Eq, Generic, Ord ) + 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' @@ -305,10 +320,10 @@ | NasalRelease | LateralRelease | NoAudibleRelease - deriving ( Show, Eq, Generic ) + deriving ( Show, Eq, Generic, Data, Lift ) data Stress = Primary | Secondary - deriving ( Show, Eq, Generic, Ord ) + deriving ( Show, Eq, Generic, Ord, Data, Lift ) data SuprasegmentalFeature = LevelLexicalTone LevelTone @@ -324,6 +339,12 @@ | 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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeApplications #-} -- | @@ -18,7 +19,7 @@ {- HLINT ignore "Redundant do" -} main :: IO () -main = ipa >> xsampa >> parser >> parserXSampa +main = ipa >> xsampa >> parser >> parserXSampa >> qq >> delim ipa :: IO () ipa = hspec $ do @@ -54,23 +55,23 @@ 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` "ɓɤ" + 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 ] - syllable = Syllable segments + syll = Syllable segments tone = LexicalToneContour Rising IPA chained = toIPA' $ WithSuprasegmentalFeature -- (Stress Primary) - (WithSuprasegmentalFeature tone syllable) + (WithSuprasegmentalFeature tone syll) chained `shouldBe` "do˩˥ˈ" describe "IPA normalization" $ do @@ -83,11 +84,11 @@ 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" + 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 @@ -123,12 +124,12 @@ let segments = [ PulmonicConsonant Voiced Alveolar Plosive , PureVowel CloseMid Back Rounded ] - syllable = Syllable segments + syll = Syllable segments tone = LexicalToneContour Rising XSampa chained = toXSampa' $ WithSuprasegmentalFeature -- (Stress Primary) - (WithSuprasegmentalFeature tone syllable) + (WithSuprasegmentalFeature tone syll) chained `shouldBe` "do_R\"" parser :: IO () @@ -183,27 +184,27 @@ describe "Syllable parser" $ do it "Parses syllables" $ do - let syllable = "ɣa" - parsed = parseIPA syllable - gamma = + let syll = "ɣa" + parsed = parseIPA syll + gamma = PulmonicConsonant Voiced Velar (Fricative NonSibilant) - a = PureVowel Open Front Unrounded + 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 + 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 syllable = "ˈő" - parsed = parseIPA syllable - tone = LevelLexicalToneDiacritic ExtraHighTone - o = PureVowel CloseMid Back Rounded + let syll = "ˈő" + parsed = parseIPA syll + tone = LevelLexicalToneDiacritic ExtraHighTone + o = PureVowel CloseMid Back Rounded parsed `shouldBe` Right -- (WithSuprasegmentalFeature -- @@ -211,22 +212,22 @@ (WithSuprasegmentalFeature (Stress Primary) (Syllable [ o ]))) it "Rejects invalid syllables" $ do - let syllable = "aL" - parsed = parseIPA @(Syllable []) syllable + let syll = "aL" + parsed = parseIPA @(Syllable []) syll parsed `shouldSatisfy` isLeft it "Rejects multiple adjacent syllables" $ do - let syllable = "aw.a" - parsed = parseIPA @(Syllable []) syllable + let syll = "aw.a" + parsed = parseIPA @(Syllable []) syll 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 ] + 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 @@ -272,27 +273,27 @@ describe "Syllable parser" $ do it "Parses syllables" $ do - let syllable = "Ga" - parsed = parseXSampa syllable - gamma = + let syll = "Ga" + parsed = parseXSampa syll + gamma = PulmonicConsonant Voiced Velar (Fricative NonSibilant) - a = PureVowel Open Front Unrounded + 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 + 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 syllable = "'o_T" - parsed = parseXSampa syllable - tone = LevelLexicalTone ExtraHighTone - o = PureVowel CloseMid Back Rounded + let syll = "'o_T" + parsed = parseXSampa syll + tone = LevelLexicalTone ExtraHighTone + o = PureVowel CloseMid Back Rounded parsed `shouldBe` Right -- (WithSuprasegmentalFeature -- @@ -300,14 +301,55 @@ (WithSuprasegmentalFeature (Stress Primary) (Syllable [ o ]))) it "Rejects multiple adjacent syllables" $ do - let syllable = "aw.a" - parsed = parseXSampa @(Syllable []) syllable + let syll = "aw.a" + parsed = parseXSampa @(Syllable []) syll 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 ] + 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/"