module WebGear.Middlewares.Path
( Path
, PathVar
, PathVarError (..)
, PathEnd
, path
, pathVar
, pathEnd
, match
, route
) where
import Control.Arrow (Kleisli (..))
import Control.Monad ((>=>))
import Control.Monad.State.Strict (MonadState (..))
import Data.Foldable (toList)
import Data.Function ((&))
import Data.List.NonEmpty (NonEmpty (..), filter)
import Data.Proxy (Proxy (..))
import Data.Text (Text, pack)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Language.Haskell.TH.Quote (QuasiQuoter (..))
import Language.Haskell.TH.Syntax (Exp (..), Q, TyLit (..), Type (..), mkName)
import Prelude hiding (drop, filter, take)
import Web.HttpApiData (FromHttpApiData (..))
import WebGear.Middlewares.Method (method)
import WebGear.Trait (Result (..), Trait (..), probe)
import WebGear.Types (MonadRouter (..), PathInfo (..), Request, RequestMiddleware')
import WebGear.Util (splitOn)
import qualified Data.List as List
data Path (s :: Symbol)
instance (KnownSymbol s, MonadState PathInfo m) => Trait (Path s) Request m where
type Attribute (Path s) Request = ()
type Absence (Path s) Request = ()
toAttribute :: Request -> m (Result (Path s) Request)
toAttribute :: Request -> m (Result (Path s) Request)
toAttribute Request
_ = do
PathInfo [Text]
actualPath <- m PathInfo
forall s (m :: * -> *). MonadState s m => m s
get
case [Text] -> [Text] -> Maybe [Text]
forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix [Text]
expectedPath [Text]
actualPath of
Maybe [Text]
Nothing -> Result (Path s) Request -> m (Result (Path s) Request)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result (Path s) Request -> m (Result (Path s) Request))
-> Result (Path s) Request -> m (Result (Path s) Request)
forall a b. (a -> b) -> a -> b
$ Absence (Path s) Request -> Result (Path s) Request
forall k (t :: k) a. Absence t a -> Result t a
NotFound ()
Just [Text]
rest -> do
PathInfo -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (PathInfo -> m ()) -> PathInfo -> m ()
forall a b. (a -> b) -> a -> b
$ [Text] -> PathInfo
PathInfo [Text]
rest
Result (Path s) Request -> m (Result (Path s) Request)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result (Path s) Request -> m (Result (Path s) Request))
-> Result (Path s) Request -> m (Result (Path s) Request)
forall a b. (a -> b) -> a -> b
$ Attribute (Path s) Request -> Result (Path s) Request
forall k (t :: k) a. Attribute t a -> Result t a
Found ()
where
expectedPath :: [Text]
expectedPath = Proxy s
forall k (t :: k). Proxy t
Proxy @s
Proxy s -> (Proxy s -> String) -> String
forall a b. a -> (a -> b) -> b
& Proxy s -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal
String -> (String -> NonEmpty String) -> NonEmpty String
forall a b. a -> (a -> b) -> b
& Char -> String -> NonEmpty String
forall a. Eq a => a -> [a] -> NonEmpty [a]
splitOn Char
'/'
NonEmpty String -> (NonEmpty String -> [String]) -> [String]
forall a b. a -> (a -> b) -> b
& (String -> Bool) -> NonEmpty String -> [String]
forall a. (a -> Bool) -> NonEmpty a -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"")
[String] -> ([String] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
pack
data PathVar tag val
data PathVarError = PathVarNotFound | PathVarParseError Text
deriving (PathVarError -> PathVarError -> Bool
(PathVarError -> PathVarError -> Bool)
-> (PathVarError -> PathVarError -> Bool) -> Eq PathVarError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PathVarError -> PathVarError -> Bool
$c/= :: PathVarError -> PathVarError -> Bool
== :: PathVarError -> PathVarError -> Bool
$c== :: PathVarError -> PathVarError -> Bool
Eq, Int -> PathVarError -> ShowS
[PathVarError] -> ShowS
PathVarError -> String
(Int -> PathVarError -> ShowS)
-> (PathVarError -> String)
-> ([PathVarError] -> ShowS)
-> Show PathVarError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PathVarError] -> ShowS
$cshowList :: [PathVarError] -> ShowS
show :: PathVarError -> String
$cshow :: PathVarError -> String
showsPrec :: Int -> PathVarError -> ShowS
$cshowsPrec :: Int -> PathVarError -> ShowS
Show, ReadPrec [PathVarError]
ReadPrec PathVarError
Int -> ReadS PathVarError
ReadS [PathVarError]
(Int -> ReadS PathVarError)
-> ReadS [PathVarError]
-> ReadPrec PathVarError
-> ReadPrec [PathVarError]
-> Read PathVarError
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [PathVarError]
$creadListPrec :: ReadPrec [PathVarError]
readPrec :: ReadPrec PathVarError
$creadPrec :: ReadPrec PathVarError
readList :: ReadS [PathVarError]
$creadList :: ReadS [PathVarError]
readsPrec :: Int -> ReadS PathVarError
$creadsPrec :: Int -> ReadS PathVarError
Read)
instance (FromHttpApiData val, MonadState PathInfo m) => Trait (PathVar tag val) Request m where
type Attribute (PathVar tag val) Request = val
type Absence (PathVar tag val) Request = PathVarError
toAttribute :: Request -> m (Result (PathVar tag val) Request)
toAttribute :: Request -> m (Result (PathVar tag val) Request)
toAttribute Request
_ = do
PathInfo [Text]
actualPath <- m PathInfo
forall s (m :: * -> *). MonadState s m => m s
get
case [Text]
actualPath of
[] -> Result (PathVar tag val) Request
-> m (Result (PathVar tag val) Request)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result (PathVar tag val) Request
-> m (Result (PathVar tag val) Request))
-> Result (PathVar tag val) Request
-> m (Result (PathVar tag val) Request)
forall a b. (a -> b) -> a -> b
$ Absence (PathVar tag val) Request
-> Result (PathVar tag val) Request
forall k (t :: k) a. Absence t a -> Result t a
NotFound Absence (PathVar tag val) Request
PathVarError
PathVarNotFound
(Text
x:[Text]
xs) -> case Text -> Either Text val
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece @val Text
x of
Left Text
e -> Result (PathVar tag val) Request
-> m (Result (PathVar tag val) Request)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result (PathVar tag val) Request
-> m (Result (PathVar tag val) Request))
-> Result (PathVar tag val) Request
-> m (Result (PathVar tag val) Request)
forall a b. (a -> b) -> a -> b
$ Absence (PathVar tag val) Request
-> Result (PathVar tag val) Request
forall k (t :: k) a. Absence t a -> Result t a
NotFound (Absence (PathVar tag val) Request
-> Result (PathVar tag val) Request)
-> Absence (PathVar tag val) Request
-> Result (PathVar tag val) Request
forall a b. (a -> b) -> a -> b
$ Text -> PathVarError
PathVarParseError Text
e
Right val
v -> do
PathInfo -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (PathInfo -> m ()) -> PathInfo -> m ()
forall a b. (a -> b) -> a -> b
$ [Text] -> PathInfo
PathInfo [Text]
xs
Result (PathVar tag val) Request
-> m (Result (PathVar tag val) Request)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result (PathVar tag val) Request
-> m (Result (PathVar tag val) Request))
-> Result (PathVar tag val) Request
-> m (Result (PathVar tag val) Request)
forall a b. (a -> b) -> a -> b
$ Attribute (PathVar tag val) Request
-> Result (PathVar tag val) Request
forall k (t :: k) a. Attribute t a -> Result t a
Found val
Attribute (PathVar tag val) Request
v
data PathEnd
instance MonadState PathInfo m => Trait PathEnd Request m where
type Attribute PathEnd Request = ()
type Absence PathEnd Request = ()
toAttribute :: Request -> m (Result PathEnd Request)
toAttribute :: Request -> m (Result PathEnd Request)
toAttribute Request
_ = do
PathInfo [Text]
actualPath <- m PathInfo
forall s (m :: * -> *). MonadState s m => m s
get
Result PathEnd Request -> m (Result PathEnd Request)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result PathEnd Request -> m (Result PathEnd Request))
-> Result PathEnd Request -> m (Result PathEnd Request)
forall a b. (a -> b) -> a -> b
$ if [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
actualPath
then Attribute PathEnd Request -> Result PathEnd Request
forall k (t :: k) a. Attribute t a -> Result t a
Found ()
else Absence PathEnd Request -> Result PathEnd Request
forall k (t :: k) a. Absence t a -> Result t a
NotFound ()
path :: forall s ts m a. (KnownSymbol s, MonadRouter m)
=> RequestMiddleware' m ts (Path s:ts) a
path :: RequestMiddleware' m ts (Path s : ts) a
path Handler' m (Path s : ts) a
handler = (Linked ts Request -> m (Response a))
-> Kleisli m (Linked ts Request) (Response a)
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli ((Linked ts Request -> m (Response a))
-> Kleisli m (Linked ts Request) (Response a))
-> (Linked ts Request -> m (Response a))
-> Kleisli m (Linked ts Request) (Response a)
forall a b. (a -> b) -> a -> b
$
forall (ts :: [*]) a (m :: * -> *).
Trait (Path s) a m =>
Linked ts a
-> m (Either (Absence (Path s) a) (Linked (Path s : ts) a))
forall t (ts :: [*]) a (m :: * -> *).
Trait t a m =>
Linked ts a -> m (Either (Absence t a) (Linked (t : ts) a))
probe @(Path s) (Linked ts Request -> m (Either () (Linked (Path s : ts) Request)))
-> (Either () (Linked (Path s : ts) Request) -> m (Response a))
-> Linked ts Request
-> m (Response a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (() -> m (Response a))
-> (Linked (Path s : ts) Request -> m (Response a))
-> Either () (Linked (Path s : ts) Request)
-> m (Response a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (m (Response a) -> () -> m (Response a)
forall a b. a -> b -> a
const m (Response a)
forall (m :: * -> *) a. MonadRouter m => m a
rejectRoute) (Handler' m (Path s : ts) a
-> Linked (Path s : ts) Request -> m (Response a)
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli Handler' m (Path s : ts) a
handler)
pathVar :: forall tag val ts m a. (FromHttpApiData val, MonadRouter m)
=> RequestMiddleware' m ts (PathVar tag val:ts) a
pathVar :: RequestMiddleware' m ts (PathVar tag val : ts) a
pathVar Handler' m (PathVar tag val : ts) a
handler = (Linked ts Request -> m (Response a))
-> Kleisli m (Linked ts Request) (Response a)
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli ((Linked ts Request -> m (Response a))
-> Kleisli m (Linked ts Request) (Response a))
-> (Linked ts Request -> m (Response a))
-> Kleisli m (Linked ts Request) (Response a)
forall a b. (a -> b) -> a -> b
$
forall (ts :: [*]) a (m :: * -> *).
Trait (PathVar tag val) a m =>
Linked ts a
-> m (Either
(Absence (PathVar tag val) a) (Linked (PathVar tag val : ts) a))
forall t (ts :: [*]) a (m :: * -> *).
Trait t a m =>
Linked ts a -> m (Either (Absence t a) (Linked (t : ts) a))
probe @(PathVar tag val) (Linked ts Request
-> m (Either PathVarError (Linked (PathVar tag val : ts) Request)))
-> (Either PathVarError (Linked (PathVar tag val : ts) Request)
-> m (Response a))
-> Linked ts Request
-> m (Response a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (PathVarError -> m (Response a))
-> (Linked (PathVar tag val : ts) Request -> m (Response a))
-> Either PathVarError (Linked (PathVar tag val : ts) Request)
-> m (Response a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (m (Response a) -> PathVarError -> m (Response a)
forall a b. a -> b -> a
const m (Response a)
forall (m :: * -> *) a. MonadRouter m => m a
rejectRoute) (Handler' m (PathVar tag val : ts) a
-> Linked (PathVar tag val : ts) Request -> m (Response a)
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli Handler' m (PathVar tag val : ts) a
handler)
pathEnd :: MonadRouter m => RequestMiddleware' m ts (PathEnd:ts) a
pathEnd :: RequestMiddleware' m ts (PathEnd : ts) a
pathEnd Handler' m (PathEnd : ts) a
handler = (Linked ts Request -> m (Response a))
-> Kleisli m (Linked ts Request) (Response a)
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli ((Linked ts Request -> m (Response a))
-> Kleisli m (Linked ts Request) (Response a))
-> (Linked ts Request -> m (Response a))
-> Kleisli m (Linked ts Request) (Response a)
forall a b. (a -> b) -> a -> b
$
forall (ts :: [*]) a (m :: * -> *).
Trait PathEnd a m =>
Linked ts a
-> m (Either (Absence PathEnd a) (Linked (PathEnd : ts) a))
forall t (ts :: [*]) a (m :: * -> *).
Trait t a m =>
Linked ts a -> m (Either (Absence t a) (Linked (t : ts) a))
probe @PathEnd (Linked ts Request
-> m (Either () (Linked (PathEnd : ts) Request)))
-> (Either () (Linked (PathEnd : ts) Request) -> m (Response a))
-> Linked ts Request
-> m (Response a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (() -> m (Response a))
-> (Linked (PathEnd : ts) Request -> m (Response a))
-> Either () (Linked (PathEnd : ts) Request)
-> m (Response a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (m (Response a) -> () -> m (Response a)
forall a b. a -> b -> a
const m (Response a)
forall (m :: * -> *) a. MonadRouter m => m a
rejectRoute) (Handler' m (PathEnd : ts) a
-> Linked (PathEnd : ts) Request -> m (Response a)
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli Handler' m (PathEnd : ts) a
handler)
match :: QuasiQuoter
match :: QuasiQuoter
match = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
{ quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
toMatchExp
, quotePat :: String -> Q Pat
quotePat = Q Pat -> String -> Q Pat
forall a b. a -> b -> a
const (Q Pat -> String -> Q Pat) -> Q Pat -> String -> Q Pat
forall a b. (a -> b) -> a -> b
$ String -> Q Pat
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"match cannot be used in a pattern"
, quoteType :: String -> Q Type
quoteType = Q Type -> String -> Q Type
forall a b. a -> b -> a
const (Q Type -> String -> Q Type) -> Q Type -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"match cannot be used in a type"
, quoteDec :: String -> Q [Dec]
quoteDec = Q [Dec] -> String -> Q [Dec]
forall a b. a -> b -> a
const (Q [Dec] -> String -> Q [Dec]) -> Q [Dec] -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"match cannot be used in a declaration"
}
route :: QuasiQuoter
route :: QuasiQuoter
route = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
{ quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
toRouteExp
, quotePat :: String -> Q Pat
quotePat = Q Pat -> String -> Q Pat
forall a b. a -> b -> a
const (Q Pat -> String -> Q Pat) -> Q Pat -> String -> Q Pat
forall a b. (a -> b) -> a -> b
$ String -> Q Pat
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"route cannot be used in a pattern"
, quoteType :: String -> Q Type
quoteType = Q Type -> String -> Q Type
forall a b. a -> b -> a
const (Q Type -> String -> Q Type) -> Q Type -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"route cannot be used in a type"
, quoteDec :: String -> Q [Dec]
quoteDec = Q [Dec] -> String -> Q [Dec]
forall a b. a -> b -> a
const (Q [Dec] -> String -> Q [Dec]) -> Q [Dec] -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"route cannot be used in a declaration"
}
toRouteExp :: String -> Q Exp
toRouteExp :: String -> Q Exp
toRouteExp String
s = do
Exp
e <- String -> Q Exp
toMatchExp String
s
Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
compose Exp
e (Name -> Exp
VarE 'pathEnd)
toMatchExp :: String -> Q Exp
toMatchExp :: String -> Q Exp
toMatchExp String
s = case String -> [String]
List.words String
s of
[String
m, String
p] -> do
let methodExp :: Exp
methodExp = Exp -> Type -> Exp
AppTypeE (Name -> Exp
VarE 'method) (Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
m)
[Exp]
pathExps <- String -> Q [Exp]
toPathExps String
p
Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp -> Exp) -> NonEmpty Exp -> Exp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
List.foldr1 Exp -> Exp -> Exp
compose (NonEmpty Exp -> Exp) -> NonEmpty Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Exp
methodExp Exp -> [Exp] -> NonEmpty Exp
forall a. a -> [a] -> NonEmpty a
:| [Exp]
pathExps
[String
p] -> do
[Exp]
pathExps <- String -> Q [Exp]
toPathExps String
p
Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp -> Exp) -> [Exp] -> Exp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
List.foldr1 Exp -> Exp -> Exp
compose [Exp]
pathExps
[String]
_ -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected an HTTP method and a path or just a path"
where
toPathExps :: String -> Q [Exp]
toPathExps :: String -> Q [Exp]
toPathExps String
p = Char -> String -> NonEmpty String
forall a. Eq a => a -> [a] -> NonEmpty [a]
splitOn Char
'/' String
p
NonEmpty String -> (NonEmpty String -> [String]) -> [String]
forall a b. a -> (a -> b) -> b
& (String -> Bool) -> NonEmpty String -> [String]
forall a. (a -> Bool) -> NonEmpty a -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"")
[String] -> ([String] -> [NonEmpty String]) -> [NonEmpty String]
forall a b. a -> (a -> b) -> b
& (String -> NonEmpty String) -> [String] -> [NonEmpty String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Char -> String -> NonEmpty String
forall a. Eq a => a -> [a] -> NonEmpty [a]
splitOn Char
':')
[NonEmpty String]
-> ([NonEmpty String] -> [NonEmpty String]) -> [NonEmpty String]
forall a b. a -> (a -> b) -> b
& (NonEmpty String -> [NonEmpty String] -> [NonEmpty String])
-> [NonEmpty String] -> [NonEmpty String] -> [NonEmpty String]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
List.foldr NonEmpty String -> [NonEmpty String] -> [NonEmpty String]
joinPath []
[NonEmpty String] -> ([NonEmpty String] -> [Q Exp]) -> [Q Exp]
forall a b. a -> (a -> b) -> b
& (NonEmpty String -> Q Exp) -> [NonEmpty String] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty String -> Q Exp
toPathExp
[Q Exp] -> ([Q Exp] -> Q [Exp]) -> Q [Exp]
forall a b. a -> (a -> b) -> b
& [Q Exp] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
joinPath :: NonEmpty String -> [NonEmpty String] -> [NonEmpty String]
joinPath :: NonEmpty String -> [NonEmpty String] -> [NonEmpty String]
joinPath NonEmpty String
p [] = [NonEmpty String
p]
joinPath (String
p:|[]) ((String
p':|[]) : [NonEmpty String]
xs) = ((String
p String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
p') String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| []) NonEmpty String -> [NonEmpty String] -> [NonEmpty String]
forall a. a -> [a] -> [a]
: [NonEmpty String]
xs
joinPath NonEmpty String
y (NonEmpty String
x:[NonEmpty String]
xs) = NonEmpty String
yNonEmpty String -> [NonEmpty String] -> [NonEmpty String]
forall a. a -> [a] -> [a]
:NonEmpty String
xNonEmpty String -> [NonEmpty String] -> [NonEmpty String]
forall a. a -> [a] -> [a]
:[NonEmpty String]
xs
toPathExp :: NonEmpty String -> Q Exp
toPathExp :: NonEmpty String -> Q Exp
toPathExp (String
p :| []) = Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Type -> Exp
AppTypeE (Name -> Exp
VarE 'path) (TyLit -> Type
LitT (TyLit -> Type) -> TyLit -> Type
forall a b. (a -> b) -> a -> b
$ String -> TyLit
StrTyLit String
p)
toPathExp (String
v :| [String
t]) = Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Type -> Exp
AppTypeE (Exp -> Type -> Exp
AppTypeE (Name -> Exp
VarE 'pathVar) (TyLit -> Type
LitT (TyLit -> Type) -> TyLit -> Type
forall a b. (a -> b) -> a -> b
$ String -> TyLit
StrTyLit String
v)) (Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
t)
toPathExp NonEmpty String
xs = String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"Invalid path component: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
":" (NonEmpty String -> [String]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty String
xs)
compose :: Exp -> Exp -> Exp
compose :: Exp -> Exp -> Exp
compose Exp
l = Exp -> Exp -> Exp -> Exp
UInfixE Exp
l (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
".")