module Ema.Route.Prism.Check (
  checkRoutePrismGivenFilePath,
  checkRoutePrismGivenRoute,
) where

import Control.Monad.Writer (Writer, runWriter, tell)
import Data.Text qualified as T
import Ema.Route.Prism.Type (Prism_, fromPrism_)
import Optics.Core (Prism', preview, review)
import System.FilePath ((</>))

checkRoutePrismGivenRoute ::
  (HasCallStack, Eq r, Show r) =>
  (a -> Prism_ FilePath r) ->
  a ->
  r ->
  Either Text ()
checkRoutePrismGivenRoute :: forall r a.
(HasCallStack, Eq r, Show r) =>
(a -> Prism_ FilePath r) -> a -> r -> Either Text ()
checkRoutePrismGivenRoute a -> Prism_ FilePath r
enc a
a r
r =
  let s :: FilePath
s = forall k (is :: IxList) t b.
Is k A_Review =>
Optic' k is t b -> b -> t
review (forall s a. Prism_ s a -> Prism' s a
fromPrism_ forall a b. (a -> b) -> a -> b
$ a -> Prism_ FilePath r
enc a
a) r
r
   in forall r a.
(Eq r, Show r) =>
(a -> Prism_ FilePath r) -> a -> r -> FilePath -> Either Text ()
checkRoutePrism a -> Prism_ FilePath r
enc a
a r
r FilePath
s

checkRoutePrismGivenFilePath ::
  (HasCallStack, Eq r, Show r) =>
  (a -> Prism_ FilePath r) ->
  a ->
  FilePath ->
  Either (r, [(FilePath, Text)]) (Maybe r)
checkRoutePrismGivenFilePath :: forall r a.
(HasCallStack, Eq r, Show r) =>
(a -> Prism_ FilePath r)
-> a -> FilePath -> Either (r, [(FilePath, Text)]) (Maybe r)
checkRoutePrismGivenFilePath a -> Prism_ FilePath r
enc a
a FilePath
s = do
  -- We should treat /foo, /foo.html and /foo/index.html as equivalent.
  let candidates :: [FilePath]
candidates = [FilePath
s, FilePath
s forall a. Semigroup a => a -> a -> a
<> FilePath
".html", FilePath
s FilePath -> FilePath -> FilePath
</> FilePath
"index.html"]
      rp :: Prism' FilePath r
rp = forall s a. Prism_ s a -> Prism' s a
fromPrism_ forall a b. (a -> b) -> a -> b
$ a -> Prism_ FilePath r
enc a
a
  case forall (t :: Type -> Type) (f :: Type -> Type) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum (forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview Prism' FilePath r
rp forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath]
candidates) of
    Maybe r
Nothing -> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Just r
r -> do
      -- All candidates must be checked, and if even one passes - we let this
      -- route go through.
      let ([(FilePath, Text)]
failed, [()]
passed) =
            forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$
              [FilePath]
candidates forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> \FilePath
candidate ->
                case forall r a.
(Eq r, Show r) =>
(a -> Prism_ FilePath r) -> a -> r -> FilePath -> Either Text ()
checkRoutePrism a -> Prism_ FilePath r
enc a
a r
r FilePath
candidate of
                  Left Text
err -> forall a b. a -> Either a b
Left (FilePath
candidate, Text
err)
                  Right () -> forall a b. b -> Either a b
Right ()
      if forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [()]
passed
        then forall a b. a -> Either a b
Left (r
r, [(FilePath, Text)]
failed)
        else forall a b. b -> Either a b
Right (forall a. a -> Maybe a
Just r
r)

checkRoutePrism :: (Eq r, Show r) => (a -> Prism_ FilePath r) -> a -> r -> FilePath -> Either Text ()
checkRoutePrism :: forall r a.
(Eq r, Show r) =>
(a -> Prism_ FilePath r) -> a -> r -> FilePath -> Either Text ()
checkRoutePrism a -> Prism_ FilePath r
p a
a r
r FilePath
s =
  let (Bool
valid, [Text]
checkLog) =
        forall w a. Writer w a -> (a, w)
runWriter forall a b. (a -> b) -> a -> b
$ forall ctx a.
(Eq a, Show a) =>
(ctx -> Prism_ FilePath a)
-> ctx -> a -> FilePath -> Writer [Text] Bool
routePrismIsLawfulFor a -> Prism_ FilePath r
p a
a r
r FilePath
s
   in if Bool
valid
        then forall a b. b -> Either a b
Right ()
        else forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Unlawful route prism for route value '" forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show r
r forall a. Semigroup a => a -> a -> a
<> Text
"'\n- " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"\n- " [Text]
checkLog

{- | Check if the route @Prism_@ is lawful.

  A route @Prism_@ is lawful if its conversions both the ways form an
  isomorphism for a given value.

  Returns a Writer reporting logs.
-}
routePrismIsLawfulFor ::
  forall ctx a.
  (Eq a, Show a) =>
  (ctx -> Prism_ FilePath a) ->
  ctx ->
  a ->
  FilePath ->
  Writer [Text] Bool
routePrismIsLawfulFor :: forall ctx a.
(Eq a, Show a) =>
(ctx -> Prism_ FilePath a)
-> ctx -> a -> FilePath -> Writer [Text] Bool
routePrismIsLawfulFor ctx -> Prism_ FilePath a
enc =
  forall s a.
(Eq a, Eq s, Show a, ToText s) =>
Prism' s a -> a -> s -> Writer [Text] Bool
prismIsLawfulFor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. Prism_ s a -> Prism' s a
fromPrism_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. ctx -> Prism_ FilePath a
enc

prismIsLawfulFor ::
  forall s a.
  (Eq a, Eq s, Show a, ToText s) =>
  Prism' s a ->
  a ->
  s ->
  Writer [Text] Bool
prismIsLawfulFor :: forall s a.
(Eq a, Eq s, Show a, ToText s) =>
Prism' s a -> a -> s -> Writer [Text] Bool
prismIsLawfulFor Prism' s a
p a
a s
s = do
  -- TODO: The logging here could be improved.
  -- log $ "Testing Partial ISO law for " <> show a <> " and " <> toText s
  let s
s' :: s = forall k (is :: IxList) t b.
Is k A_Review =>
Optic' k is t b -> b -> t
review Prism' s a
p a
a
  -- log $ "Prism actual encoding: " <> toText s'
  let Maybe a
ma' :: Maybe a = forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview Prism' s a
p s
s'
  -- log $ "Decoding of that encoding: " <> show ma'
  forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (s
s forall a. Eq a => a -> a -> Bool
== s
s') forall a b. (a -> b) -> a -> b
$
    OneItem [Text] -> WriterT [Text] Identity ()
log forall a b. (a -> b) -> a -> b
$
      forall a. ToText a => a -> Text
toText s
s forall a. Semigroup a => a -> a -> a
<> Text
" /= " forall a. Semigroup a => a -> a -> a
<> forall a. ToText a => a -> Text
toText s
s' forall a. Semigroup a => a -> a -> a
<> Text
" (encoding of '" forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show a
a forall a. Semigroup a => a -> a -> a
<> Text
"')"
  forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (forall a. a -> Maybe a
Just a
a forall a. Eq a => a -> a -> Bool
== Maybe a
ma') forall a b. (a -> b) -> a -> b
$
    OneItem [Text] -> WriterT [Text] Identity ()
log forall a b. (a -> b) -> a -> b
$
      forall b a. (Show a, IsString b) => a -> b
show (forall a. a -> Maybe a
Just a
a) forall a. Semigroup a => a -> a -> a
<> Text
" /= " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show Maybe a
ma' forall a. Semigroup a => a -> a -> a
<> Text
" (decoding of " forall a. Semigroup a => a -> a -> a
<> forall a. ToText a => a -> Text
toText s
s forall a. Semigroup a => a -> a -> a
<> Text
")"
  forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (s
s forall a. Eq a => a -> a -> Bool
== s
s') Bool -> Bool -> Bool
&& (forall a. a -> Maybe a
Just a
a forall a. Eq a => a -> a -> Bool
== Maybe a
ma')
  where
    log :: OneItem [Text] -> WriterT [Text] Identity ()
log = forall w (m :: Type -> Type). MonadWriter w m => w -> m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x. One x => OneItem x -> x
one