FormText.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wall #-}

{- | Text that fits a text box of CASA Form 101-02.

A box of the form has a fixed font size (10 pt) and a fixed size, and the
form cuts off text that does not fit. @FormText font width lines@ is text
that is not blank, that the form's fonts can show, and that, wrapped at
@width@ points in @font@, takes at most @lines@ lines. A one-line box holds
no line breaks.

The constructor is not exported (see "ReOC.Primitive.Text1"). A @FormText@
is built with the prism '_FormText' or with 'formTextLiteral'.
-}
module ReOC.Primitive.FormText (
  FormFont (..),
  KnownFormFont (..),
  FormText,
  FormLine,
  FormLines,
  WideLine,
  _FormText,
  formTextText,
  formTextText1,
  formTextLiteral,
  textWidth,
  textLines,
) where

import Control.Lens (Prism', preview, prism')
import Data.Char (isControl)
import Data.Maybe (fromMaybe, isJust)
import Data.Proxy (Proxy (..))
import Data.Text (Text)
import qualified Data.Text as Text
import GHC.TypeNats (KnownNat, Nat, natVal)
import Language.Haskell.TH.Syntax (Code (..), Lift, Q, liftTyped)
import ReOC.Primitive.FormFont (narrowWidth, wideWidth)
import ReOC.Primitive.Text1 (Text1, text1Text, _Text1)

{- $setup
>>> :set -XDataKinds
>>> :set -XOverloadedStrings
>>> :set -XTypeApplications
>>> import Control.Lens ((^?))
-}

-- | The fonts of the text boxes of the form, by their widest characters.
data FormFont
  = -- | Helvetica Light Condensed or Roboto Condensed: most boxes.
    Narrow
  | -- | Helvetica Roman as well: questions 9 and 17.
    Wide
  deriving (Eq, Ord, Show)

-- | A font, known from its type.
class KnownFormFont (f :: FormFont) where
  formFontVal :: FormFont

instance KnownFormFont 'Narrow where
  formFontVal = Narrow

instance KnownFormFont 'Wide where
  formFontVal = Wide

-- | Text that fits a box of the form: @width@ points wide and @lines@ lines high.
newtype FormText (f :: FormFont) (width :: Nat) (lines :: Nat)
  = FormText Text1
  deriving (Eq, Ord, Show, Lift)

-- | Text that fits one line of a full-width box of the form, such as a name.
type FormLine = FormText 'Narrow 212 1

-- | Text that fits @n@ lines of a full-width box of the form.
type FormLines n = FormText 'Narrow 212 n

-- | Text that fits one line of a full-width box of the form in Helvetica Roman.
type WideLine = FormText 'Wide 212 1

-- The width of a character, in thousandths of a point at 10 pt.
characterWidth :: FormFont -> Char -> Maybe Int
characterWidth font c =
  if isControl c
    then Nothing
    else case font of
      Narrow -> narrowWidth c
      Wide -> wideWidth c

{- | The width of text in a font at 10 pt, in points, if the font can show it.

>>> textWidth Narrow "Banksia Point"
Just 54.16
-}
textWidth :: FormFont -> Text -> Maybe Double
textWidth font t =
  (\ws -> fromIntegral (sum ws) / 100) <$> traverse (characterWidth font) (Text.unpack t)

{- | The number of lines that text takes when the form wraps it at a width,
in points: each line break starts a line, lines break at spaces, and a word
wider than a line breaks between its characters. Characters that the font
cannot show have the width of the widest character.

>>> textLines Narrow 50 "one two three four five six"
3
-}
textLines :: FormFont -> Double -> Text -> Int
textLines font width =
  sum . map paragraph . Text.splitOn "\n"
 where
  w c =
    fromIntegral (fromMaybe 1015 (characterWidth font c)) / 100 :: Double
  space =
    w ' '
  paragraph p =
    case Text.splitOn " " p of
      [] -> 1
      first : rest ->
        let (n0, x0) = word (1, 0) first
         in fst (foldl next (n0, x0) rest)
  next (n, x) wd =
    let ww = sum (map w (Text.unpack wd))
     in if x + space + ww <= width
          then (n, x + space + ww)
          else word (n + 1, 0) wd
  -- places a word at the start of a line, breaking it between characters if it is too wide
  word :: (Int, Double) -> Text -> (Int, Double)
  word (n, _) wd =
    foldl
      (\(k, x) c -> if x + w c <= width || x == 0 then (k, x + w c) else (k + 1, w c))
      (n, 0)
      (Text.unpack wd)

{- | Text that fits a box of the form.

>>> "Mei-Ling Hartley" ^? _FormText @'Narrow @212 @1
Just (FormText (Text1 "Mei-Ling Hartley"))

>>> "first line\nsecond line" ^? _FormText @'Narrow @212 @1
Nothing

>>> "a long name that does not fit a narrow box" ^? _FormText @'Narrow @60 @1
Nothing

>>> "日本" ^? _FormText @'Narrow @212 @1
Nothing
-}
_FormText :: forall f width lines. (KnownFormFont f, KnownNat width, KnownNat lines) => Prism' Text (FormText f width lines)
_FormText =
  prism'
    formTextText
    ( \t ->
        let font = formFontVal @f
            maxLines = fromIntegral (natVal (Proxy :: Proxy lines))
            width = fromIntegral (natVal (Proxy :: Proxy width))
            shown c = isJust (characterWidth font c) || (c == '\n' && maxLines > 1)
         in if Text.all shown t && textLines font width t <= maxLines
              then FormText <$> preview _Text1 t
              else Nothing
    )

-- | The text of a @FormText@.
formTextText :: FormText f width lines -> Text
formTextText (FormText t) =
  text1Text t

-- | The text of a @FormText@, which is not blank.
formTextText1 :: FormText f width lines -> Text1
formTextText1 (FormText t) =
  t

{- | A @FormText@ literal, checked when the program is compiled:

> $$(formTextLiteral "Mei-Ling Hartley") :: FormLine
-}
formTextLiteral :: forall f width lines. (KnownFormFont f, KnownNat width, KnownNat lines) => String -> Code Q (FormText f width lines)
formTextLiteral s =
  maybe
    (Code (fail ("formTextLiteral: does not fit the box of the form, or has a character that the form cannot show: " <> show s)))
    liftTyped
    (preview (_FormText @f @width @lines) (Text.pack s))