module Text.Ogmarkup.Private.Typography where
import Data.String
import qualified Text.Ogmarkup.Private.Ast as Ast
data Space =
Normal
| Nbsp
| None
deriving (Eq,Ord)
data Typography a = Typography {
decide :: Ast.Mark -> (Space, Space)
, output :: Ast.Mark -> a
, openDialogue :: Bool -> Maybe Ast.Mark
, closeDialogue :: Bool -> Maybe Ast.Mark
}
instance Functor Typography where
f `fmap` (Typography d op o c) = Typography d (f . op) o c
beforeAtom :: Typography a
-> Ast.Atom a
-> Space
beforeAtom t (Ast.Punctuation m) = case decide t m of (r, _) -> r
beforeAtom t _ = Normal
afterAtom :: Typography a
-> Ast.Atom a
-> Space
afterAtom t (Ast.Punctuation m) = case decide t m of (_, r) -> r
afterAtom t _ = Normal
normalizeAtom :: Typography a
-> Ast.Atom a
-> a
normalizeAtom t (Ast.Punctuation m) = output t m
normalizeAtom t (Ast.Word w) = w
frenchTypo :: (Ast.Mark -> a) -> Typography a
frenchTypo op = Typography t op prevT nextT
where
t :: Ast.Mark -> (Space, Space)
t Ast.Semicolon = (Nbsp, Normal)
t Ast.Colon = (Nbsp, Normal)
t Ast.OpenQuote = (Normal, Nbsp)
t Ast.CloseQuote = (Nbsp, Normal)
t Ast.Irony = (Nbsp, Normal)
t Ast.Interrobang = (Nbsp, Normal)
t Ast.Question = (Nbsp, Normal)
t Ast.Exclamation = (Nbsp, Normal)
t Ast.LongDash = (Normal, Normal)
t Ast.Dash = (None, None)
t Ast.Hyphen = (None, None)
t Ast.Comma = (None, Normal)
t Ast.Point = (None, Normal)
t Ast.Apostrophe = (None, None)
t Ast.SuspensionPoints = (None, Normal)
prevT True = Just Ast.LongDash
prevT False = Just Ast.OpenQuote
nextT True = Nothing
nextT False = Just Ast.CloseQuote
unicodeFrenchTypo :: (IsString a) => Typography a
unicodeFrenchTypo = frenchTypo $ \case
Ast.Semicolon -> ";"
Ast.Colon -> ","
Ast.OpenQuote -> "«"
Ast.CloseQuote -> "»"
Ast.Irony -> "⸮"
Ast.Interrobang -> "‽"
Ast.Question -> "?"
Ast.Exclamation -> "!"
Ast.LongDash -> "—"
Ast.Dash -> "–"
Ast.Hyphen -> "-"
Ast.Comma -> ","
Ast.Point -> "."
Ast.Apostrophe -> "’"
Ast.SuspensionPoints -> "…"
htmlFrenchTypo :: (IsString a) => Typography a
htmlFrenchTypo = frenchTypo $ \case
Ast.Semicolon -> ";"
Ast.Colon -> ","
Ast.OpenQuote -> "«"
Ast.CloseQuote -> "»"
Ast.Irony -> "⸮"
Ast.Interrobang -> "‽"
Ast.Question -> "?"
Ast.Exclamation -> "!"
Ast.LongDash -> "—"
Ast.Dash -> "–"
Ast.Hyphen -> "-"
Ast.Comma -> ","
Ast.Point -> "."
Ast.Apostrophe -> "’"
Ast.SuspensionPoints -> "…"
englishTypo :: (Ast.Mark -> a) -> Typography a
englishTypo op = Typography t op (pure $ Just Ast.OpenQuote) (pure $ Just Ast.CloseQuote)
where
t :: Ast.Mark -> (Space, Space)
t Ast.Semicolon = (None, Normal)
t Ast.Colon = (None, Normal)
t Ast.OpenQuote = (Normal, None)
t Ast.CloseQuote = (None, Normal)
t Ast.Irony = (None, Normal)
t Ast.Interrobang = (None, Normal)
t Ast.Question = (None, Normal)
t Ast.Exclamation = (None, Normal)
t Ast.LongDash = (Normal, None)
t Ast.Dash = (None, None)
t Ast.Hyphen = (None, None)
t Ast.Comma = (None, Normal)
t Ast.Point = (None, Normal)
t Ast.Apostrophe = (None, None)
t Ast.SuspensionPoints = (None, Normal)
unicodeEnglishTypo :: (IsString a) => Typography a
unicodeEnglishTypo = englishTypo $ \case
Ast.Semicolon -> ";"
Ast.Colon -> ","
Ast.OpenQuote -> "“"
Ast.CloseQuote -> "”"
Ast.Irony -> "⸮"
Ast.Interrobang -> "‽"
Ast.Question -> "?"
Ast.Exclamation -> "!"
Ast.LongDash -> "—"
Ast.Dash -> "–"
Ast.Hyphen -> "-"
Ast.Comma -> ","
Ast.Point -> "."
Ast.Apostrophe -> "’"
Ast.SuspensionPoints -> "…"
htmlEnglishTypo :: (IsString a) => Typography a
htmlEnglishTypo = englishTypo $ \case
Ast.Semicolon -> ";"
Ast.Colon -> ","
Ast.OpenQuote -> "“"
Ast.CloseQuote -> "”"
Ast.Irony -> "⸮"
Ast.Interrobang -> "‽"
Ast.Question -> "?"
Ast.Exclamation -> "!"
Ast.LongDash -> "—"
Ast.Dash -> "–"
Ast.Hyphen -> "-"
Ast.Comma -> ","
Ast.Point -> "."
Ast.Apostrophe -> "’"
Ast.SuspensionPoints -> "…"