casa-reoc-0.1.0.0: test/RenderTests.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wall #-}
-- | Tests of the documents that a ReOC gives.
module RenderTests (
renderTests,
) where
import Control.Lens (cloneLens, has, set, toListOf, view, (&), (.~), (?~))
import qualified Data.ByteString as ByteString
import Data.Foldable (toList)
import Data.List (nub)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Map as Map
import Data.Maybe (isJust)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified Data.Text.Lazy as Lazy
import Data.Time.Calendar (fromGregorian)
import DataGens (genReOC, genRiskAssessment)
import FormFields (formFields, textBoxes)
import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Laws (prismLaws)
import Numeric.Natural (Natural)
import PrimitiveGens
import ReOC
import ReOC.Examples (banksiaPoint, draft, examples)
import ReOC.Render.Markdown (escapeMarkdown, inline)
import ReOC.Render.OperationsManual.Diagram (organisationalDiagramSvg)
import System.Directory (doesDirectoryExist, doesFileExist, getTemporaryDirectory, removePathForcibly)
import System.FilePath ((</>))
import qualified Text.XML as XML
renderTests :: [(PropertyName, Property)]
renderTests =
concat
[ prismLaws "_Text1" _Text1 genText genText1
, prismLaws "_FormText" (_FormText @'Narrow @212 @1) genText genFormText
, prismLaws "_FormText (wide, 5 lines)" (_FormText @'Wide @185 @5) genText genFormText
, prismLaws "_ABN" _ABN (Text.pack <$> genDigitsText) genABN
, prismLaws "_ARN" _ARN (Text.pack <$> genDigitsText) genARN
, prismLaws "_EmailAddress" _EmailAddress genText genEmailAddress
, prismLaws "_PhoneNumber" _PhoneNumber (Text.pack <$> genDigitsText) genPhoneNumber
, prismLaws "_Postcode" _Postcode (Text.pack <$> genDigitsText) genPostcode
, prismLaws "_Positive" _Positive genNatural genPositive
, prismLaws "_Percentage" _Percentage genNatural genPercentage
, prismLaws "_GrossWeight" _GrossWeight (Gen.integral (Range.linear 0 30000)) genGrossWeight
, prismLaws "_ReviewMonths" _ReviewMonths genNatural genReviewMonths
, prismLaws "_PassMark" _PassMark genNatural genPassMark
, prismLaws "_Some" (_Some @3) (Gen.nonEmpty (Range.linear 1 5) Gen.bool) (genSome Gen.bool)
, prismLaws "_AtMost" (_AtMost @3) (Gen.list (Range.linear 0 5) Gen.bool) (genAtMost Gen.bool)
,
[ ("every field of the application form is on CASA Form 101-02", prop_fieldsOnForm)
, ("no field of the application form is filled twice", prop_fieldsOnce)
, ("every text of the application form fits its box", prop_fieldsFit)
, ("the documents are well-formed XML", prop_wellFormed)
, ("the organisational diagram is well-formed SVG", prop_diagram)
, ("the manuals have no holes or markers left", prop_noHoles)
, ("the RePL training manual is written only with RePL training", prop_trainingManual)
, ("the operations manual has the legal name of the company", prop_legalName)
, ("the risk register has a row for each risk", prop_riskRows)
, ("the amendment record increases its version and keeps its dates in order", prop_amendmentRecord)
, ("text in markdown is shown as it is", prop_markdownEscape)
, ("the risk rating matrix", prop_riskMatrix)
, ("a risk is rated with its likelihood and consequence", prop_riskRating)
, ("the documents keep the placeholders of the document build", prop_placeholders)
, ("filling the placeholders leaves none", prop_fillPlaceholders)
, ("each example gives well-formed documents whose form text fits", prop_examples)
, ("the documents in examples are the ones the examples give", prop_examplesWritten)
, ("every example is valid", prop_examplesValid)
, ("filling in the unfilled form of a valid ReOC gives it back", prop_fillUnfill)
, ("filling in an empty form gives an error at each required field", prop_fillEmpty)
, ("an invalid and an unfilled field each give one error at its path", prop_fillErrors)
, ("a list field with too many elements is an error at the list", prop_fillTooMany)
, ("the draft example gives its errors", prop_draft)
, ("the blank form is written beside the application form of each example", prop_blankForm)
, ("writing the documents writes the blank form and the written signature", prop_writtenFiles)
]
]
where
genDigitsText =
Gen.choice [show <$> Gen.integral (Range.linear (0 :: Integer) 99999999999), Gen.string (Range.linear 0 12) Gen.unicode]
-- Generates a ReOC, with RePL training in about half of them.
genReOC' :: Gen ReOC
genReOC' =
genReOC
prop_fieldsOnForm :: Property
prop_fieldsOnForm =
property $ do
r <- forAll genReOC'
let fs = concatMap snd (applicationFormFields r)
mapM_' fs $ \(n, v) ->
case Map.lookup n formFields of
Nothing -> annotate ("not a field of the form: " <> show n) >> failure
Just Nothing -> success
Just (Just states) -> do
annotate (show (n, v))
assert (v `elem` states)
where
mapM_' xs f = mapM_ f xs
prop_fieldsOnce :: Property
prop_fieldsOnce =
property $ do
r <- forAll genReOC'
let names = map fst (concatMap snd (applicationFormFields r))
names === nub names
-- Every text the form is filled with can be shown by its font, and takes no more lines than its box shows.
prop_fieldsFit :: Property
prop_fieldsFit =
property $ do
r <- forAll genReOC'
let fs = concatMap snd (applicationFormFields r)
mapM_
( \(n, v) ->
case Map.lookup n textBoxes of
Just (font, width, lines')
| not ("${" `Text.isInfixOf` v) -> do
annotate (show (n, v))
assert (all (isJust . textWidth font) (filter (/= "") (Text.splitOn "\n" v)))
assert (textLines font width v <= lines')
_ -> success
)
fs
prop_wellFormed :: Property
prop_wellFormed =
withTests 40 . property $ do
r <- forAll genReOC'
let docs = [renderApplicationForm r, renderOperationsManual r] <> toList (renderTrainingManual r)
mapM_
( \d -> do
assert (Text.all xmlCharacter d)
case XML.parseText XML.def (Lazy.fromStrict d) of
Left e -> annotate (show e) >> failure
Right _ -> success
)
docs
prop_diagram :: Property
prop_diagram =
property $ do
r <- forAll genReOC'
case XML.parseText XML.def (Lazy.fromStrict (organisationalDiagramSvg r)) of
Left e -> annotate (show e) >> failure
Right _ -> success
-- The holes of a template: each {{name}}. Generated text can hold "{{", so the test looks for the holes themselves.
templateHoles :: Text.Text -> [Text.Text]
templateHoles t =
nub [h | s <- drop 1 (Text.splitOn "{{" t), let (n, rest) = Text.breakOn "}}" s, not (Text.null rest), let h = "{{" <> n <> "}}"]
prop_noHoles :: Property
prop_noHoles =
withTests 40 . property $ do
holes <- evalIO (templateHoles . Text.concat <$> mapM Text.readFile ["template/rpas-operations-manual.fodt", "template/repl-training-manual.fodt", "template/repl-training-manual.md"])
assert (length holes > 50)
r <- forAll genReOC'
let docs = renderOperationsManual r : toList (renderTrainingManual r)
mapM_ (\d -> mapM_ (\h -> annotate (show h) >> assert (not (h `Text.isInfixOf` d))) holes) docs
-- Markers are comments, and text from the data has its < escaped.
mapM_ (\t -> assert (not ("<!--" `Text.isInfixOf` t))) (renderTrainingManual r)
prop_trainingManual :: Property
prop_trainingManual =
withTests 40 . property $ do
r <- forAll genReOC'
isJust (renderTrainingManual r) === isJust (get maybeTrainingMaterial r)
prop_legalName :: Property
prop_legalName =
withTests 40 . property $ do
r <- forAll genReOC'
assert (escapeXml (legalName (get (operator . company) r)) `Text.isInfixOf` renderOperationsManual r)
prop_riskRows :: Property
prop_riskRows =
withTests 40 . property $ do
r <- forAll genReOC'
Text.count "<table:table-row table:style-name=\"Table17.2\">" (renderOperationsManual r)
=== length (toList (get (operationsManual . riskRegister) r))
prop_amendmentRecord :: Property
prop_amendmentRecord =
property $ do
r <- forAll genReOC'
let entries = toList (amendmentRecord (get operationsManual r))
versionOf :: AmendmentEntry -> (Natural, Natural)
versionOf (v, _, _, _, _) = (get majorVersion v, get minorVersion v)
dateOf (_, d, _, _, _) = d
pairs = zip entries (drop 1 entries)
assert (all (\(a, b) -> versionOf a < versionOf b) pairs)
assert (all (\(a, b) -> dateOf a <= dateOf b) pairs)
prop_markdownEscape :: Property
prop_markdownEscape =
property $ do
t <- forAll (text1Text <$> genText1)
inline (escapeMarkdown t) === escapeXml (Text.map (\c -> if c == '\n' || c == '\r' then ' ' else c) t)
prop_riskMatrix :: Property
prop_riskMatrix =
withTests 1 . property $ do
riskLevelOf (RiskAssessment' Frequent Catastrophic) === High
riskLevelOf (RiskAssessment' Improbable Catastrophic) === Medium
riskLevelOf (RiskAssessment' ExtremelyImprobable Catastrophic) === Medium
riskLevelOf (RiskAssessment' ExtremelyImprobable Hazardous) === Low
riskLevelOf (RiskAssessment' Remote Negligible) === Low
riskLevelOf (RiskAssessment' Occasional Moderate) === Medium
prop_riskRating :: Property
prop_riskRating =
property $ do
a <- forAll genRiskAssessment
riskRating a === likelihoodValue (get riskLikelihood a) <> consequenceValue (get riskConsequence a)
prop_placeholders :: Property
prop_placeholders =
withTests 1 . property $ do
let manual = renderOperationsManual validBanksiaPoint
form = renderApplicationForm validBanksiaPoint
assert ("${CI_COMMIT_SHA}" `Text.isInfixOf` manual)
assert ("${CI_PAGES_URL}" `Text.isInfixOf` manual)
assert ("${DECLARATION_DAY}" `Text.isInfixOf` form)
assert ("Version 1.0 - September 2026" `Text.isInfixOf` manual)
prop_fillPlaceholders :: Property
prop_fillPlaceholders =
withTests 1 . property $ do
let b = BuildInfo "0123abc" "https://example.net/reoc" (fromGregorian 2026 10 23)
mapM_
( \(_, r) ->
mapM_ (\d -> assert (not ("${" `Text.isInfixOf` fillPlaceholders b d))) (exampleDocuments r)
)
completeExamples
-- The documents of an example.
exampleDocuments :: ReOC -> [Text.Text]
exampleDocuments r =
[renderApplicationForm r, renderOperationsManual r] <> toList (renderTrainingManual r)
prop_examples :: Property
prop_examples =
withTests 1 . property $
mapM_
( \(_, r) -> do
let docs = exampleDocuments r
isJust (renderTrainingManual r) === isJust (get maybeTrainingMaterial r)
mapM_
( \d -> case XML.parseText XML.def (Lazy.fromStrict d) of
Left e -> annotate (show e) >> failure
Right _ -> success
)
docs
mapM_ (\(n, v) -> annotate (show (n, v)) >> assert (fits n v)) (concatMap snd (applicationFormFields r))
)
completeExamples
where
fits n v =
case Map.lookup n textBoxes of
Just (font, width, lines')
| not ("${" `Text.isInfixOf` v) ->
all (isJust . textWidth font) (filter (/= "") (Text.splitOn "\n" v)) && textLines font width v <= lines'
_ -> True
-- The documents in the directory of each example are the ones it gives: run reoc-examples after changing an example.
-- The source distribution does not hold the documents of the examples, so an example without its directory is skipped.
prop_examplesWritten :: Property
prop_examplesWritten =
withTests 1 . property $
mapM_
( \(dir, r) ->
whenWritten dir $
mapM_
( \(f, d) -> do
let file = "examples" </> dir </> f
exists <- evalIO (doesFileExist file)
annotate file
assert exists
written <- evalIO (Text.readFile file)
written === d
)
( [(applicationFormFile, renderApplicationForm r), (operationsManualFile, renderOperationsManual r)]
<> maybe [] (\t -> [(trainingManualFile, t)]) (renderTrainingManual r)
)
)
completeExamples
-- Checks the written documents of an example, if its directory is there.
whenWritten :: FilePath -> PropertyT IO () -> PropertyT IO ()
whenWritten dir checks = do
written <- evalIO (doesDirectoryExist ("examples" </> dir))
if written
then checks
else label "the documents of the examples are not here (a source distribution)"
prop_blankForm :: Property
prop_blankForm =
withTests 1 . property $ do
assert ("%PDF" `ByteString.isPrefixOf` blankForm)
mapM_
( \(dir, _) ->
whenWritten dir $ do
let file = "examples" </> dir </> blankFormFile
annotate file
written <- evalIO (ByteString.readFile file)
assert (written == blankForm)
)
completeExamples
-- Writing the documents writes the blank form and the written signature, read from its file if given by a path.
prop_writtenFiles :: Property
prop_writtenFiles =
withTests 1 . property $ do
tmp <- evalIO getTemporaryDirectory
let dir = tmp </> "casa-reoc-test-written-files"
signatureSource = tmp </> "casa-reoc-test-signature.png"
png = ByteString.pack [137, 80, 78, 71, 13, 10, 26, 10]
withSignature s = set (applicationForm . signature) (Just s) validBanksiaPoint
evalIO (ByteString.writeFile signatureSource png)
mapM_
( \s -> do
evalIO (removePathForcibly dir >> writeDocuments dir (withSignature s))
written <- evalIO (ByteString.readFile (dir </> writtenSignatureImageFile))
written === png
form <- evalIO (ByteString.readFile (dir </> blankFormFile))
assert (form == blankForm)
)
[WrittenSignatureImage png, WrittenSignatureFile signatureSource]
evalIO (removePathForcibly dir >> writeDocuments dir (set (applicationForm . signature) Nothing validBanksiaPoint))
unsigned <- evalIO (doesFileExist (dir </> writtenSignatureImageFile))
assert (not unsigned)
-- The examples that are valid, with their directories.
completeExamples :: [(FilePath, ReOC)]
completeExamples =
[(d, r) | (d, Right r) <- examples]
-- The valid example Banksia Point.
validBanksiaPoint :: ReOC
validBanksiaPoint =
either (error . Text.unpack . renderReOCErrors) id banksiaPoint
-- Every example is valid.
prop_examplesValid :: Property
prop_examplesValid =
withTests 1 . property $
mapM_
( \(d, filled) -> case filled of
Left errors -> annotate d >> annotate (Text.unpack (renderReOCErrors errors)) >> failure
Right _ -> success
)
examples
-- Filling in the unfilled form of a valid ReOC gives it back.
prop_fillUnfill :: Property
prop_fillUnfill =
withTests 40 . property $ do
r <- forAll genReOC'
(fillReOC (unfillReOC r) :: Either (NonEmpty ReOCError) ReOC) === Right r
-- An unfilled ReOC with nothing entered is not filled in, with an error at each required field and nothing else.
prop_fillEmpty :: Property
prop_fillEmpty =
withTests 1 . property $
case fillReOC mkUnfilledReOC :: Either (NonEmpty ReOCError) ReOC of
Right _ -> failure
Left errors -> do
assert (all (has unfilled) errors)
assert (all (any (any isField) . toListOf path) errors)
let paths = map (toListOf path) (toList errors)
paths === nub paths
assert (length errors > 40)
where
isField = \case
StepField _ -> True
StepIndex _ -> False
-- An invalid and an unfilled field of a valid ReOC each give one error, at its own path.
prop_fillErrors :: Property
prop_fillErrors =
withTests 40 . property $ do
r <- forAll genReOC'
let entered =
unfillReOC r
& operator . company . abn ?~ "12 345 678 901"
& operator . keyPersonnel . chiefExecutive . nominee . person . fullName .~ Nothing
(fillReOC entered :: Either (NonEmpty ReOCError) ReOC)
=== Left
( ReOCErrorInvalid (Invalid [StepField ReOCOperator, StepField OperatorCompany, StepField CompanyAbn] (InvalidABN "12 345 678 901"))
:| [ ReOCErrorUnfilled
( Unfilled
[ StepField ReOCOperator
, StepField OperatorKeyPersonnel
, StepField KeyPersonnelChiefExecutive
, StepField ChiefExecutiveNominee
, StepField NomineePerson
, StepField PersonFullName
]
)
]
)
-- A list field with too many elements is an error at the list.
prop_fillTooMany :: Property
prop_fillTooMany =
withTests 20 . property $ do
r <- forAll genReOC'
let u = unfillReOC r
nine = take 9 (cycle (view (cloneLens (operator . fleet)) u))
(fillReOC (u & operator . fleet .~ nine) :: Either (NonEmpty ReOCError) ReOC)
=== Left (ReOCErrorTooMany (TooMany [StepField ReOCOperator, StepField OperatorFleet] 8 9) :| [])
-- The draft example gives its invalid ABN, and every field not yet filled in.
prop_draft :: Property
prop_draft =
withTests 1 . property $
case draft of
Right _ -> failure
Left errors -> do
assert (ReOCErrorInvalid (Invalid [StepField ReOCOperator, StepField OperatorCompany, StepField CompanyAbn] (InvalidABN "15 092 285 143")) `elem` errors)
assert (not (any (\e -> toListOf path e == [[StepField ReOCOperator, StepField OperatorCompany, StepField CompanyCompanyName]]) errors))