QQ.hs

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