Text1.hs

{-# LANGUAGE DeriveLift #-}
{-# OPTIONS_GHC -Wall #-}

{- | Text that is not blank (it has at least one character that is not white
space), every character of which XML can hold: no control characters other
than tab, line feed and carriage return, and neither U+FFFE nor U+FFFF. The
documents are XML, so text with any other character would make them invalid.

Like every primitive type, @Text1@ is outside the classy optics recipe: its
constructor is not exported, so that every value keeps its invariant. It is
built with the prism '_Text1' or, for a literal, with 'text1Literal', which is
checked when the program is compiled.
-}
module ReOC.Primitive.Text1 (
  Text1,
  _Text1,
  text1Text,
  text1Literal,
  xmlCharacter,
) where

import Control.Lens (Prism', preview, prism')
import Data.Char (isSpace)
import Data.Text (Text)
import qualified Data.Text as Text
import Language.Haskell.TH.Syntax (Code (..), Lift, Q, liftTyped)

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

-- | Text that is not blank, and that XML can hold.
newtype Text1
  = Text1 Text
  deriving (Eq, Ord, Show, Lift)

{- | Text that is not blank, and that XML can hold.

>>> "Banksia Point" ^? _Text1
Just (Text1 "Banksia Point")

>>> " \t" ^? _Text1
Nothing

>>> "Bad\x01name" ^? _Text1
Nothing
-}
_Text1 :: Prism' Text Text1
_Text1 =
  prism'
    text1Text
    (\t -> if Text.any (not . isSpace) t && Text.all xmlCharacter t then Just (Text1 t) else Nothing)

{- | Whether XML 1.0 can hold a character.

>>> map xmlCharacter "a\t\x01\xFFFE"
[True,True,False,False]
-}
xmlCharacter :: Char -> Bool
xmlCharacter c =
  c == '\t' || c == '\n' || c == '\r' || (c >= '\x20' && c <= '\xD7FF') || (c >= '\xE000' && c <= '\xFFFD') || c >= '\x10000'

-- | The text of a @Text1@.
text1Text :: Text1 -> Text
text1Text (Text1 t) =
  t

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

> $$(text1Literal "Banksia Point Aerial Media")
-}
text1Literal :: String -> Code Q Text1
text1Literal s =
  maybe
    (Code (fail ("text1Literal: blank, or a character that XML cannot hold: " <> show s)))
    liftTyped
    (preview _Text1 (Text.pack s))