{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Web.Routing.Combinators where

import Data.HVect
import Data.String
import Data.Typeable (Typeable)
import Web.HttpApiData
import qualified Data.Text as T

import Web.Routing.SafeRouting

data PathState = Open | Closed

data Path (as :: [*]) (pathState :: PathState) where
  Empty :: Path '[] 'Open
  StaticCons :: T.Text -> Path as ps -> Path as ps
  VarCons :: (FromHttpApiData a, Typeable a) => Path as ps -> Path (a ': as) ps
  Wildcard :: Path as 'Open -> Path (T.Text ': as) 'Closed

toInternalPath :: Path as pathState -> PathInternal as
toInternalPath :: Path as pathState -> PathInternal as
toInternalPath Path as pathState
Empty = PathInternal as
PathInternal '[]
PI_Empty
toInternalPath (StaticCons Text
t Path as pathState
p) = Text -> PathInternal as -> PathInternal as
forall (as :: [*]). Text -> PathInternal as -> PathInternal as
PI_StaticCons Text
t (Path as pathState -> PathInternal as
forall (as :: [*]) (pathState :: PathState).
Path as pathState -> PathInternal as
toInternalPath Path as pathState
p)
toInternalPath (VarCons Path as pathState
p) = PathInternal as -> PathInternal (a : as)
forall a (as :: [*]).
(FromHttpApiData a, Typeable a) =>
PathInternal as -> PathInternal (a : as)
PI_VarCons (Path as pathState -> PathInternal as
forall (as :: [*]) (pathState :: PathState).
Path as pathState -> PathInternal as
toInternalPath Path as pathState
p)
toInternalPath (Wildcard Path as 'Open
p) = PathInternal as -> PathInternal (Text : as)
forall (as :: [*]). PathInternal as -> PathInternal (Text : as)
PI_Wildcard (Path as 'Open -> PathInternal as
forall (as :: [*]) (pathState :: PathState).
Path as pathState -> PathInternal as
toInternalPath Path as 'Open
p)

type Var a = Path (a ': '[]) 'Open

-- | A route parameter
var :: (Typeable a, FromHttpApiData a) => Path (a ': '[]) 'Open
var :: Path '[a] 'Open
var = Path '[] 'Open -> Path '[a] 'Open
forall a (as :: [*]) (ps :: PathState).
(FromHttpApiData a, Typeable a) =>
Path as ps -> Path (a : as) ps
VarCons Path '[] 'Open
Empty

-- | A static route piece
static :: String -> Path '[] 'Open
static :: String -> Path '[] 'Open
static String
s =
  let pieces :: [Text]
pieces = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn Text
"/" (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
s
  in (Text -> Path '[] 'Open -> Path '[] 'Open)
-> Path '[] 'Open -> [Text] -> Path '[] 'Open
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Text -> Path '[] 'Open -> Path '[] 'Open
forall (as :: [*]) (ps :: PathState).
Text -> Path as ps -> Path as ps
StaticCons Path '[] 'Open
Empty [Text]
pieces

instance (a ~ '[], pathState ~ 'Open) => IsString (Path a pathState) where
    fromString :: String -> Path a pathState
fromString = String -> Path a pathState
String -> Path '[] 'Open
static

-- | The root of a path piece. Use to define a handler for "/"
root :: Path '[] 'Open
root :: Path '[] 'Open
root = Path '[] 'Open
Empty

-- | Matches the rest of the route. Should be the last part of the path.
wildcard :: Path '[T.Text] 'Closed
wildcard :: Path '[Text] 'Closed
wildcard = Path '[] 'Open -> Path '[Text] 'Closed
forall (as :: [*]). Path as 'Open -> Path (Text : as) 'Closed
Wildcard Path '[] 'Open
Empty

(</>) :: Path as 'Open -> Path bs ps2 -> Path (Append as bs) ps2
</> :: Path as 'Open -> Path bs ps2 -> Path (Append as bs) ps2
(</>) Path as 'Open
Empty Path bs ps2
xs = Path bs ps2
Path (Append as bs) ps2
xs
(</>) (StaticCons Text
pathPiece Path as 'Open
xs) Path bs ps2
ys = Text -> Path (Append as bs) ps2 -> Path (Append as bs) ps2
forall (as :: [*]) (ps :: PathState).
Text -> Path as ps -> Path as ps
StaticCons Text
pathPiece (Path as 'Open
xs Path as 'Open -> Path bs ps2 -> Path (Append as bs) ps2
forall (as :: [*]) (bs :: [*]) (ps2 :: PathState).
Path as 'Open -> Path bs ps2 -> Path (Append as bs) ps2
</> Path bs ps2
ys)
(</>) (VarCons Path as 'Open
xs) Path bs ps2
ys = Path (Append as bs) ps2 -> Path (a : Append as bs) ps2
forall a (as :: [*]) (ps :: PathState).
(FromHttpApiData a, Typeable a) =>
Path as ps -> Path (a : as) ps
VarCons (Path as 'Open
xs Path as 'Open -> Path bs ps2 -> Path (Append as bs) ps2
forall (as :: [*]) (bs :: [*]) (ps2 :: PathState).
Path as 'Open -> Path bs ps2 -> Path (Append as bs) ps2
</> Path bs ps2
ys)

pathToRep :: Path as ps -> Rep as
pathToRep :: Path as ps -> Rep as
pathToRep Path as ps
Empty = Rep as
Rep '[]
RNil
pathToRep (StaticCons Text
_ Path as ps
p) = Path as ps -> Rep as
forall (as :: [*]) (ps :: PathState). Path as ps -> Rep as
pathToRep Path as ps
p
pathToRep (VarCons Path as ps
p) = Rep as -> Rep (a : as)
forall (ts1 :: [*]) t. Rep ts1 -> Rep (t : ts1)
RCons (Path as ps -> Rep as
forall (as :: [*]) (ps :: PathState). Path as ps -> Rep as
pathToRep Path as ps
p)
pathToRep (Wildcard Path as 'Open
p) = Rep as -> Rep (Text : as)
forall (ts1 :: [*]) t. Rep ts1 -> Rep (t : ts1)
RCons (Path as 'Open -> Rep as
forall (as :: [*]) (ps :: PathState). Path as ps -> Rep as
pathToRep Path as 'Open
p)

renderRoute :: AllHave ToHttpApiData as => Path as 'Open -> HVect as -> T.Text
renderRoute :: Path as 'Open -> HVect as -> Text
renderRoute Path as 'Open
p = [Text] -> Text
combineRoutePieces ([Text] -> Text) -> (HVect as -> [Text]) -> HVect as -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path as 'Open -> HVect as -> [Text]
forall (as :: [*]).
AllHave ToHttpApiData as =>
Path as 'Open -> HVect as -> [Text]
renderRoute' Path as 'Open
p

renderRoute' :: AllHave ToHttpApiData as => Path as 'Open -> HVect as -> [T.Text]
renderRoute' :: Path as 'Open -> HVect as -> [Text]
renderRoute' Path as 'Open
Empty HVect as
_ = []
renderRoute' (StaticCons Text
pathPiece Path as 'Open
pathXs) HVect as
paramXs =
    ( Text
pathPiece Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Path as 'Open -> HVect as -> [Text]
forall (as :: [*]).
AllHave ToHttpApiData as =>
Path as 'Open -> HVect as -> [Text]
renderRoute' Path as 'Open
pathXs HVect as
paramXs )
renderRoute' (VarCons Path as 'Open
pathXs) (t
val :&: HVect ts1
paramXs) =
    ( t -> Text
forall a. ToHttpApiData a => a -> Text
toUrlPiece t
val Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Path as 'Open -> HVect as -> [Text]
forall (as :: [*]).
AllHave ToHttpApiData as =>
Path as 'Open -> HVect as -> [Text]
renderRoute' Path as 'Open
pathXs HVect as
HVect ts1
paramXs)
#if __GLASGOW_HASKELL__ < 800
renderRoute' _ _ =
    error "This will never happen."
#endif