ReviewMonths.hs

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

{- | A number of months from 1 to 12: the time from when an entry of the risk
register is made to when it is due for review. The manual requires the
register to be reviewed at least annually.

The constructor is not exported (see "ReOC.Primitive.Text1"). A
@ReviewMonths@ is built with the prism '_ReviewMonths' or with
'reviewMonthsLiteral'.
-}
module ReOC.Primitive.ReviewMonths (
  ReviewMonths,
  _ReviewMonths,
  reviewMonthsNatural,
  reviewMonthsLiteral,
) where

import Control.Lens (Prism', preview, prism')
import Language.Haskell.TH.Syntax (Code (..), Lift, Q, liftTyped)
import Numeric.Natural (Natural)

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

-- | A number of months from 1 to 12.
newtype ReviewMonths
  = ReviewMonths Natural
  deriving (Eq, Ord, Show, Lift)

{- | A number of months from 1 to 12.

>>> (12 :: Natural) ^? _ReviewMonths
Just (ReviewMonths 12)

>>> (13 :: Natural) ^? _ReviewMonths
Nothing
-}
_ReviewMonths :: Prism' Natural ReviewMonths
_ReviewMonths =
  prism'
    reviewMonthsNatural
    (\n -> if n >= 1 && n <= 12 then Just (ReviewMonths n) else Nothing)

-- | The number of months.
reviewMonthsNatural :: ReviewMonths -> Natural
reviewMonthsNatural (ReviewMonths n) =
  n

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

> $$(reviewMonthsLiteral 12)
-}
reviewMonthsLiteral :: Natural -> Code Q ReviewMonths
reviewMonthsLiteral n =
  maybe
    (Code (fail ("reviewMonthsLiteral: not from 1 to 12: " <> show n)))
    liftTyped
    (preview _ReviewMonths n)