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 :: (a -> Prism_ FilePath r) -> a -> r -> Either Text ()
checkRoutePrismGivenRoute a -> Prism_ FilePath r
enc a
a r
r =
  let s :: FilePath
s = Optic' A_Prism NoIx FilePath r -> r -> FilePath
forall (k :: OpticKind) (is :: IxList) (t :: OpticKind)
       (b :: OpticKind).
Is k A_Review =>
Optic' k is t b -> b -> t
review (Prism_ FilePath r -> Optic' A_Prism NoIx FilePath r
forall (s :: OpticKind) (a :: OpticKind). Prism_ s a -> Prism' s a
fromPrism_ (Prism_ FilePath r -> Optic' A_Prism NoIx FilePath r)
-> Prism_ FilePath r -> Optic' A_Prism NoIx FilePath r
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ a -> Prism_ FilePath r
enc a
a) r
r
   in (a -> Prism_ FilePath r) -> a -> r -> FilePath -> Either Text ()
forall (r :: OpticKind) (a :: OpticKind).
(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 :: (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 FilePath -> FilePath -> FilePath
forall (a :: OpticKind). Semigroup a => a -> a -> a
<> FilePath
".html", FilePath
s FilePath -> FilePath -> FilePath
</> FilePath
"index.html"]
      rp :: Prism' FilePath r
rp = Prism_ FilePath r -> Prism' FilePath r
forall (s :: OpticKind) (a :: OpticKind). Prism_ s a -> Prism' s a
fromPrism_ (Prism_ FilePath r -> Prism' FilePath r)
-> Prism_ FilePath r -> Prism' FilePath r
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ a -> Prism_ FilePath r
enc a
a
  case [Maybe r] -> Maybe r
forall (t :: OpticKind -> OpticKind) (f :: OpticKind -> OpticKind)
       (a :: OpticKind).
(Foldable t, Alternative f) =>
t (f a) -> f a
asum (Prism' FilePath r -> FilePath -> Maybe r
forall (k :: OpticKind) (is :: IxList) (s :: OpticKind)
       (a :: OpticKind).
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview Prism' FilePath r
rp (FilePath -> Maybe r) -> [FilePath] -> [Maybe r]
forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Functor f =>
(a -> b) -> f a -> f b
<$> [FilePath]
candidates) of
    Maybe r
Nothing -> Maybe r -> Either (r, [(FilePath, Text)]) (Maybe r)
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure Maybe r
forall (a :: OpticKind). 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) =
            [Either (FilePath, Text) ()] -> ([(FilePath, Text)], [()])
forall (a :: OpticKind) (b :: OpticKind).
[Either a b] -> ([a], [b])
partitionEithers ([Either (FilePath, Text) ()] -> ([(FilePath, Text)], [()]))
-> [Either (FilePath, Text) ()] -> ([(FilePath, Text)], [()])
forall (a :: OpticKind) b. (a -> b) -> a -> b
$
              [FilePath]
candidates [FilePath]
-> (FilePath -> Either (FilePath, Text) ())
-> [Either (FilePath, Text) ()]
forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Functor f =>
f a -> (a -> b) -> f b
<&> \FilePath
candidate ->
                case (a -> Prism_ FilePath r) -> a -> r -> FilePath -> Either Text ()
forall (r :: OpticKind) (a :: OpticKind).
(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 -> (FilePath, Text) -> Either (FilePath, Text) ()
forall (a :: OpticKind) (b :: OpticKind). a -> Either a b
Left (FilePath
candidate, Text
err)
                  Right () -> () -> Either (FilePath, Text) ()
forall (a :: OpticKind) (b :: OpticKind). b -> Either a b
Right ()
      if [()] -> Bool
forall (t :: OpticKind -> OpticKind) (a :: OpticKind).
Foldable t =>
t a -> Bool
null [()]
passed
        then (r, [(FilePath, Text)]) -> Either (r, [(FilePath, Text)]) (Maybe r)
forall (a :: OpticKind) (b :: OpticKind). a -> Either a b
Left (r
r, [(FilePath, Text)]
failed)
        else Maybe r -> Either (r, [(FilePath, Text)]) (Maybe r)
forall (a :: OpticKind) (b :: OpticKind). b -> Either a b
Right (r -> Maybe r
forall (a :: OpticKind). a -> Maybe a
Just r
r)

checkRoutePrism :: (Eq r, Show r) => (a -> Prism_ FilePath r) -> a -> r -> FilePath -> Either Text ()
checkRoutePrism :: (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) =
        Writer [Text] Bool -> (Bool, [Text])
forall (w :: OpticKind) (a :: OpticKind). Writer w a -> (a, w)
runWriter (Writer [Text] Bool -> (Bool, [Text]))
-> Writer [Text] Bool -> (Bool, [Text])
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ (a -> Prism_ FilePath r)
-> a -> r -> FilePath -> Writer [Text] Bool
forall (ctx :: OpticKind) (a :: OpticKind).
(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 () -> Either Text ()
forall (a :: OpticKind) (b :: OpticKind). b -> Either a b
Right ()
        else Text -> Either Text ()
forall (a :: OpticKind) (b :: OpticKind). a -> Either a b
Left (Text -> Either Text ()) -> Text -> Either Text ()
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Text
"Unlawful route prism for route value '" Text -> Text -> Text
forall (a :: OpticKind). Semigroup a => a -> a -> a
<> r -> Text
forall (b :: OpticKind) (a :: OpticKind).
(Show a, IsString b) =>
a -> b
show r
r Text -> Text -> Text
forall (a :: OpticKind). Semigroup a => a -> a -> a
<> Text
"'\n- " Text -> Text -> Text
forall (a :: OpticKind). 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 :: (ctx -> Prism_ FilePath a)
-> ctx -> a -> FilePath -> Writer [Text] Bool
routePrismIsLawfulFor ctx -> Prism_ FilePath a
enc =
  Prism' FilePath a -> a -> FilePath -> Writer [Text] Bool
forall (s :: OpticKind) (a :: OpticKind).
(Eq a, Eq s, Show a, ToText s) =>
Prism' s a -> a -> s -> Writer [Text] Bool
prismIsLawfulFor (Prism' FilePath a -> a -> FilePath -> Writer [Text] Bool)
-> (ctx -> Prism' FilePath a)
-> ctx
-> a
-> FilePath
-> Writer [Text] Bool
forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. Prism_ FilePath a -> Prism' FilePath a
forall (s :: OpticKind) (a :: OpticKind). Prism_ s a -> Prism' s a
fromPrism_ (Prism_ FilePath a -> Prism' FilePath a)
-> (ctx -> Prism_ FilePath a) -> ctx -> Prism' FilePath a
forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(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 :: 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 = Prism' s a -> a -> s
forall (k :: OpticKind) (is :: IxList) (t :: OpticKind)
       (b :: OpticKind).
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 = Prism' s a -> s -> Maybe a
forall (k :: OpticKind) (is :: IxList) (s :: OpticKind)
       (a :: OpticKind).
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'
  Bool -> WriterT [Text] Identity () -> WriterT [Text] Identity ()
forall (f :: OpticKind -> OpticKind).
Applicative f =>
Bool -> f () -> f ()
unless (s
s s -> s -> Bool
forall (a :: OpticKind). Eq a => a -> a -> Bool
== s
s') (WriterT [Text] Identity () -> WriterT [Text] Identity ())
-> WriterT [Text] Identity () -> WriterT [Text] Identity ()
forall (a :: OpticKind) b. (a -> b) -> a -> b
$
    OneItem [Text] -> WriterT [Text] Identity ()
log (OneItem [Text] -> WriterT [Text] Identity ())
-> OneItem [Text] -> WriterT [Text] Identity ()
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ s -> Text
forall (a :: OpticKind). ToText a => a -> Text
toText s
s Text -> Text -> Text
forall (a :: OpticKind). Semigroup a => a -> a -> a
<> Text
" /= " Text -> Text -> Text
forall (a :: OpticKind). Semigroup a => a -> a -> a
<> s -> Text
forall (a :: OpticKind). ToText a => a -> Text
toText s
s' Text -> Text -> Text
forall (a :: OpticKind). Semigroup a => a -> a -> a
<> Text
" (encoding of '" Text -> Text -> Text
forall (a :: OpticKind). Semigroup a => a -> a -> a
<> a -> Text
forall (b :: OpticKind) (a :: OpticKind).
(Show a, IsString b) =>
a -> b
show a
a Text -> Text -> Text
forall (a :: OpticKind). Semigroup a => a -> a -> a
<> Text
"')"
  Bool -> WriterT [Text] Identity () -> WriterT [Text] Identity ()
forall (f :: OpticKind -> OpticKind).
Applicative f =>
Bool -> f () -> f ()
unless (a -> Maybe a
forall (a :: OpticKind). a -> Maybe a
Just a
a Maybe a -> Maybe a -> Bool
forall (a :: OpticKind). Eq a => a -> a -> Bool
== Maybe a
ma') (WriterT [Text] Identity () -> WriterT [Text] Identity ())
-> WriterT [Text] Identity () -> WriterT [Text] Identity ()
forall (a :: OpticKind) b. (a -> b) -> a -> b
$
    OneItem [Text] -> WriterT [Text] Identity ()
log (OneItem [Text] -> WriterT [Text] Identity ())
-> OneItem [Text] -> WriterT [Text] Identity ()
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Maybe a -> Text
forall (b :: OpticKind) (a :: OpticKind).
(Show a, IsString b) =>
a -> b
show (a -> Maybe a
forall (a :: OpticKind). a -> Maybe a
Just a
a) Text -> Text -> Text
forall (a :: OpticKind). Semigroup a => a -> a -> a
<> Text
" /= " Text -> Text -> Text
forall (a :: OpticKind). Semigroup a => a -> a -> a
<> Maybe a -> Text
forall (b :: OpticKind) (a :: OpticKind).
(Show a, IsString b) =>
a -> b
show Maybe a
ma' Text -> Text -> Text
forall (a :: OpticKind). Semigroup a => a -> a -> a
<> Text
" (decoding of " Text -> Text -> Text
forall (a :: OpticKind). Semigroup a => a -> a -> a
<> s -> Text
forall (a :: OpticKind). ToText a => a -> Text
toText s
s Text -> Text -> Text
forall (a :: OpticKind). Semigroup a => a -> a -> a
<> Text
")"
  Bool -> Writer [Text] Bool
forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure (Bool -> Writer [Text] Bool) -> Bool -> Writer [Text] Bool
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ (s
s s -> s -> Bool
forall (a :: OpticKind). Eq a => a -> a -> Bool
== s
s') Bool -> Bool -> Bool
&& (a -> Maybe a
forall (a :: OpticKind). a -> Maybe a
Just a
a Maybe a -> Maybe a -> Bool
forall (a :: OpticKind). Eq a => a -> a -> Bool
== Maybe a
ma')
  where
    log :: OneItem [Text] -> WriterT [Text] Identity ()
log = [Text] -> WriterT [Text] Identity ()
forall (w :: OpticKind) (m :: OpticKind -> OpticKind).
MonadWriter w m =>
w -> m ()
tell ([Text] -> WriterT [Text] Identity ())
-> (OneItem [Text] -> [Text])
-> OneItem [Text]
-> WriterT [Text] Identity ()
forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. OneItem [Text] -> [Text]
forall (x :: OpticKind). One x => OneItem x -> x
one