Strict.hs

{-|
Module      : Prosidy.Compile.Strict
Description : Ensure that no unknown settings or properties are used.
Copyright   : ©2020 James Alexander Feldman-Crough
License     : MPL-2.0
Maintainer  : alex@fldcr.com
-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TupleSections #-}
module Prosidy.Compile.Strict (strict) where

import           Lens.Micro              hiding ( strict )

import qualified Prosidy                       as P
import           Prosidy.Compile.Core
import           Prosidy.Compile.Error

import           Control.Monad                  ( unless )
import           Data.HashSet                   ( HashSet )

import qualified Data.HashSet                  as HS
import qualified Data.HashMap.Strict           as HM

-- | Ensure that all properties and settings on a node are expected, and throw
-- an error when extraneous metadata is attached. This is extremely useful
-- for catching typos.
--
-- The matchers 'Prosidy.Compile.Match.blockTag', 
-- 'Prosidy.Compile.Match.inlineTag', and 'Prosidy.Compile.Match.literalTag'
-- already match strictly: wrapping them in this combinator is unneccessary.
strict :: (Applicative f, P.HasMetadata i) => RuleT i e f a -> RuleT i e f a
strict r = r <* checked
  where
    checked = rule . Lift $ \item ->
        let
            Schema { schemaProperties, schemaSettings } = collectSchema r item
            extraProperties =
                HS.difference (item ^. P.properties . P._Set) schemaProperties
            extraSettings = HS.difference
                (item ^. P.settings . P._Assoc . to HM.keysSet)
                schemaSettings
            extras =
                HS.map (PropertyKind, ) extraProperties
                    <> HS.map (SettingKind, ) extraSettings
        in
            pure $ unless (HS.null extras) (Left $ UnknownMetadata extras)

collectSchema :: RuleT i e f a -> i -> Schema
collectSchema rule = getSchema . interpretWith rule interpret

interpret :: Interpret e f Strict
interpret _ = \case
    GetProperty _ name        -> recordProperty name
    GetSetting _ name _       -> recordSetting name
    GetRequiredSetting name _ -> recordSetting name
    _                         -> doNothing

newtype Strict a = Strict (Schema -> Schema)

instance Functor Strict where
    fmap _ = coerce

instance Applicative Strict where
    pure _ = Strict id
    Strict lhs <*> Strict rhs = Strict $ lhs <> rhs

data Schema = Schema
    { schemaProperties :: HashSet P.Key
    , schemaSettings   :: HashSet P.Key
    }

instance Semigroup Schema where
    Schema p1 s1 <> Schema p2 s2 = Schema (p1 <> p2) (s1 <> s2)

instance Monoid Schema where
    mempty = Schema mempty mempty

coerce :: Strict a -> Strict b
coerce = \(Strict x) -> Strict x

getSchema :: Strict a -> Schema
getSchema (Strict x) = x mempty

doNothing :: Strict a
doNothing = Strict id

recordProperty :: P.Key -> Strict a
recordProperty k =
    Strict $ \s -> s { schemaProperties = HS.insert k $ schemaProperties s }

recordSetting :: P.Key -> Strict a
recordSetting k =
    Strict $ \s -> s { schemaSettings = HS.insert k $ schemaSettings s }