{-| Normal form where on handler search API is
traversed in tree like facion without retraversal of the paths.
-}
module Mig.Core.Api.NormalForm.TreeApi (
  TreeApi (..),
  CaptureCase (..),
  getPath,
  toTreeApi,
) where

import Data.List qualified as List
import Data.List.Extra qualified as List
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (isNothing, mapMaybe)
import Data.Text (Text)
import Data.Text qualified as Text

import Mig.Core.Api (Api (..), Path (..), PathItem (..))

type CaptureMap = Map Text Text

{-| This form of API encodes path switch points as Map's so
it does not retraverse the routes and can find the right
branch on switch. In the plain api it tries the routes one by one
until it finds the right one.
-}
data TreeApi a
  = WithStaticPath [Text] (TreeApi a)
  | WithCapturePath [Text] (TreeApi a)
  | SwitchApi (Maybe a) (Map Text (TreeApi a)) (Maybe (CaptureCase a))
  deriving (TreeApi a -> TreeApi a -> Bool
forall a. Eq a => TreeApi a -> TreeApi a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TreeApi a -> TreeApi a -> Bool
$c/= :: forall a. Eq a => TreeApi a -> TreeApi a -> Bool
== :: TreeApi a -> TreeApi a -> Bool
$c== :: forall a. Eq a => TreeApi a -> TreeApi a -> Bool
Eq, Int -> TreeApi a -> ShowS
forall a. Show a => Int -> TreeApi a -> ShowS
forall a. Show a => [TreeApi a] -> ShowS
forall a. Show a => TreeApi a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TreeApi a] -> ShowS
$cshowList :: forall a. Show a => [TreeApi a] -> ShowS
show :: TreeApi a -> String
$cshow :: forall a. Show a => TreeApi a -> String
showsPrec :: Int -> TreeApi a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> TreeApi a -> ShowS
Show, forall a b. a -> TreeApi b -> TreeApi a
forall a b. (a -> b) -> TreeApi a -> TreeApi 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 -> TreeApi b -> TreeApi a
$c<$ :: forall a b. a -> TreeApi b -> TreeApi a
fmap :: forall a b. (a -> b) -> TreeApi a -> TreeApi b
$cfmap :: forall a b. (a -> b) -> TreeApi a -> TreeApi b
Functor)

-- | Capture case alternative
data CaptureCase a = CaptureCase
  { forall a. CaptureCase a -> Text
name :: Text
  , forall a. CaptureCase a -> TreeApi a
api :: TreeApi a
  }
  deriving (CaptureCase a -> CaptureCase a -> Bool
forall a. Eq a => CaptureCase a -> CaptureCase a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CaptureCase a -> CaptureCase a -> Bool
$c/= :: forall a. Eq a => CaptureCase a -> CaptureCase a -> Bool
== :: CaptureCase a -> CaptureCase a -> Bool
$c== :: forall a. Eq a => CaptureCase a -> CaptureCase a -> Bool
Eq, Int -> CaptureCase a -> ShowS
forall a. Show a => Int -> CaptureCase a -> ShowS
forall a. Show a => [CaptureCase a] -> ShowS
forall a. Show a => CaptureCase a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CaptureCase a] -> ShowS
$cshowList :: forall a. Show a => [CaptureCase a] -> ShowS
show :: CaptureCase a -> String
$cshow :: forall a. Show a => CaptureCase a -> String
showsPrec :: Int -> CaptureCase a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> CaptureCase a -> ShowS
Show, forall a b. a -> CaptureCase b -> CaptureCase a
forall a b. (a -> b) -> CaptureCase a -> CaptureCase 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 -> CaptureCase b -> CaptureCase a
$c<$ :: forall a b. a -> CaptureCase b -> CaptureCase a
fmap :: forall a b. (a -> b) -> CaptureCase a -> CaptureCase b
$cfmap :: forall a b. (a -> b) -> CaptureCase a -> CaptureCase b
Functor)

-- | Get a route by path, also extracts capture map
getPath :: [Text] -> TreeApi a -> Maybe (a, CaptureMap)
getPath :: forall a. [Text] -> TreeApi a -> Maybe (a, CaptureMap)
getPath [Text]
mainPath = forall a.
CaptureMap -> [Text] -> TreeApi a -> Maybe (a, CaptureMap)
go forall a. Monoid a => a
mempty (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null) [Text]
mainPath)
  where
    go :: CaptureMap -> [Text] -> TreeApi a -> Maybe (a, CaptureMap)
    go :: forall a.
CaptureMap -> [Text] -> TreeApi a -> Maybe (a, CaptureMap)
go !CaptureMap
captures ![Text]
path !TreeApi a
api =
      case [Text]
path of
        [] ->
          case TreeApi a
api of
            SwitchApi (Just a
result) Map Text (TreeApi a)
_ Maybe (CaptureCase a)
_ -> forall a. a -> Maybe a
Just (a
result, CaptureMap
captures)
            TreeApi a
_ -> forall a. Maybe a
Nothing
        Text
headPath : [Text]
tailPath ->
          case TreeApi a
api of
            WithStaticPath [Text]
static TreeApi a
subApi -> forall {a}.
CaptureMap
-> [Text] -> [Text] -> TreeApi a -> Maybe (a, CaptureMap)
onStaticPath CaptureMap
captures (Text
headPath forall a. a -> [a] -> [a]
: [Text]
tailPath) [Text]
static TreeApi a
subApi
            WithCapturePath [Text]
names TreeApi a
subApi -> forall {a}.
CaptureMap
-> [Text] -> [Text] -> TreeApi a -> Maybe (a, CaptureMap)
onCapturePath CaptureMap
captures (Text
headPath forall a. a -> [a] -> [a]
: [Text]
tailPath) [Text]
names TreeApi a
subApi
            SwitchApi Maybe a
_ Map Text (TreeApi a)
alternatives Maybe (CaptureCase a)
mCapture -> forall {r} {a}.
(HasField "name" r Text, HasField "api" r (TreeApi a)) =>
CaptureMap
-> Text
-> [Text]
-> Map Text (TreeApi a)
-> Maybe r
-> Maybe (a, CaptureMap)
onSwitch CaptureMap
captures Text
headPath [Text]
tailPath Map Text (TreeApi a)
alternatives Maybe (CaptureCase a)
mCapture

    onStaticPath :: CaptureMap
-> [Text] -> [Text] -> TreeApi a -> Maybe (a, CaptureMap)
onStaticPath CaptureMap
captures [Text]
pathQuery [Text]
staticPath TreeApi a
subApi = do
      [Text]
rest <- forall a. Eq a => [a] -> [a] -> Maybe [a]
checkPrefix [Text]
staticPath [Text]
pathQuery
      forall a.
CaptureMap -> [Text] -> TreeApi a -> Maybe (a, CaptureMap)
go CaptureMap
captures [Text]
rest TreeApi a
subApi

    onCapturePath :: CaptureMap
-> [Text] -> [Text] -> TreeApi a -> Maybe (a, CaptureMap)
onCapturePath CaptureMap
captures [Text]
pathQuery [Text]
names TreeApi a
subApi = do
      (CaptureMap
nextCaptures, [Text]
nextPath) <- CaptureMap -> [Text] -> [Text] -> Maybe (CaptureMap, [Text])
accumCapture CaptureMap
captures [Text]
names [Text]
pathQuery
      forall a.
CaptureMap -> [Text] -> TreeApi a -> Maybe (a, CaptureMap)
go CaptureMap
nextCaptures [Text]
nextPath TreeApi a
subApi

    onSwitch :: CaptureMap
-> Text
-> [Text]
-> Map Text (TreeApi a)
-> Maybe r
-> Maybe (a, CaptureMap)
onSwitch CaptureMap
captures Text
headPath [Text]
tailPath Map Text (TreeApi a)
alternatives Maybe r
mCapture =
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
headPath Map Text (TreeApi a)
alternatives of
        Just TreeApi a
subApi -> forall a.
CaptureMap -> [Text] -> TreeApi a -> Maybe (a, CaptureMap)
go CaptureMap
captures [Text]
tailPath TreeApi a
subApi
        Maybe (TreeApi a)
Nothing -> do
          r
captureCase <- Maybe r
mCapture
          forall a.
CaptureMap -> [Text] -> TreeApi a -> Maybe (a, CaptureMap)
go (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert r
captureCase.name Text
headPath CaptureMap
captures) [Text]
tailPath r
captureCase.api

checkPrefix :: (Eq a) => [a] -> [a] -> Maybe [a]
checkPrefix :: forall a. Eq a => [a] -> [a] -> Maybe [a]
checkPrefix (a
a : [a]
as) (a
b : [a]
bs)
  | a
a forall a. Eq a => a -> a -> Bool
== a
b = forall a. Eq a => [a] -> [a] -> Maybe [a]
checkPrefix [a]
as [a]
bs
  | Bool
otherwise = forall a. Maybe a
Nothing
checkPrefix [] [a]
b = forall a. a -> Maybe a
Just [a]
b
checkPrefix [a]
_ [a]
_ = forall a. Maybe a
Nothing

accumCapture :: CaptureMap -> [Text] -> [Text] -> Maybe (CaptureMap, [Text])
accumCapture :: CaptureMap -> [Text] -> [Text] -> Maybe (CaptureMap, [Text])
accumCapture !CaptureMap
captures ![Text]
names ![Text]
path =
  case [Text]
names of
    [] -> forall a. a -> Maybe a
Just (CaptureMap
captures, [Text]
path)
    Text
name : [Text]
rest ->
      case [Text]
path of
        Text
pathHead : [Text]
pathTail -> CaptureMap -> [Text] -> [Text] -> Maybe (CaptureMap, [Text])
accumCapture (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
name Text
pathHead CaptureMap
captures) [Text]
rest [Text]
pathTail
        [] -> forall a. Maybe a
Nothing

-------------------------------------------------------------------------------------

-- | Converts api to tree normal form
toTreeApi :: Api a -> TreeApi a
toTreeApi :: forall a. Api a -> TreeApi a
toTreeApi =
  forall a. TreeApi a -> TreeApi a
joinPaths forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    Api a
Empty -> forall a.
Maybe a
-> Map Text (TreeApi a) -> Maybe (CaptureCase a) -> TreeApi a
SwitchApi forall a. Maybe a
Nothing forall a. Monoid a => a
mempty forall a. Maybe a
Nothing
    WithPath Path
path Api a
subApi -> case Path -> Maybe PathPrefix
fromPathPrefix Path
path of
      Maybe PathPrefix
Nothing -> forall a. Api a -> TreeApi a
toTreeApi Api a
subApi
      Just PathPrefix
prefix -> case PathPrefix
prefix of
        StaticPrefix [Text]
ps Path
rest -> forall a. [Text] -> TreeApi a -> TreeApi a
WithStaticPath [Text]
ps (forall a. Api a -> TreeApi a
toTreeApi forall a b. (a -> b) -> a -> b
$ forall a. Path -> Api a -> Api a
WithPath Path
rest Api a
subApi)
        CapturePrefix [Text]
ps Path
rest -> forall a. [Text] -> TreeApi a -> TreeApi a
WithCapturePath [Text]
ps (forall a. Api a -> TreeApi a
toTreeApi forall a b. (a -> b) -> a -> b
$ forall a. Path -> Api a -> Api a
WithPath Path
rest Api a
subApi)
    HandleRoute a
a -> forall a.
Maybe a
-> Map Text (TreeApi a) -> Maybe (CaptureCase a) -> TreeApi a
SwitchApi (forall a. a -> Maybe a
Just a
a) forall a. Monoid a => a
mempty forall a. Maybe a
Nothing
    Append Api a
a Api a
b -> forall a. Alts a -> TreeApi a
fromAlts forall a b. (a -> b) -> a -> b
$ forall a. [AppendItem a] -> Alts a
orderAppends (forall a. Api a -> [AppendItem a]
collectAppends Api a
a forall a. Semigroup a => a -> a -> a
<> forall a. Api a -> [AppendItem a]
collectAppends Api a
b)

joinPaths :: TreeApi a -> TreeApi a
joinPaths :: forall a. TreeApi a -> TreeApi a
joinPaths = \case
  SwitchApi Maybe a
mRoute Map Text (TreeApi a)
alts Maybe (CaptureCase a)
mCapture -> forall a.
Maybe a
-> Map Text (TreeApi a) -> Maybe (CaptureCase a) -> TreeApi a
SwitchApi Maybe a
mRoute (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. TreeApi a -> TreeApi a
joinPaths Map Text (TreeApi a)
alts) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a}. CaptureCase a -> CaptureCase a
joinCapturePaths Maybe (CaptureCase a)
mCapture)
  WithStaticPath [Text]
pathA (WithStaticPath [Text]
pathB TreeApi a
subApi) -> forall a. TreeApi a -> TreeApi a
joinPaths (forall a. [Text] -> TreeApi a -> TreeApi a
WithStaticPath ([Text]
pathA forall a. [a] -> [a] -> [a]
++ [Text]
pathB) TreeApi a
subApi)
  WithCapturePath [Text]
namesA (WithCapturePath [Text]
namesB TreeApi a
subApi) -> forall a. TreeApi a -> TreeApi a
joinPaths (forall a. [Text] -> TreeApi a -> TreeApi a
WithCapturePath ([Text]
namesA forall a. [a] -> [a] -> [a]
++ [Text]
namesB) TreeApi a
subApi)
  WithStaticPath [Text]
path TreeApi a
subApi -> forall a. [Text] -> TreeApi a -> TreeApi a
WithStaticPath [Text]
path (forall a. TreeApi a -> TreeApi a
joinPaths TreeApi a
subApi)
  WithCapturePath [Text]
names TreeApi a
subApi -> forall a. [Text] -> TreeApi a -> TreeApi a
WithCapturePath [Text]
names (forall a. TreeApi a -> TreeApi a
joinPaths TreeApi a
subApi)
  where
    joinCapturePaths :: CaptureCase a -> CaptureCase a
joinCapturePaths CaptureCase a
x = CaptureCase a
x{$sel:api:CaptureCase :: TreeApi a
api = forall a. TreeApi a -> TreeApi a
joinPaths CaptureCase a
x.api}

data Alts a = Alts
  { forall a. Alts a -> [(Text, Api a)]
appends :: [(Text, Api a)]
  , forall a. Alts a -> Maybe (Text, Api a)
capture :: Maybe (Text, Api a)
  , forall a. Alts a -> Maybe a
route :: Maybe a
  }

data AppendItem a
  = StaticAppend Text (Api a)
  | RouteAppend a
  | CaptureAppend Text (Api a)

collectAppends :: Api a -> [AppendItem a]
collectAppends :: forall a. Api a -> [AppendItem a]
collectAppends = \case
  Api a
Empty -> []
  HandleRoute a
a -> [forall a. a -> AppendItem a
RouteAppend a
a]
  Append Api a
a Api a
b -> forall a. Api a -> [AppendItem a]
collectAppends Api a
a forall a. Semigroup a => a -> a -> a
<> forall a. Api a -> [AppendItem a]
collectAppends Api a
b
  WithPath (Path [PathItem]
items) Api a
subApi -> case [PathItem]
items of
    [] -> forall a. Api a -> [AppendItem a]
collectAppends Api a
subApi
    StaticPath Text
item : [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Text -> Api a -> AppendItem a
StaticAppend Text
item Api a
subApi
    StaticPath Text
item : [PathItem]
rest -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Text -> Api a -> AppendItem a
StaticAppend Text
item (forall a. Path -> Api a -> Api a
WithPath ([PathItem] -> Path
Path [PathItem]
rest) Api a
subApi)
    CapturePath Text
item : [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Text -> Api a -> AppendItem a
CaptureAppend Text
item Api a
subApi
    CapturePath Text
item : [PathItem]
rest -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Text -> Api a -> AppendItem a
CaptureAppend Text
item (forall a. Path -> Api a -> Api a
WithPath ([PathItem] -> Path
Path [PathItem]
rest) Api a
subApi)

orderAppends :: [AppendItem a] -> Alts a
orderAppends :: forall a. [AppendItem a] -> Alts a
orderAppends [AppendItem a]
items =
  Alts
    { $sel:appends:Alts :: [(Text, Api a)]
appends = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {a}. AppendItem a -> Maybe (Text, Api a)
toAppend [AppendItem a]
items
    , $sel:capture:Alts :: Maybe (Text, Api a)
capture = forall a b. (a -> Maybe b) -> [a] -> Maybe b
List.firstJust forall {a}. AppendItem a -> Maybe (Text, Api a)
toCapture [AppendItem a]
items
    , $sel:route:Alts :: Maybe a
route = forall a b. (a -> Maybe b) -> [a] -> Maybe b
List.firstJust forall {a}. AppendItem a -> Maybe a
toRoute [AppendItem a]
items
    }
  where
    toAppend :: AppendItem a -> Maybe (Text, Api a)
toAppend = \case
      StaticAppend Text
name Api a
api -> forall a. a -> Maybe a
Just (Text
name, Api a
api)
      AppendItem a
_ -> forall a. Maybe a
Nothing

    toCapture :: AppendItem a -> Maybe (Text, Api a)
toCapture = \case
      CaptureAppend Text
name Api a
api -> forall a. a -> Maybe a
Just (Text
name, Api a
api)
      AppendItem a
_ -> forall a. Maybe a
Nothing

    toRoute :: AppendItem a -> Maybe a
toRoute = \case
      RouteAppend a
route -> forall a. a -> Maybe a
Just a
route
      AppendItem a
_ -> forall a. Maybe a
Nothing

fromAlts :: Alts a -> TreeApi a
fromAlts :: forall a. Alts a -> TreeApi a
fromAlts Alts a
alts =
  case Maybe (Text, Api a)
getStaticSingleton of
    Just (Text
path, Api a
subApi) -> forall a. [Text] -> TreeApi a -> TreeApi a
WithStaticPath [Text
path] (forall a. Api a -> TreeApi a
toTreeApi Api a
subApi)
    Maybe (Text, Api a)
Nothing ->
      case Maybe (Text, Api a)
getCaptureSingleton of
        Just (Text
names, Api a
subApi) -> forall a. [Text] -> TreeApi a -> TreeApi a
WithCapturePath [Text
names] (forall a. Api a -> TreeApi a
toTreeApi Api a
subApi)
        Maybe (Text, Api a)
Nothing -> forall a.
Maybe a
-> Map Text (TreeApi a) -> Maybe (CaptureCase a) -> TreeApi a
SwitchApi Alts a
alts.route (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Api a -> TreeApi a
toTreeApi forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList Alts a
alts.appends) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a}. (Text, Api a) -> CaptureCase a
toCaptureCase Alts a
alts.capture)
  where
    toCaptureCase :: (Text, Api a) -> CaptureCase a
toCaptureCase (Text
name, Api a
api) = forall a. Text -> TreeApi a -> CaptureCase a
CaptureCase Text
name (forall a. Api a -> TreeApi a
toTreeApi Api a
api)

    getStaticSingleton :: Maybe (Text, Api a)
getStaticSingleton =
      case Alts a
alts.appends of
        [(Text
path, Api a
subApi)] | forall a. Maybe a -> Bool
isNothing Alts a
alts.route Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing Alts a
alts.capture -> forall a. a -> Maybe a
Just (Text
path, Api a
subApi)
        [(Text, Api a)]
_ -> forall a. Maybe a
Nothing

    getCaptureSingleton :: Maybe (Text, Api a)
getCaptureSingleton =
      case Alts a
alts.capture of
        Just (Text
name, Api a
subApi) | forall a. Maybe a -> Bool
isNothing Alts a
alts.route Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null Alts a
alts.appends -> forall a. a -> Maybe a
Just (Text
name, Api a
subApi)
        Maybe (Text, Api a)
_ -> forall a. Maybe a
Nothing

data PathPrefix
  = StaticPrefix [Text] Path
  | CapturePrefix [Text] Path

fromPathPrefix :: Path -> Maybe PathPrefix
fromPathPrefix :: Path -> Maybe PathPrefix
fromPathPrefix (Path [PathItem]
items) = case [PathItem]
items of
  [] -> forall a. Maybe a
Nothing
  StaticPath Text
item : [PathItem]
rest -> forall a. a -> Maybe a
Just ([Text] -> [PathItem] -> PathPrefix
accumStatics [Text
item] [PathItem]
rest)
  CapturePath Text
item : [PathItem]
rest -> forall a. a -> Maybe a
Just ([Text] -> [PathItem] -> PathPrefix
accumCaptures [Text
item] [PathItem]
rest)
  where
    accumStatics :: [Text] -> [PathItem] -> PathPrefix
accumStatics [Text]
res [PathItem]
rest =
      case [PathItem]
rest of
        StaticPath Text
item : [PathItem]
nextRest -> [Text] -> [PathItem] -> PathPrefix
accumStatics (Text
item forall a. a -> [a] -> [a]
: [Text]
res) [PathItem]
nextRest
        [PathItem]
_ -> [Text] -> Path -> PathPrefix
StaticPrefix (forall a. [a] -> [a]
List.reverse [Text]
res) ([PathItem] -> Path
Path [PathItem]
rest)

    accumCaptures :: [Text] -> [PathItem] -> PathPrefix
accumCaptures [Text]
res [PathItem]
rest =
      case [PathItem]
rest of
        CapturePath Text
item : [PathItem]
nextRest -> [Text] -> [PathItem] -> PathPrefix
accumCaptures (Text
item forall a. a -> [a] -> [a]
: [Text]
res) [PathItem]
nextRest
        [PathItem]
_ -> [Text] -> Path -> PathPrefix
CapturePrefix (forall a. [a] -> [a]
List.reverse [Text]
res) ([PathItem] -> Path
Path [PathItem]
rest)