TreeApi.hs

{-| 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 (Eq, Show, Functor)

-- | Capture case alternative
data CaptureCase a = CaptureCase
  { name :: Text
  , api :: TreeApi a
  }
  deriving (Eq, Show, Functor)

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

    onStaticPath captures pathQuery staticPath subApi = do
      rest <- checkPrefix staticPath pathQuery
      go captures rest subApi

    onCapturePath captures pathQuery names subApi = do
      (nextCaptures, nextPath) <- accumCapture captures names pathQuery
      go nextCaptures nextPath subApi

    onSwitch captures headPath tailPath alternatives mCapture =
      case Map.lookup headPath alternatives of
        Just subApi -> go captures tailPath subApi
        Nothing -> do
          captureCase <- mCapture
          go (Map.insert captureCase.name headPath captures) tailPath captureCase.api

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

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

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

-- | Converts api to tree normal form
toTreeApi :: Api a -> TreeApi a
toTreeApi =
  joinPaths . \case
    Empty -> SwitchApi Nothing mempty Nothing
    WithPath path subApi -> case fromPathPrefix path of
      Nothing -> toTreeApi subApi
      Just prefix -> case prefix of
        StaticPrefix ps rest -> WithStaticPath ps (toTreeApi $ WithPath rest subApi)
        CapturePrefix ps rest -> WithCapturePath ps (toTreeApi $ WithPath rest subApi)
    HandleRoute a -> SwitchApi (Just a) mempty Nothing
    Append a b -> fromAlts $ orderAppends (collectAppends a <> collectAppends b)

joinPaths :: TreeApi a -> TreeApi a
joinPaths = \case
  SwitchApi mRoute alts mCapture -> SwitchApi mRoute (fmap joinPaths alts) (fmap joinCapturePaths mCapture)
  WithStaticPath pathA (WithStaticPath pathB subApi) -> joinPaths (WithStaticPath (pathA ++ pathB) subApi)
  WithCapturePath namesA (WithCapturePath namesB subApi) -> joinPaths (WithCapturePath (namesA ++ namesB) subApi)
  WithStaticPath path subApi -> WithStaticPath path (joinPaths subApi)
  WithCapturePath names subApi -> WithCapturePath names (joinPaths subApi)
  where
    joinCapturePaths x = x{api = joinPaths x.api}

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

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

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

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

    toCapture = \case
      CaptureAppend name api -> Just (name, api)
      _ -> Nothing

    toRoute = \case
      RouteAppend route -> Just route
      _ -> Nothing

fromAlts :: Alts a -> TreeApi a
fromAlts alts =
  case getStaticSingleton of
    Just (path, subApi) -> WithStaticPath [path] (toTreeApi subApi)
    Nothing ->
      case getCaptureSingleton of
        Just (names, subApi) -> WithCapturePath [names] (toTreeApi subApi)
        Nothing -> SwitchApi alts.route (fmap toTreeApi $ Map.fromList alts.appends) (fmap toCaptureCase alts.capture)
  where
    toCaptureCase (name, api) = CaptureCase name (toTreeApi api)

    getStaticSingleton =
      case alts.appends of
        [(path, subApi)] | isNothing alts.route && isNothing alts.capture -> Just (path, subApi)
        _ -> Nothing

    getCaptureSingleton =
      case alts.capture of
        Just (name, subApi) | isNothing alts.route && null alts.appends -> Just (name, subApi)
        _ -> Nothing

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

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

    accumCaptures res rest =
      case rest of
        CapturePath item : nextRest -> accumCaptures (item : res) nextRest
        _ -> CapturePrefix (List.reverse res) (Path rest)