Markup.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wall #-}

{- | The marked-up text of the RePL training manual template: markdown with
holes @{{name}}@ and markers @<!-- ... -->@ for text that is repeated for
each course or included on a condition.
-}
module ReOC.Render.TrainingManual.Markup (
  parseMarkup,
  checkMarkup,
  conditionValues,
) where

import Data.Text (Text)
import qualified Data.Text as Text
import ReOC.Render.TrainingManual.Chunk (Chunk (..))

{- $setup
>>> :set -XOverloadedStrings
-}

-- A token of the marked-up text.
data Token
  = TText Text
  | THole Text
  | TMarker Text

tokens :: Text -> [Token]
tokens t
  | Text.null t = []
  | otherwise =
      let (before, rest) = breakFirst t
       in [TText before | not (Text.null before)] <> marker rest
 where
  breakFirst x =
    let (a, _) = Text.breakOn "{{" x
        (b, _) = Text.breakOn "<!--" x
     in if Text.length a <= Text.length b then Text.splitAt (Text.length a) x else Text.splitAt (Text.length b) x
  marker rest
    | "{{" `Text.isPrefixOf` rest =
        let (name, after) = Text.breakOn "}}" (Text.drop 2 rest)
         in THole name : tokens (Text.drop 2 after)
    | "<!--" `Text.isPrefixOf` rest =
        let (body, after) = Text.breakOn "-->" (Text.drop 4 rest)
         in TMarker (Text.strip body) : tokens (Text.drop 3 after)
    | otherwise = []

{- | Parses marked-up text.

>>> parseMarkup "a {{organisation-name}} <!-- if simulator -->b<!-- end -->"
Right [Literal "a ",Hole "organisation-name",Literal " ",SimulatorCondition [Literal "b"]]

>>> parseMarkup "<!-- if simulator -->b"
Left "a marker is not closed"
-}
parseMarkup :: Text -> Either String [Chunk]
parseMarkup t =
  case go (tokens t) of
    Right (cs, []) -> Right cs
    Right (_, _ : _) -> Left "an end marker has no start"
    Left e -> Left e
 where
  -- parses chunks up to an end marker, which is returned with the tokens after it
  go :: [Token] -> Either String ([Chunk], [Token])
  go = \case
    [] -> Right ([], [])
    TText x : rest -> first (Literal x :) <$> go rest
    THole n : rest -> first (Hole n :) <$> go rest
    ts@(TMarker m : rest)
      | m == "end" || m == "per-course end" -> Right ([], ts)
      | m == "per-course begin" -> block "per-course end" PerCourse rest
      | m == "if simulator" -> block "end" SimulatorCondition rest
      | Just c <- Text.stripPrefix "if offered " m -> condition OfferedCondition c rest
      | Just c <- Text.stripPrefix "if " m -> condition CourseCondition c rest
      | otherwise -> Left ("unknown marker: " <> Text.unpack m)
  block close make rest = do
    (inner, after) <- go rest
    case after of
      TMarker m : more | m == close -> first (make inner :) <$> go more
      _ -> Left "a marker is not closed"
  condition make c rest =
    case Text.splitOn "=" c of
      [k, v] -> block "end" (make k v) rest
      _ -> Left ("not a condition: " <> Text.unpack c)
  first f (a, b) = (f a, b)

{- | The values of a key of a condition: @category@, @weight@, @complexity@ or
@course-type@.
-}
conditionValues :: Text -> Maybe [Text]
conditionValues = \case
  "category" -> Just ["multirotor", "helicopter", "powered-lift", "aeroplane"]
  "weight" -> Just ["up-to-7kg", "up-to-25kg"]
  "complexity" -> Just ["automated-and-manual", "automated-only"]
  "course-type" -> Just ["initial", "upgrade-same-category", "upgrade-different-category"]
  _ -> Nothing

{- | The errors of marked-up text, given the names of the holes of the
manual and of each course: unknown holes, unknown conditions, course holes
and conditions outside a @per-course@ block, and nested @per-course@ blocks.

>>> checkMarkup ["organisation-name"] ["course-title"] [Hole "course-title"]
["the hole {{course-title}} is outside a per-course block"]
-}
checkMarkup :: [Text] -> [Text] -> [Chunk] -> [String]
checkMarkup global course =
  concatMap (check False)
 where
  check inCourse = \case
    Literal _ -> []
    Hole n
      | n `elem` global -> []
      | n `elem` course -> ["the hole {{" <> Text.unpack n <> "}} is outside a per-course block" | not inCourse]
      | otherwise -> ["unknown hole {{" <> Text.unpack n <> "}}"]
    CourseCondition k v cs ->
      ["the condition " <> Text.unpack k <> "=" <> Text.unpack v <> " is outside a per-course block" | not inCourse]
        <> value k v
        <> concatMap (check inCourse) cs
    OfferedCondition k v cs ->
      value k v <> concatMap (check inCourse) cs
    SimulatorCondition cs ->
      concatMap (check inCourse) cs
    PerCourse cs ->
      ["a per-course block is inside another" | inCourse] <> concatMap (check True) cs
  value k v =
    case conditionValues k of
      Nothing -> ["unknown condition key: " <> Text.unpack k]
      Just vs -> ["unknown value of " <> Text.unpack k <> ": " <> Text.unpack v | v `notElem` vs]