Font.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Graphics.Blank.Types.Font where

import           Control.Applicative
import           Control.Monad

import           Data.Char
import           Data.Default.Class
import           Data.Ix (Ix)
import           Data.Maybe
import           Data.String
import qualified Data.Text as TS
import           Data.Text (Text)
import qualified Data.Text.Lazy.Builder as B (singleton)

import           Graphics.Blank.JavaScript
import           Graphics.Blank.Parser
import           Graphics.Blank.Types
import           Graphics.Blank.Types.CSS

import           Prelude.Compat

import qualified Text.ParserCombinators.ReadP as ReadP
import           Text.ParserCombinators.ReadP hiding ((<++), choice, pfail)
import qualified Text.ParserCombinators.ReadPrec as ReadPrec
import           Text.ParserCombinators.ReadPrec (ReadPrec, (<++), lift, pfail)
import           Text.Read (Read(..), readListPrecDefault)

import           TextShow (TextShow(..), Builder, FromTextShow(..), showbSpace)

-------------------------------------------------------------------------------

-- | A data type that can represent a browser font.
class CanvasFont a where
    -- | Convert a value into a JavaScript string representing a font value.
    jsCanvasFont :: a -> Builder

instance CanvasFont Text where
    jsCanvasFont = jsText

instance CanvasFont Font where
    jsCanvasFont = jsFont

-------------------------------------------------------------------------------

-- | A CSS-style font data type.
data Font = FontProperties
  {   fontStyle   :: FontStyle
    , fontVariant :: FontVariant
    , fontWeight  :: FontWeight
    , fontSize    :: FontSize
    , lineHeight  :: LineHeight
    , fontFamily  :: [FontFamily]
  } -- ^ A font specified by its individual longhand properties.
  | CaptionFont      -- ^ The font used for captioned controls (e.g., buttons, drop-downs, etc.)
  | IconFont         -- ^ The font used to label icons.
  | MenuFont         -- ^ The font used in menus (e.g., dropdown menus and menu lists).
  | MessageBoxFont   -- ^ The font used in dialog boxes.
  | SmallCaptionFont -- ^ The font used for labeling small controls.
  | StatusBarFont    -- ^ The font used in window status bars.
  deriving (Eq, Ord)

-- |
-- Creates a new font from the 'FontFamily' list, using the 'Default' instances
-- for the other five longhand properties. If you only wish to change certain
-- properties and leave the others alone, this provides a convenient mechanism
-- for doing so:
--
-- @
-- ('defFont' ["Gill Sans Extrabold", 'sansSerif']) {
--     'fontStyle'  = 'italic'
--   , 'fontSize'   = 12 # 'px'
--   , 'lineHeight' = 14 # 'px'
-- }
-- @
defFont :: [FontFamily] -> Font
defFont = FontProperties def def def def def

-- | Shorthand for 'CaptionFont'.
caption :: Font
caption = CaptionFont

-- | Shorthand for 'IconFont'.
icon :: Font
icon = IconFont

-- | Shorthand for 'MenuFont'.
menu :: Font
menu = MenuFont

-- | Shorthand for 'MessageBoxFont'.
messageBox :: Font
messageBox = MessageBoxFont

-- | Shorthand for 'SmallCaptionFont'.
smallCaption :: Font
smallCaption = SmallCaptionFont

-- | Shorthand for 'StatusBarFont'.
statusBar :: Font
statusBar = StatusBarFont

instance IsString Font where
    fromString = read

instance JSArg Font where
    showbJS = jsFont

jsFont :: Font -> Builder
jsFont = jsLiteralBuilder . showb

instance Read Font where
    readPrec = do
        lift skipSpaces
        ReadPrec.choice
            [ CaptionFont      <$ lift (stringCI "caption")
            , IconFont         <$ lift (stringCI "icon")
            , MenuFont         <$ lift (stringCI "menu")
            , MessageBoxFont   <$ lift (stringCI "message-box")
            , SmallCaptionFont <$ lift (stringCI "small-caption")
            , StatusBarFont    <$ lift (stringCI "status-bar")
            , readFontProperties Nothing Nothing Nothing
            ]
    readListPrec = readListPrecDefault

-- | Like 'Either', but with three possibilities instead of two.
data OneOfThree a b c = One a | Two b | Three c

-- |
-- The formal syntax for the font CSS property
-- (https://developer.mozilla.org/en-US/docs/Web/CSS/font#Syntax) is surprisingly complex.
-- It requires that font-style, font-variant, and font-weight must be defined, if any,
-- before the font-size value. Furthermore, each of those three properties may only be defined at
-- most once, and the relative order of the three does not matter. This is a tall order for the
-- Text.ParserCombinators modules, so we use a heavily monadic utility function to detect
-- make it easier to catch bad input. The three Maybe arguments each represent whether its
-- respective property has not (Nothing) or has (Just) been read. If it has been read, then
-- readFontProperties will not attempt to parse it again.
--
-- readFontProperties will proceed to parse the remaining Font longhand properties once
-- either all three of the first properties have been parsed, or when it is unsuccessful at
-- parsing any of the first three properties.
readFontProperties :: Maybe FontStyle -> Maybe FontVariant -> Maybe FontWeight -> ReadPrec Font
readFontProperties style variant weight =
    -- If all three properties have been parsed, proceed to the remaining three properties.
    if isJust style && isJust variant && isJust weight
       then readFontProperties' style variant weight
       else do
               -- If the property has already been parsed, do not parse it again.
           let parseCheck :: Maybe a -> ReadPrec a -> ReadPrec a
               parseCheck mb parser = if isJust mb then pfail else parser

               readStyle, readVariant, readWeight :: ReadPrec (OneOfThree FontStyle FontVariant FontWeight)
               readStyle   = One   <$> parseCheck style readPrec
               readVariant = Two   <$> parseCheck variant readPrec
               readWeight  = Three <$> parseCheck weight readPrec

           -- First attempt to parse font-style, then font-variant, then font-weight (unless one
           -- of them has already been parsed, in which case skip to the next property parser.
           prop <- maybeReadPrec $ readStyle <++ readVariant <++ readWeight
           -- Check to see which property, if any, was parsed.
           case prop of
               Just (One style') -> do
                   when (isJust style) pfail -- Safeguard to ensure a property is not parsed twice.
                   readFontProperties (Just style') variant weight
               Just (Two variant') -> do
                   when (isJust variant) pfail
                   readFontProperties style (Just variant') weight
               Just (Three weight') -> do
                   when (isJust weight) pfail
                   readFontProperties style variant (Just weight')
               -- If no properties were parsed, proceed to the remaining three properties.
               Nothing -> readFontProperties' style variant weight

-- |
-- Parses the remaining three Font longhand properties (font-size, line-height, and
-- font-family). Make sure to also parse the forward slash, if any, that separates
-- the font-size and line-height properties.
readFontProperties' :: Maybe FontStyle -> Maybe FontVariant -> Maybe FontWeight -> ReadPrec Font
readFontProperties' mbStyle mbVariant mbWeight =
  FontProperties (fromMaybe def mbStyle) (fromMaybe def mbVariant) (fromMaybe def mbWeight)
  <$> readPrec
  <*> lift (option def $ skipSpaces *> char '/' *> unlift readPrec)
  <*> (lift (munch1 isSpace) *> readPrec)

instance Show Font where
    showsPrec p = showsPrec p . FromTextShow

instance TextShow Font where
    showb (FontProperties style variant weight size height' family)
        = showb style
       <> showbSpace
       <> showb variant
       <> showbSpace
       <> showb weight
       <> showbSpace
       <> showb size
       <> B.singleton '/'
       <> showb height'
       <> showbSpace
       <> showb family
    showb CaptionFont      = "caption"
    showb IconFont         = "icon"
    showb MenuFont         = "menu"
    showb MessageBoxFont   = "message-box"
    showb SmallCaptionFont = "small-caption"
    showb StatusBarFont    = "status-bar"

-------------------------------------------------------------------------------

-- | Specifies if a 'Font' is italic or oblique.
data FontStyle = NormalStyle  -- ^ Selects a font classified as normal (default).
               | ItalicStyle  -- ^ Selects a font that is labeled italic, or if one is not available,
                              --   one labeled oblique.
               | ObliqueStyle -- ^ Selects a font that is labeled oblique.
  deriving (Bounded, Enum, Eq, Ix, Ord)

-- | Shorthand for 'ItalicStyle'.
italic :: FontStyle
italic = ItalicStyle

-- | Shorthand for 'ObliqueStyle'.
oblique :: FontStyle
oblique = ObliqueStyle

instance Default FontStyle where
    def = NormalStyle

instance IsString FontStyle where
    fromString = read

instance NormalProperty FontStyle

instance Read FontStyle where
    readPrec = lift $ do
        skipSpaces
        ReadP.choice
            [ NormalStyle  <$ stringCI "normal"
            , ItalicStyle  <$ stringCI "italic"
            , ObliqueStyle <$ stringCI "oblique"
            ]
    readListPrec = readListPrecDefault

instance Show FontStyle where
    showsPrec p = showsPrec p . FromTextShow

instance TextShow FontStyle where
    showb NormalStyle  = "normal"
    showb ItalicStyle  = "italic"
    showb ObliqueStyle = "oblique"

-------------------------------------------------------------------------------

-- | Specifies the face of a 'Font'.
data FontVariant = NormalVariant    -- ^ A normal font face (default).
                 | SmallCapsVariant -- ^ A font face with small capital letters for lowercase characters.
  deriving (Bounded, Enum, Eq, Ix, Ord)

-- | Shorthand for 'SmallCapsVariant'.
smallCaps :: FontVariant
smallCaps = SmallCapsVariant

instance Default FontVariant where
    def = NormalVariant

instance IsString FontVariant where
    fromString = read

instance NormalProperty FontVariant

instance Read FontVariant where
    readPrec = lift $ do
      skipSpaces
      (NormalVariant <$ stringCI "normal") <|> (SmallCapsVariant <$ stringCI "small-caps")
    readListPrec = readListPrecDefault

instance Show FontVariant where
    showsPrec p = showsPrec p . FromTextShow

instance TextShow FontVariant where
    showb NormalVariant    = "normal"
    showb SmallCapsVariant = "small-caps"

-------------------------------------------------------------------------------

-- |
-- Specifies the boldness of a 'Font'. Note that 'FontWeight' is an instance of
-- 'Num' so that the nine numeric weights can be used directly. For example:
--
-- @
-- ('defFont' ['sansSerif']) { 'fontWeight' = 900 }
-- @
--
-- Attempting to use a numeric weight other than the nine given will result in
-- a runtime error.
data FontWeight = NormalWeight -- ^ Default.
                | BoldWeight
                | BolderWeight
                | LighterWeight
                | Weight100
                | Weight200
                | Weight300
                | Weight400
                | Weight500
                | Weight600
                | Weight700
                | Weight800
                | Weight900
  deriving (Bounded, Enum, Eq, Ix, Ord)

-- | Shorthand for 'BoldWeight'.
bold :: FontWeight
bold = BoldWeight

-- | Shorthand for 'BolderWeight'.
bolder :: FontWeight
bolder = BolderWeight

-- | Shorthand for 'LighterWeight'.
lighter :: FontWeight
lighter = LighterWeight

fontWeightError :: a
fontWeightError = error "invalid font-weight operation"

instance Default FontWeight where
    def = NormalWeight

instance IsString FontWeight where
    fromString = read

instance NormalProperty FontWeight

instance Num FontWeight where
    (+)    = fontWeightError
    (-)    = fontWeightError
    (*)    = fontWeightError
    abs    = fontWeightError
    signum = fontWeightError
    fromInteger 100 = Weight100
    fromInteger 200 = Weight200
    fromInteger 300 = Weight300
    fromInteger 400 = Weight400
    fromInteger 500 = Weight500
    fromInteger 600 = Weight600
    fromInteger 700 = Weight700
    fromInteger 800 = Weight800
    fromInteger 900 = Weight900
    fromInteger _   = fontWeightError

instance Read FontWeight where
    readPrec = lift $ do
        skipSpaces
        ReadP.choice
            [ NormalWeight  <$ stringCI "normal"
            , BoldWeight    <$ stringCI "bold"
            , BolderWeight  <$ stringCI "bolder"
            , LighterWeight <$ stringCI "lighter"
            , Weight100     <$ string   "100"
            , Weight200     <$ string   "200"
            , Weight300     <$ string   "300"
            , Weight400     <$ string   "400"
            , Weight500     <$ string   "500"
            , Weight600     <$ string   "600"
            , Weight700     <$ string   "700"
            , Weight800     <$ string   "800"
            , Weight900     <$ string   "900"
            ]
    readListPrec = readListPrecDefault

instance Show FontWeight where
    showsPrec p = showsPrec p . FromTextShow

instance TextShow FontWeight where
    showb NormalWeight  = "normal"
    showb BoldWeight    = "bold"
    showb BolderWeight  = "bolder"
    showb LighterWeight = "lighter"
    showb Weight100     = "100"
    showb Weight200     = "200"
    showb Weight300     = "300"
    showb Weight400     = "400"
    showb Weight500     = "500"
    showb Weight600     = "600"
    showb Weight700     = "700"
    showb Weight800     = "800"
    showb Weight900     = "900"

-------------------------------------------------------------------------------

-- | The desired height of 'Font' glyphs.
--
-- ==== __Examples__
--
-- @
-- ('defFont' ['sansSerif']) { 'fontSize' = 'xxSmall' }
-- ('defFont' ['sansSerif']) { 'fontSize' = 30 # 'pt' }
-- ('defFont' ['sansSerif']) { 'fontSize' = 50 # 'percent' }
-- @
data FontSize = XXSmallSize
              | XSmallSize
              | SmallSize
              | MediumSize -- ^ Default.
              | LargeSize
              | XLargeSize
              | XXLargeSize
              | LargerSize
              | SmallerSize
              | FontSizeLength Length
              | FontSizePercentage Percentage
  deriving (Eq, Ord)

-- | Shorthand for 'XXSmallSize'.
xxSmall :: FontSize
xxSmall = XXSmallSize

-- | Shorthand for 'XSmallSize'.
xSmall :: FontSize
xSmall = XSmallSize

-- | Shorthand for 'SmallSize'.
small :: FontSize
small = SmallSize

-- | Shorthand for 'MediumSize'.
medium :: FontSize
medium = MediumSize

-- | Shorthand for 'LargeSize'.
large :: FontSize
large = LargeSize

-- | Shorthand for 'XLargeSize'.
xLarge :: FontSize
xLarge = XLargeSize

-- | Shorthand for 'XXLargeSize'.
xxLarge :: FontSize
xxLarge = XXLargeSize

-- | Shorthand for 'LargerSize'.
larger :: FontSize
larger = LargerSize

-- | Shorthand for 'SmallerSize'.
smaller :: FontSize
smaller = SmallerSize

instance Default FontSize where
    def = MediumSize

instance IsString FontSize where
    fromString = read

instance LengthProperty FontSize where
    fromLength = FontSizeLength

instance PercentageProperty FontSize where
    percent = FontSizePercentage

instance Read FontSize where
    readPrec = do
        lift $ skipSpaces
        ReadPrec.choice
            [ XXSmallSize        <$  lift (stringCI "xx-small")
            , XSmallSize         <$  lift (stringCI "x-small")
            , SmallSize          <$  lift (stringCI "small")
            , MediumSize         <$  lift (stringCI "medium")
            , LargeSize          <$  lift (stringCI "large")
            , XLargeSize         <$  lift (stringCI "x-large")
            , XXLargeSize        <$  lift (stringCI "xx-large")
            , LargerSize         <$  lift (stringCI "larger")
            , SmallerSize        <$  lift (stringCI "smaller")
            , FontSizeLength     <$> readPrec
            , FontSizePercentage <$> readPrec <* lift (char '%')
            ]
    readListPrec = readListPrecDefault

instance Show FontSize where
    showsPrec p = showsPrec p . FromTextShow

instance TextShow FontSize where
    showb XXSmallSize            = "xx-small"
    showb XSmallSize             = "x-small"
    showb SmallSize              = "small"
    showb MediumSize             = "medium"
    showb LargeSize              = "large"
    showb XLargeSize             = "x-large"
    showb XXLargeSize            = "xx-large"
    showb LargerSize             = "larger"
    showb SmallerSize            = "smaller"
    showb (FontSizeLength l)     = showb l
    showb (FontSizePercentage p) = jsDouble p <> B.singleton '%'

-------------------------------------------------------------------------------

-- | The height of the line boxes in a 'Font'.
--
-- ==== __Examples__
--
-- @
-- ('defFont' ['sansSerif']) { 'lineHeight' = 'normal' }
-- ('defFont' ['sansSerif']) { 'lineHeight' = 50 }
-- ('defFont' ['sansSerif']) { 'lineHeight' = 30 # 'em' }
-- ('defFont' ['sansSerif']) { 'lineHeight' = 70 # 'percent' }
-- @
data LineHeight = NormalLineHeight -- ^ Default.
                | LineHeightNumber Double
                | LineHeightLength Length
                | LineHeightPercentage Percentage
  deriving (Eq, Ord)

lineHeightError :: a
lineHeightError = error "no arithmetic for line-height"

instance Default LineHeight where
    def = NormalLineHeight

instance Fractional LineHeight where
    (/)   = lineHeightError
    recip = lineHeightError
    fromRational = LineHeightNumber . fromRational

instance IsString LineHeight where
    fromString = read

instance LengthProperty LineHeight where
    fromLength = LineHeightLength

instance NormalProperty LineHeight

instance Num LineHeight where
    (+)    = lineHeightError
    (-)    = lineHeightError
    (*)    = lineHeightError
    abs    = lineHeightError
    signum = lineHeightError
    fromInteger = LineHeightNumber . fromInteger

instance PercentageProperty LineHeight where
    percent = LineHeightPercentage

instance Read LineHeight where
    readPrec = do
        lift skipSpaces
        ReadPrec.choice
            [ NormalLineHeight     <$  lift (stringCI "normal")
            , LineHeightNumber     <$> readPrec
            , LineHeightLength     <$> readPrec
            , LineHeightPercentage <$> readPrec <* lift (char '%')
            ]
    readListPrec = readListPrecDefault

instance Show LineHeight where
    showsPrec p = showsPrec p . FromTextShow

instance TextShow LineHeight where
    showb NormalLineHeight         = "normal"
    showb (LineHeightNumber n)     = jsDouble n
    showb (LineHeightLength l)     = showb l
    showb (LineHeightPercentage p) = jsDouble p <> B.singleton '%'

-------------------------------------------------------------------------------

-- |
-- The name of a 'Font' family. Note that both 'FontFamily' and @['FontFamily']@
-- are instances of 'IsString', so it is possible to produce 'FontFamily' values
-- in several different ways. For example, these are all of type 'FontFamily':
--
-- @
-- 'FontFamilyName' "Gill Sans Extrabold"
-- "Gill Sans Extrabold" :: 'FontFamily'
-- 'serif'
-- "serif" :: 'FontFamily'
-- @
--
-- These are all of type @['FontFamily']@:
--
-- @
-- ['FontFamilyName' \"Helvetica\", 'serif']
-- [\"Helvetica\", "serif"] :: ['FontFamily']
-- "Helvetica, serif" :: ['FontFamily']
-- @
data FontFamily = FontFamilyName Text -- ^ The name of a custom font family.
                | SerifFamily         -- ^ A generic font family where glyphs have
                                      --   serifed endings.
                | SansSerifFamily     -- ^ A generic font family where glyphs do not
                                      --   have serifed endings.
                | MonospaceFamily     -- ^ A generic font family where all glyphs have
                                      --   the same fixed width.
                | CursiveFamily       -- ^ A generic font family with cursive glyphs.
                | FantasyFamily       -- ^ A generic font family where glyphs have
                                      --   decorative, playful representations.
  deriving (Eq, Ord)

-- | Shorthand for 'SerifFamily'.
serif :: FontFamily
serif = SerifFamily

-- | Shorthand for 'SansSerifFamily'.
sansSerif :: FontFamily
sansSerif = SansSerifFamily

-- | Shorthand for 'MonospaceFamily'.
monospace :: FontFamily
monospace = MonospaceFamily

-- | Shorthand for 'CursiveFamily'.
cursive :: FontFamily
cursive = CursiveFamily

-- | Shorthand for 'FantasyFamily'.
fantasy :: FontFamily
fantasy = FantasyFamily

instance IsString FontFamily where
    fromString = read

-- |
-- There are two separate 'IsString' instances for 'FontFamily' so that single font
-- families and lists of font families alike can be converted from string literals.
instance IsString [FontFamily] where
    fromString = read

instance Read FontFamily where
    readPrec = lift $ do
        skipSpaces
        ReadP.choice
          [ SerifFamily     <$ stringCI "serif"
          , SansSerifFamily <$ stringCI "sans-serif"
          , MonospaceFamily <$ stringCI "monospace"
          , CursiveFamily   <$ stringCI "cursive"
          , FantasyFamily   <$ stringCI "fantasy"
          , let quoted quote = between (char quote) (char quote)
             in quoted '"' (readFontFamily $ Just '"')
                  <|> quoted '\'' (readFontFamily $ Just '\'')
                  <|> readFontFamily Nothing
          ]

    -- readListPrec is overloaded so that it will read in a comma-separated list of
    -- family names not delimited by square brackets, as per the CSS syntax.
    readListPrec = lift . sepBy1 (unlift readPrec) $ skipSpaces *> char ','

readFontFamily :: Maybe Char -> ReadP FontFamily
readFontFamily mQuote = do
    name <- case mQuote of
        Just quote -> munch (/= quote)
        Nothing    -> unwords <$> sepBy1 cssIdent (munch1 isSpace)
    return . FontFamilyName $ TS.pack name

instance Show FontFamily where
    showsPrec p = showsPrec p . FromTextShow
    showList    = showsPrec 0 . FromTextShow

instance TextShow FontFamily where
    showb (FontFamilyName name) = showb name
    showb SerifFamily           = "serif"
    showb SansSerifFamily       = "sans-serif"
    showb MonospaceFamily       = "monospace"
    showb CursiveFamily         = "cursive"
    showb FantasyFamily         = "fantasy"

    -- Omit the square brackets when showing a list of font families so that
    -- it matches the CSS syntax.
    showbList = jsList showb

-------------------------------------------------------------------------------

-- | A convenient way to use the 'Default' normal value for several 'Font'
-- longhand properties.
class Default a => NormalProperty a where
    -- | The default value for a CSS property. For example, it can be used
    -- like this:
    --
    -- @
    -- ('defFont' ['sansSerif']) { 'lineHeight' = 'normal' }
    -- @
    normal :: a
    normal = def