{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}

module Conformance where

import Control.Exception
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Writer.Strict
import Data.Functor.Identity

-- | A conforming monad transformer to compute a result according to a spec.
--
-- RFC 2119 describes these terms:
--
-- 1. MUST and MUST NOT:
--    These describe absolute requirements or absolute prohibitions.
--    However, some implementations still do not adhere to these.
--    Some of those situations are fixable, and some are not.
--
--    If the situation is fixable, we error with an error of type @ue@.
--
--    If the situation is fixable, we can either error out (a strict implementation) with an error of type @fe@ or apply the fix.
--    The @fe@ parameter represents fixable errors, which can either be emitted as warnings, or errored on.
--    A predicate @(fe -> Bool)@ decides whether to fix the error. (The predicate returns True if the fixable error is to be fixed.)
-- 2. SHOULD and SHOULD NOT:
--    These describe weaker requirements or prohibitions.
--    The @w@ parameter represents warnings to represent cases where requirements or prohibitions were violated.
newtype ConformT ue fe w m a = ConformT
  { forall ue fe w (m :: * -> *) a.
ConformT ue fe w m a
-> ReaderT
     (fe -> m Bool)
     (WriterT (Notes fe w) (ExceptT (HaltReason ue fe) m))
     a
unConformT ::
      ReaderT (fe -> m Bool) (WriterT (Notes fe w) (ExceptT (HaltReason ue fe) m)) a
  }
  deriving newtype
    ( forall a b. a -> ConformT ue fe w m b -> ConformT ue fe w m a
forall a b.
(a -> b) -> ConformT ue fe w m a -> ConformT ue fe w m b
forall ue fe w (m :: * -> *) a b.
Functor m =>
a -> ConformT ue fe w m b -> ConformT ue fe w m a
forall ue fe w (m :: * -> *) a b.
Functor m =>
(a -> b) -> ConformT ue fe w m a -> ConformT ue fe w m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ConformT ue fe w m b -> ConformT ue fe w m a
$c<$ :: forall ue fe w (m :: * -> *) a b.
Functor m =>
a -> ConformT ue fe w m b -> ConformT ue fe w m a
fmap :: forall a b.
(a -> b) -> ConformT ue fe w m a -> ConformT ue fe w m b
$cfmap :: forall ue fe w (m :: * -> *) a b.
Functor m =>
(a -> b) -> ConformT ue fe w m a -> ConformT ue fe w m b
Functor,
      forall a. a -> ConformT ue fe w m a
forall a b.
ConformT ue fe w m a
-> ConformT ue fe w m b -> ConformT ue fe w m a
forall a b.
ConformT ue fe w m a
-> ConformT ue fe w m b -> ConformT ue fe w m b
forall a b.
ConformT ue fe w m (a -> b)
-> ConformT ue fe w m a -> ConformT ue fe w m b
forall a b c.
(a -> b -> c)
-> ConformT ue fe w m a
-> ConformT ue fe w m b
-> ConformT ue fe w m c
forall {ue} {fe} {w} {m :: * -> *}.
Monad m =>
Functor (ConformT ue fe w m)
forall ue fe w (m :: * -> *) a.
Monad m =>
a -> ConformT ue fe w m a
forall ue fe w (m :: * -> *) a b.
Monad m =>
ConformT ue fe w m a
-> ConformT ue fe w m b -> ConformT ue fe w m a
forall ue fe w (m :: * -> *) a b.
Monad m =>
ConformT ue fe w m a
-> ConformT ue fe w m b -> ConformT ue fe w m b
forall ue fe w (m :: * -> *) a b.
Monad m =>
ConformT ue fe w m (a -> b)
-> ConformT ue fe w m a -> ConformT ue fe w m b
forall ue fe w (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> ConformT ue fe w m a
-> ConformT ue fe w m b
-> ConformT ue fe w m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b.
ConformT ue fe w m a
-> ConformT ue fe w m b -> ConformT ue fe w m a
$c<* :: forall ue fe w (m :: * -> *) a b.
Monad m =>
ConformT ue fe w m a
-> ConformT ue fe w m b -> ConformT ue fe w m a
*> :: forall a b.
ConformT ue fe w m a
-> ConformT ue fe w m b -> ConformT ue fe w m b
$c*> :: forall ue fe w (m :: * -> *) a b.
Monad m =>
ConformT ue fe w m a
-> ConformT ue fe w m b -> ConformT ue fe w m b
liftA2 :: forall a b c.
(a -> b -> c)
-> ConformT ue fe w m a
-> ConformT ue fe w m b
-> ConformT ue fe w m c
$cliftA2 :: forall ue fe w (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> ConformT ue fe w m a
-> ConformT ue fe w m b
-> ConformT ue fe w m c
<*> :: forall a b.
ConformT ue fe w m (a -> b)
-> ConformT ue fe w m a -> ConformT ue fe w m b
$c<*> :: forall ue fe w (m :: * -> *) a b.
Monad m =>
ConformT ue fe w m (a -> b)
-> ConformT ue fe w m a -> ConformT ue fe w m b
pure :: forall a. a -> ConformT ue fe w m a
$cpure :: forall ue fe w (m :: * -> *) a.
Monad m =>
a -> ConformT ue fe w m a
Applicative,
      forall a. a -> ConformT ue fe w m a
forall a b.
ConformT ue fe w m a
-> ConformT ue fe w m b -> ConformT ue fe w m b
forall a b.
ConformT ue fe w m a
-> (a -> ConformT ue fe w m b) -> ConformT ue fe w m b
forall ue fe w (m :: * -> *).
Monad m =>
Applicative (ConformT ue fe w m)
forall ue fe w (m :: * -> *) a.
Monad m =>
a -> ConformT ue fe w m a
forall ue fe w (m :: * -> *) a b.
Monad m =>
ConformT ue fe w m a
-> ConformT ue fe w m b -> ConformT ue fe w m b
forall ue fe w (m :: * -> *) a b.
Monad m =>
ConformT ue fe w m a
-> (a -> ConformT ue fe w m b) -> ConformT ue fe w m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> ConformT ue fe w m a
$creturn :: forall ue fe w (m :: * -> *) a.
Monad m =>
a -> ConformT ue fe w m a
>> :: forall a b.
ConformT ue fe w m a
-> ConformT ue fe w m b -> ConformT ue fe w m b
$c>> :: forall ue fe w (m :: * -> *) a b.
Monad m =>
ConformT ue fe w m a
-> ConformT ue fe w m b -> ConformT ue fe w m b
>>= :: forall a b.
ConformT ue fe w m a
-> (a -> ConformT ue fe w m b) -> ConformT ue fe w m b
$c>>= :: forall ue fe w (m :: * -> *) a b.
Monad m =>
ConformT ue fe w m a
-> (a -> ConformT ue fe w m b) -> ConformT ue fe w m b
Monad,
      MonadReader (fe -> m Bool),
      MonadError (HaltReason ue fe),
      MonadWriter (Notes fe w)
    )

-- We cannot have 'Alternative' because there is no 'empty', but we don't want to depend on some dependency that provides 'Alt': https://hackage.haskell.org/package/semigroupoids-5.3.7/docs/Data-Functor-Alt.html
-- because it's a huge dependency.
altConform :: Monad m => ConformT ue fe w m a -> ConformT ue fe w m a -> ConformT ue fe w m a
altConform :: forall (m :: * -> *) ue fe w a.
Monad m =>
ConformT ue fe w m a
-> ConformT ue fe w m a -> ConformT ue fe w m a
altConform ConformT ue fe w m a
cf1 ConformT ue fe w m a
cf2 = do
  fe -> m Bool
decider <- forall r (m :: * -> *). MonadReader r m => m r
ask
  Either (HaltReason ue fe) (a, Notes fe w)
errOrTup1 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall fe (m :: * -> *) ue w a.
(fe -> m Bool)
-> ConformT ue fe w m a
-> m (Either (HaltReason ue fe) (a, Notes fe w))
runConformTFlexible fe -> m Bool
decider ConformT ue fe w m a
cf1
  case Either (HaltReason ue fe) (a, Notes fe w)
errOrTup1 of
    Right (a
a, Notes fe w
notes) -> do
      forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Notes fe w
notes
      forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
    Left HaltReason ue fe
_ -> do
      Either (HaltReason ue fe) (a, Notes fe w)
errOrTup2 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall fe (m :: * -> *) ue w a.
(fe -> m Bool)
-> ConformT ue fe w m a
-> m (Either (HaltReason ue fe) (a, Notes fe w))
runConformTFlexible fe -> m Bool
decider ConformT ue fe w m a
cf2
      case Either (HaltReason ue fe) (a, Notes fe w)
errOrTup2 of
        Right (a
a, Notes fe w
notes) -> do
          forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Notes fe w
notes
          forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
        Left HaltReason ue fe
err2 -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError HaltReason ue fe
err2

instance MonadTrans (ConformT ue fe w) where
  lift :: forall (m :: * -> *) a. Monad m => m a -> ConformT ue fe w m a
lift = forall ue fe w (m :: * -> *) a.
ReaderT
  (fe -> m Bool)
  (WriterT (Notes fe w) (ExceptT (HaltReason ue fe) m))
  a
-> ConformT ue fe w m a
ConformT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

data HaltReason ue fe
  = HaltedBecauseOfUnfixableError !ue
  | HaltedBecauseOfStrictness !fe
  deriving (Int -> HaltReason ue fe -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall ue fe.
(Show ue, Show fe) =>
Int -> HaltReason ue fe -> ShowS
forall ue fe. (Show ue, Show fe) => [HaltReason ue fe] -> ShowS
forall ue fe. (Show ue, Show fe) => HaltReason ue fe -> String
showList :: [HaltReason ue fe] -> ShowS
$cshowList :: forall ue fe. (Show ue, Show fe) => [HaltReason ue fe] -> ShowS
show :: HaltReason ue fe -> String
$cshow :: forall ue fe. (Show ue, Show fe) => HaltReason ue fe -> String
showsPrec :: Int -> HaltReason ue fe -> ShowS
$cshowsPrec :: forall ue fe.
(Show ue, Show fe) =>
Int -> HaltReason ue fe -> ShowS
Show, HaltReason ue fe -> HaltReason ue fe -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall ue fe.
(Eq ue, Eq fe) =>
HaltReason ue fe -> HaltReason ue fe -> Bool
/= :: HaltReason ue fe -> HaltReason ue fe -> Bool
$c/= :: forall ue fe.
(Eq ue, Eq fe) =>
HaltReason ue fe -> HaltReason ue fe -> Bool
== :: HaltReason ue fe -> HaltReason ue fe -> Bool
$c== :: forall ue fe.
(Eq ue, Eq fe) =>
HaltReason ue fe -> HaltReason ue fe -> Bool
Eq)

instance (Exception ue, Exception fe) => Exception (HaltReason ue fe) where
  displayException :: HaltReason ue fe -> String
displayException = \case
    HaltedBecauseOfUnfixableError ue
ue -> forall e. Exception e => e -> String
displayException ue
ue
    HaltedBecauseOfStrictness fe
fe -> forall e. Exception e => e -> String
displayException fe
fe

data Notes fe w = Notes
  { forall fe w. Notes fe w -> [fe]
notesFixableErrors :: ![fe],
    forall fe w. Notes fe w -> [w]
notesWarnings :: ![w]
  }
  deriving (Int -> Notes fe w -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall fe w. (Show fe, Show w) => Int -> Notes fe w -> ShowS
forall fe w. (Show fe, Show w) => [Notes fe w] -> ShowS
forall fe w. (Show fe, Show w) => Notes fe w -> String
showList :: [Notes fe w] -> ShowS
$cshowList :: forall fe w. (Show fe, Show w) => [Notes fe w] -> ShowS
show :: Notes fe w -> String
$cshow :: forall fe w. (Show fe, Show w) => Notes fe w -> String
showsPrec :: Int -> Notes fe w -> ShowS
$cshowsPrec :: forall fe w. (Show fe, Show w) => Int -> Notes fe w -> ShowS
Show, Notes fe w -> Notes fe w -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall fe w. (Eq fe, Eq w) => Notes fe w -> Notes fe w -> Bool
/= :: Notes fe w -> Notes fe w -> Bool
$c/= :: forall fe w. (Eq fe, Eq w) => Notes fe w -> Notes fe w -> Bool
== :: Notes fe w -> Notes fe w -> Bool
$c== :: forall fe w. (Eq fe, Eq w) => Notes fe w -> Notes fe w -> Bool
Eq)

instance Semigroup (Notes w fe) where
  <> :: Notes w fe -> Notes w fe -> Notes w fe
(<>) (Notes [w]
fes1 [fe]
ws1) (Notes [w]
fes2 [fe]
ws2) =
    Notes
      { notesFixableErrors :: [w]
notesFixableErrors = [w]
fes1 forall a. [a] -> [a] -> [a]
++ [w]
fes2,
        notesWarnings :: [fe]
notesWarnings = [fe]
ws1 forall a. [a] -> [a] -> [a]
++ [fe]
ws2
      }

instance Monoid (Notes w fe) where
  mempty :: Notes w fe
mempty = forall fe w. [fe] -> [w] -> Notes fe w
Notes [] []
  mappend :: Notes w fe -> Notes w fe -> Notes w fe
mappend = forall a. Semigroup a => a -> a -> a
(<>)

nullNotes :: Notes w fe -> Bool
nullNotes :: forall w fe. Notes w fe -> Bool
nullNotes Notes {[w]
[fe]
notesWarnings :: [fe]
notesFixableErrors :: [w]
notesWarnings :: forall fe w. Notes fe w -> [w]
notesFixableErrors :: forall fe w. Notes fe w -> [fe]
..} = forall (t :: * -> *) a. Foldable t => t a -> Bool
null [w]
notesFixableErrors Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [fe]
notesWarnings

-- | Most flexible way to run a 'ConformT'
runConformTFlexible ::
  (fe -> m Bool) ->
  ConformT ue fe w m a ->
  m (Either (HaltReason ue fe) (a, Notes fe w))
runConformTFlexible :: forall fe (m :: * -> *) ue w a.
(fe -> m Bool)
-> ConformT ue fe w m a
-> m (Either (HaltReason ue fe) (a, Notes fe w))
runConformTFlexible fe -> m Bool
predicate (ConformT ReaderT
  (fe -> m Bool)
  (WriterT (Notes fe w) (ExceptT (HaltReason ue fe) m))
  a
func) = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT
  (fe -> m Bool)
  (WriterT (Notes fe w) (ExceptT (HaltReason ue fe) m))
  a
func fe -> m Bool
predicate))

-- | Don't fix any fixable errors.
--
-- This is standard-compliant.
runConformT ::
  Monad m =>
  ConformT ue fe w m a ->
  m (Either (HaltReason ue fe) (a, [w]))
runConformT :: forall (m :: * -> *) ue fe w a.
Monad m =>
ConformT ue fe w m a -> m (Either (HaltReason ue fe) (a, [w]))
runConformT ConformT ue fe w m a
func = do
  Either (HaltReason ue fe) (a, Notes fe w)
errOrTup <- forall fe (m :: * -> *) ue w a.
(fe -> m Bool)
-> ConformT ue fe w m a
-> m (Either (HaltReason ue fe) (a, Notes fe w))
runConformTFlexible forall (m :: * -> *) fe. Applicative m => fe -> m Bool
fixNone ConformT ue fe w m a
func
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ do
    (a
a, Notes fe w
notes) <- Either (HaltReason ue fe) (a, Notes fe w)
errOrTup
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, forall fe w. Notes fe w -> [w]
notesWarnings Notes fe w
notes)

-- | Don't fix any fixable errors, and don't allow any warnings either
--
-- This is standard-compliant, but potentially more strict than necessary.
runConformTStrict ::
  Monad m =>
  ConformT ue fe w m a ->
  m (Either (Either ue (Notes fe w)) a)
runConformTStrict :: forall (m :: * -> *) ue fe w a.
Monad m =>
ConformT ue fe w m a -> m (Either (Either ue (Notes fe w)) a)
runConformTStrict ConformT ue fe w m a
func = do
  Either (HaltReason ue fe) (a, Notes fe w)
errOrTup <- forall fe (m :: * -> *) ue w a.
(fe -> m Bool)
-> ConformT ue fe w m a
-> m (Either (HaltReason ue fe) (a, Notes fe w))
runConformTFlexible forall (m :: * -> *) fe. Applicative m => fe -> m Bool
fixNone ConformT ue fe w m a
func
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Either (HaltReason ue fe) (a, Notes fe w)
errOrTup of
    Left HaltReason ue fe
haltReason -> case HaltReason ue fe
haltReason of
      HaltedBecauseOfUnfixableError ue
ue -> forall a b. a -> Either a b
Left (forall a b. a -> Either a b
Left ue
ue)
      -- Cannot happen, but is fine if it does.
      HaltedBecauseOfStrictness fe
fe -> forall a b. a -> Either a b
Left (forall a b. b -> Either a b
Right (forall fe w. [fe] -> [w] -> Notes fe w
Notes [fe
fe] []))
    Right (a
a, Notes fe w
notes) -> if forall w fe. Notes w fe -> Bool
nullNotes Notes fe w
notes then forall a b. b -> Either a b
Right a
a else forall a b. a -> Either a b
Left (forall a b. b -> Either a b
Right Notes fe w
notes)

-- | Fix as much as possible
--
-- That this is __not__ standard-compliant.
runConformTLenient ::
  Monad m =>
  ConformT ue fe w m a ->
  m (Either ue (a, Notes fe w))
runConformTLenient :: forall (m :: * -> *) ue fe w a.
Monad m =>
ConformT ue fe w m a -> m (Either ue (a, Notes fe w))
runConformTLenient ConformT ue fe w m a
func = do
  Either (HaltReason ue fe) (a, Notes fe w)
errOrTup <- forall fe (m :: * -> *) ue w a.
(fe -> m Bool)
-> ConformT ue fe w m a
-> m (Either (HaltReason ue fe) (a, Notes fe w))
runConformTFlexible forall (m :: * -> *) fe. Applicative m => fe -> m Bool
fixAll ConformT ue fe w m a
func
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Either (HaltReason ue fe) (a, Notes fe w)
errOrTup of
    Left HaltReason ue fe
hr -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ case HaltReason ue fe
hr of
      HaltedBecauseOfStrictness fe
_ -> forall a. HasCallStack => String -> a
error String
"cannot happen, but this cannot be proven to the compiler."
      HaltedBecauseOfUnfixableError ue
ue -> ue
ue
    Right (a, Notes fe w)
r -> forall a b. b -> Either a b
Right (a, Notes fe w)
r

type Conform ue fe w = ConformT ue fe w Identity

-- | Most flexible way to run a 'Conform'
runConformFlexible ::
  -- | Predicate to select fixable errors that should be fixed and thereby
  -- become a warning instead.
  (fe -> Bool) ->
  Conform ue fe w a ->
  Either (HaltReason ue fe) (a, Notes fe w)
runConformFlexible :: forall fe ue w a.
(fe -> Bool)
-> Conform ue fe w a -> Either (HaltReason ue fe) (a, Notes fe w)
runConformFlexible fe -> Bool
predicate = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall fe (m :: * -> *) ue w a.
(fe -> m Bool)
-> ConformT ue fe w m a
-> m (Either (HaltReason ue fe) (a, Notes fe w))
runConformTFlexible (forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
. fe -> Bool
predicate)

-- | Don't fix any fixable errors.
--
-- This is standard-compliant
runConform ::
  Conform ue fe w a ->
  Either (HaltReason ue fe) (a, [w])
runConform :: forall ue fe w a.
Conform ue fe w a -> Either (HaltReason ue fe) (a, [w])
runConform = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) ue fe w a.
Monad m =>
ConformT ue fe w m a -> m (Either (HaltReason ue fe) (a, [w]))
runConformT

-- | Don't fix any fixable errors, and don't allow any warnings either
--
-- This is standard-compliant, but potentially more strict than necessary.
runConformStrict ::
  Conform ue fe w a ->
  Either (Either ue (Notes fe w)) a
runConformStrict :: forall ue fe w a.
Conform ue fe w a -> Either (Either ue (Notes fe w)) a
runConformStrict = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) ue fe w a.
Monad m =>
ConformT ue fe w m a -> m (Either (Either ue (Notes fe w)) a)
runConformTStrict

-- | Fix as much as possible
--
-- That this is __not__ standard-compliant.
runConformLenient ::
  Conform ue fe w a ->
  Either ue (a, Notes fe w)
runConformLenient :: forall ue fe w a. Conform ue fe w a -> Either ue (a, Notes fe w)
runConformLenient = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) ue fe w a.
Monad m =>
ConformT ue fe w m a -> m (Either ue (a, Notes fe w))
runConformTLenient

-- | Try to run a conform function, return Nothing if there were unfixable
-- errors or unfixed fixable errors.
tryConform ::
  Monad m =>
  ConformT ue fe w m a ->
  ConformT ue fe w m (Maybe a)
tryConform :: forall (m :: * -> *) ue fe w a.
Monad m =>
ConformT ue fe w m a -> ConformT ue fe w m (Maybe a)
tryConform ConformT ue fe w m a
c = forall ue fe w (m :: * -> *) a.
ReaderT
  (fe -> m Bool)
  (WriterT (Notes fe w) (ExceptT (HaltReason ue fe) m))
  a
-> ConformT ue fe w m a
ConformT forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \fe -> m Bool
predicate -> do
  Either (HaltReason ue fe) (a, Notes fe w)
errOrRes <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall fe (m :: * -> *) ue w a.
(fe -> m Bool)
-> ConformT ue fe w m a
-> m (Either (HaltReason ue fe) (a, Notes fe w))
runConformTFlexible fe -> m Bool
predicate ConformT ue fe w m a
c
  case Either (HaltReason ue fe) (a, Notes fe w)
errOrRes of
    Left HaltReason ue fe
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Right (a
result, Notes fe w
notes) -> do
      forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Notes fe w
notes
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just a
result)

fixAll :: Applicative m => fe -> m Bool
fixAll :: forall (m :: * -> *) fe. Applicative m => fe -> m Bool
fixAll = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

fixNone :: Applicative m => fe -> m Bool
fixNone :: forall (m :: * -> *) fe. Applicative m => fe -> m Bool
fixNone = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

conformFromEither :: Monad m => Either ue a -> ConformT ue fe w m a
conformFromEither :: forall (m :: * -> *) ue a fe w.
Monad m =>
Either ue a -> ConformT ue fe w m a
conformFromEither = \case
  Left ue
ue -> forall (m :: * -> *) ue fe w a.
Monad m =>
ue -> ConformT ue fe w m a
unfixableError ue
ue
  Right a
r -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r

conformMapAll :: Monad m => (ue1 -> ue2) -> (fe1 -> fe2) -> (w1 -> w2) -> ConformT ue1 fe1 w1 m a -> ConformT ue2 fe2 w2 m a
conformMapAll :: forall (m :: * -> *) ue1 ue2 fe1 fe2 w1 w2 a.
Monad m =>
(ue1 -> ue2)
-> (fe1 -> fe2)
-> (w1 -> w2)
-> ConformT ue1 fe1 w1 m a
-> ConformT ue2 fe2 w2 m a
conformMapAll ue1 -> ue2
ueFunc fe1 -> fe2
feFunc w1 -> w2
wFunc (ConformT ReaderT
  (fe1 -> m Bool)
  (WriterT (Notes fe1 w1) (ExceptT (HaltReason ue1 fe1) m))
  a
cFunc) =
  forall ue fe w (m :: * -> *) a.
ReaderT
  (fe -> m Bool)
  (WriterT (Notes fe w) (ExceptT (HaltReason ue fe) m))
  a
-> ConformT ue fe w m a
ConformT forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a (n :: * -> *) b r.
(m a -> n b) -> ReaderT r m a -> ReaderT r n b
mapReaderT
      ( forall (m :: * -> *) a w (n :: * -> *) b w'.
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
mapWriterT
          ( \ExceptT (HaltReason ue1 fe1) m (a, Notes fe1 w1)
func -> do
              (a
res, Notes fe1 w1
notes) <- forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT HaltReason ue1 fe1 -> HaltReason ue2 fe2
haltReasonMapError ExceptT (HaltReason ue1 fe1) m (a, Notes fe1 w1)
func
              forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
res, Notes fe1 w1 -> Notes fe2 w2
notesMapError Notes fe1 w1
notes)
          )
      )
      (forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT (\fe2 -> m Bool
predicate -> fe2 -> m Bool
predicate forall b c a. (b -> c) -> (a -> b) -> a -> c
. fe1 -> fe2
feFunc) ReaderT
  (fe1 -> m Bool)
  (WriterT (Notes fe1 w1) (ExceptT (HaltReason ue1 fe1) m))
  a
cFunc)
  where
    notesMapError :: Notes fe1 w1 -> Notes fe2 w2
notesMapError (Notes [fe1]
fes [w1]
wes) =
      forall fe w. [fe] -> [w] -> Notes fe w
Notes
        (forall a b. (a -> b) -> [a] -> [b]
map fe1 -> fe2
feFunc [fe1]
fes)
        (forall a b. (a -> b) -> [a] -> [b]
map w1 -> w2
wFunc [w1]
wes)
    haltReasonMapError :: HaltReason ue1 fe1 -> HaltReason ue2 fe2
haltReasonMapError = \case
      HaltedBecauseOfUnfixableError ue1
ue -> forall ue fe. ue -> HaltReason ue fe
HaltedBecauseOfUnfixableError (ue1 -> ue2
ueFunc ue1
ue)
      HaltedBecauseOfStrictness fe1
fe -> forall ue fe. fe -> HaltReason ue fe
HaltedBecauseOfStrictness (fe1 -> fe2
feFunc fe1
fe)

conformMapErrors :: Monad m => (ue1 -> ue2) -> (fe1 -> fe2) -> ConformT ue1 fe1 w m a -> ConformT ue2 fe2 w m a
conformMapErrors :: forall (m :: * -> *) ue1 ue2 fe1 fe2 w a.
Monad m =>
(ue1 -> ue2)
-> (fe1 -> fe2) -> ConformT ue1 fe1 w m a -> ConformT ue2 fe2 w m a
conformMapErrors ue1 -> ue2
ueFunc fe1 -> fe2
feFunc = forall (m :: * -> *) ue1 ue2 fe1 fe2 w1 w2 a.
Monad m =>
(ue1 -> ue2)
-> (fe1 -> fe2)
-> (w1 -> w2)
-> ConformT ue1 fe1 w1 m a
-> ConformT ue2 fe2 w2 m a
conformMapAll ue1 -> ue2
ueFunc fe1 -> fe2
feFunc forall a. a -> a
id

conformMapError ::
  Monad m =>
  (ue1 -> ue2) ->
  ConformT ue1 fe w m a ->
  ConformT ue2 fe w m a
conformMapError :: forall (m :: * -> *) ue1 ue2 fe w a.
Monad m =>
(ue1 -> ue2) -> ConformT ue1 fe w m a -> ConformT ue2 fe w m a
conformMapError ue1 -> ue2
func = forall (m :: * -> *) ue1 ue2 fe1 fe2 w a.
Monad m =>
(ue1 -> ue2)
-> (fe1 -> fe2) -> ConformT ue1 fe1 w m a -> ConformT ue2 fe2 w m a
conformMapErrors ue1 -> ue2
func forall a. a -> a
id

conformMapFixableError ::
  Monad m =>
  (fe1 -> fe2) ->
  ConformT ue fe1 w m a ->
  ConformT ue fe2 w m a
conformMapFixableError :: forall (m :: * -> *) fe1 fe2 ue w a.
Monad m =>
(fe1 -> fe2) -> ConformT ue fe1 w m a -> ConformT ue fe2 w m a
conformMapFixableError = forall (m :: * -> *) ue1 ue2 fe1 fe2 w a.
Monad m =>
(ue1 -> ue2)
-> (fe1 -> fe2) -> ConformT ue1 fe1 w m a -> ConformT ue2 fe2 w m a
conformMapErrors forall a. a -> a
id

emitWarning :: Monad m => w -> ConformT ue fe w m ()
emitWarning :: forall (m :: * -> *) w ue fe. Monad m => w -> ConformT ue fe w m ()
emitWarning w
w = forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (forall fe w. [fe] -> [w] -> Notes fe w
Notes [] [w
w])

emitFixableError :: Monad m => fe -> ConformT ue fe w m ()
emitFixableError :: forall (m :: * -> *) fe ue w.
Monad m =>
fe -> ConformT ue fe w m ()
emitFixableError fe
fe = do
  fe -> m Bool
predicate <- forall r (m :: * -> *). MonadReader r m => m r
ask
  Bool
fixThisError <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ fe -> m Bool
predicate fe
fe
  if Bool
fixThisError
    then forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (forall fe w. [fe] -> [w] -> Notes fe w
Notes [fe
fe] [])
    else forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (forall ue fe. fe -> HaltReason ue fe
HaltedBecauseOfStrictness fe
fe)

unfixableError :: Monad m => ue -> ConformT ue fe w m a
unfixableError :: forall (m :: * -> *) ue fe w a.
Monad m =>
ue -> ConformT ue fe w m a
unfixableError ue
ue = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (forall ue fe. ue -> HaltReason ue fe
HaltedBecauseOfUnfixableError ue
ue)