{-|
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 :: RuleT i e f a -> RuleT i e f a
strict r :: RuleT i e f a
r = RuleT i e f a
r RuleT i e f a -> RuleT i e f () -> RuleT i e f a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* RuleT i e f ()
forall e. RuleT i e f ()
checked
  where
    checked :: RuleT i e f ()
checked = RuleF i e f () -> RuleT i e f ()
forall i e (f :: * -> *) o. RuleF i e f o -> RuleT i e f o
rule (RuleF i e f () -> RuleT i e f ())
-> ((i -> f (Either (Error e) ())) -> RuleF i e f ())
-> (i -> f (Either (Error e) ()))
-> RuleT i e f ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (i -> f (Either (Error e) ())) -> RuleF i e f ()
forall input (context :: * -> *) error output.
(input -> context (Either (Error error) output))
-> RuleF input error context output
Lift ((i -> f (Either (Error e) ())) -> RuleT i e f ())
-> (i -> f (Either (Error e) ())) -> RuleT i e f ()
forall a b. (a -> b) -> a -> b
$ \item :: i
item ->
        let
            Schema { HashSet Key
schemaProperties :: Schema -> HashSet Key
schemaProperties :: HashSet Key
schemaProperties, HashSet Key
schemaSettings :: Schema -> HashSet Key
schemaSettings :: HashSet Key
schemaSettings } = RuleT i e f a -> i -> Schema
forall i e (f :: * -> *) a. RuleT i e f a -> i -> Schema
collectSchema RuleT i e f a
r i
item
            extraProperties :: HashSet Key
extraProperties =
                HashSet Key -> HashSet Key -> HashSet Key
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HS.difference (i
item i -> Getting (HashSet Key) i (HashSet Key) -> HashSet Key
forall s a. s -> Getting a s a -> a
^. Optic (->) (Const (HashSet Key)) i i (Set Key) (Set Key)
forall m. HasMetadata m => Lens' m (Set Key)
P.properties Optic (->) (Const (HashSet Key)) i i (Set Key) (Set Key)
-> ((HashSet Key -> Const (HashSet Key) (HashSet Key))
    -> Set Key -> Const (HashSet Key) (Set Key))
-> Getting (HashSet Key) i (HashSet Key)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HashSet Key -> Const (HashSet Key) (HashSet Key))
-> Set Key -> Const (HashSet Key) (Set Key)
forall a b. Iso (Set a) (Set b) (HashSet a) (HashSet b)
P._Set) HashSet Key
schemaProperties
            extraSettings :: HashSet Key
extraSettings = HashSet Key -> HashSet Key -> HashSet Key
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HS.difference
                (i
item i -> Getting (HashSet Key) i (HashSet Key) -> HashSet Key
forall s a. s -> Getting a s a -> a
^. Optic
  (->) (Const (HashSet Key)) i i (Assoc Key Text) (Assoc Key Text)
forall m. HasMetadata m => Lens' m (Assoc Key Text)
P.settings Optic
  (->) (Const (HashSet Key)) i i (Assoc Key Text) (Assoc Key Text)
-> ((HashSet Key -> Const (HashSet Key) (HashSet Key))
    -> Assoc Key Text -> Const (HashSet Key) (Assoc Key Text))
-> Getting (HashSet Key) i (HashSet Key)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic
  (->)
  (Const (HashSet Key))
  (Assoc Key Text)
  (Assoc Key Text)
  (HashMap Key Text)
  (HashMap Key Text)
forall k v k' v'.
Iso (Assoc k v) (Assoc k' v') (HashMap k v) (HashMap k' v')
P._Assoc Optic
  (->)
  (Const (HashSet Key))
  (Assoc Key Text)
  (Assoc Key Text)
  (HashMap Key Text)
  (HashMap Key Text)
-> ((HashSet Key -> Const (HashSet Key) (HashSet Key))
    -> HashMap Key Text -> Const (HashSet Key) (HashMap Key Text))
-> (HashSet Key -> Const (HashSet Key) (HashSet Key))
-> Assoc Key Text
-> Const (HashSet Key) (Assoc Key Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HashMap Key Text -> HashSet Key)
-> SimpleGetter (HashMap Key Text) (HashSet Key)
forall s a. (s -> a) -> SimpleGetter s a
to HashMap Key Text -> HashSet Key
forall k a. HashMap k a -> HashSet k
HM.keysSet)
                HashSet Key
schemaSettings
            extras :: HashSet (MetadataKind, Key)
extras =
                (Key -> (MetadataKind, Key))
-> HashSet Key -> HashSet (MetadataKind, Key)
forall b a.
(Hashable b, Eq b) =>
(a -> b) -> HashSet a -> HashSet b
HS.map (MetadataKind
PropertyKind, ) HashSet Key
extraProperties
                    HashSet (MetadataKind, Key)
-> HashSet (MetadataKind, Key) -> HashSet (MetadataKind, Key)
forall a. Semigroup a => a -> a -> a
<> (Key -> (MetadataKind, Key))
-> HashSet Key -> HashSet (MetadataKind, Key)
forall b a.
(Hashable b, Eq b) =>
(a -> b) -> HashSet a -> HashSet b
HS.map (MetadataKind
SettingKind, ) HashSet Key
extraSettings
        in
            Either (Error e) () -> f (Either (Error e) ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Error e) () -> f (Either (Error e) ()))
-> Either (Error e) () -> f (Either (Error e) ())
forall a b. (a -> b) -> a -> b
$ Bool -> Either (Error e) () -> Either (Error e) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (HashSet (MetadataKind, Key) -> Bool
forall a. HashSet a -> Bool
HS.null HashSet (MetadataKind, Key)
extras) (Error e -> Either (Error e) ()
forall a b. a -> Either a b
Left (Error e -> Either (Error e) ()) -> Error e -> Either (Error e) ()
forall a b. (a -> b) -> a -> b
$ HashSet (MetadataKind, Key) -> Error e
forall a. HashSet (MetadataKind, Key) -> Error a
UnknownMetadata HashSet (MetadataKind, Key)
extras)

collectSchema :: RuleT i e f a -> i -> Schema
collectSchema :: RuleT i e f a -> i -> Schema
collectSchema rule :: RuleT i e f a
rule = Strict a -> Schema
forall a. Strict a -> Schema
getSchema (Strict a -> Schema) -> (i -> Strict a) -> i -> Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RuleT i e f a -> Interpret e f Strict -> i -> Strict a
forall (g :: * -> *) i e (f :: * -> *) a.
Applicative g =>
RuleT i e f a -> Interpret e f g -> i -> g a
interpretWith RuleT i e f a
rule Interpret e f Strict
forall e (f :: * -> *). Interpret e f Strict
interpret

interpret :: Interpret e f Strict
interpret :: i -> RuleF i e f a -> Strict a
interpret _ = \case
    GetProperty _ name :: Key
name        -> Key -> Strict a
forall a. Key -> Strict a
recordProperty Key
name
    GetSetting _ name :: Key
name _       -> Key -> Strict a
forall a. Key -> Strict a
recordSetting Key
name
    GetRequiredSetting name :: Key
name _ -> Key -> Strict a
forall a. Key -> Strict a
recordSetting Key
name
    _                         -> Strict a
forall a. Strict a
doNothing

newtype Strict a = Strict (Schema -> Schema)

instance Functor Strict where
    fmap :: (a -> b) -> Strict a -> Strict b
fmap _ = Strict a -> Strict b
forall a b. Strict a -> Strict b
coerce

instance Applicative Strict where
    pure :: a -> Strict a
pure _ = (Schema -> Schema) -> Strict a
forall a. (Schema -> Schema) -> Strict a
Strict Schema -> Schema
forall a. a -> a
id
    Strict lhs :: Schema -> Schema
lhs <*> :: Strict (a -> b) -> Strict a -> Strict b
<*> Strict rhs :: Schema -> Schema
rhs = (Schema -> Schema) -> Strict b
forall a. (Schema -> Schema) -> Strict a
Strict ((Schema -> Schema) -> Strict b) -> (Schema -> Schema) -> Strict b
forall a b. (a -> b) -> a -> b
$ Schema -> Schema
lhs (Schema -> Schema) -> (Schema -> Schema) -> Schema -> Schema
forall a. Semigroup a => a -> a -> a
<> Schema -> Schema
rhs

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

instance Semigroup Schema where
    Schema p1 :: HashSet Key
p1 s1 :: HashSet Key
s1 <> :: Schema -> Schema -> Schema
<> Schema p2 :: HashSet Key
p2 s2 :: HashSet Key
s2 = HashSet Key -> HashSet Key -> Schema
Schema (HashSet Key
p1 HashSet Key -> HashSet Key -> HashSet Key
forall a. Semigroup a => a -> a -> a
<> HashSet Key
p2) (HashSet Key
s1 HashSet Key -> HashSet Key -> HashSet Key
forall a. Semigroup a => a -> a -> a
<> HashSet Key
s2)

instance Monoid Schema where
    mempty :: Schema
mempty = HashSet Key -> HashSet Key -> Schema
Schema HashSet Key
forall a. Monoid a => a
mempty HashSet Key
forall a. Monoid a => a
mempty

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

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

doNothing :: Strict a
doNothing :: Strict a
doNothing = (Schema -> Schema) -> Strict a
forall a. (Schema -> Schema) -> Strict a
Strict Schema -> Schema
forall a. a -> a
id

recordProperty :: P.Key -> Strict a
recordProperty :: Key -> Strict a
recordProperty k :: Key
k =
    (Schema -> Schema) -> Strict a
forall a. (Schema -> Schema) -> Strict a
Strict ((Schema -> Schema) -> Strict a) -> (Schema -> Schema) -> Strict a
forall a b. (a -> b) -> a -> b
$ \s :: Schema
s -> Schema
s { schemaProperties :: HashSet Key
schemaProperties = Key -> HashSet Key -> HashSet Key
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HS.insert Key
k (HashSet Key -> HashSet Key) -> HashSet Key -> HashSet Key
forall a b. (a -> b) -> a -> b
$ Schema -> HashSet Key
schemaProperties Schema
s }

recordSetting :: P.Key -> Strict a
recordSetting :: Key -> Strict a
recordSetting k :: Key
k =
    (Schema -> Schema) -> Strict a
forall a. (Schema -> Schema) -> Strict a
Strict ((Schema -> Schema) -> Strict a) -> (Schema -> Schema) -> Strict a
forall a b. (a -> b) -> a -> b
$ \s :: Schema
s -> Schema
s { schemaSettings :: HashSet Key
schemaSettings = Key -> HashSet Key -> HashSet Key
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HS.insert Key
k (HashSet Key -> HashSet Key) -> HashSet Key -> HashSet Key
forall a b. (a -> b) -> a -> b
$ Schema -> HashSet Key
schemaSettings Schema
s }