{-# LANGUAGE CPP, TemplateHaskell #-}
module Web.Routes.TH
( derivePathInfo
, derivePathInfo'
, standard
, mkRoute
) where
import Control.Applicative ((<$>))
import Control.Monad (ap, replicateM)
import Data.Char (isUpper, toLower, toUpper)
import Data.List (intercalate, foldl')
import Data.List.Split (split, dropInitBlank, keepDelimsL, whenElt)
import Data.Text (pack, unpack)
import Data.Typeable (typeOf)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (nameBase)
import Text.ParserCombinators.Parsec ((<|>),many1)
import Web.Routes.PathInfo
derivePathInfo :: Name
-> Q [Dec]
derivePathInfo :: Name -> Q [Dec]
derivePathInfo = ([Char] -> [Char]) -> Name -> Q [Dec]
derivePathInfo' [Char] -> [Char]
standard
derivePathInfo' :: (String -> String)
-> Name
-> Q [Dec]
derivePathInfo' :: ([Char] -> [Char]) -> Name -> Q [Dec]
derivePathInfo' [Char] -> [Char]
formatter Name
name
= do Class
c <- Name -> Q Class
parseInfo Name
name
case Class
c of
Tagged [(Name, Int)]
cons Cxt
cx [Name]
keys ->
do let context :: Q Cxt
context = Cxt -> Q Cxt
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cxt -> Q Cxt) -> Cxt -> Q Cxt
forall a b. (a -> b) -> a -> b
$ [ Type -> Type -> Type
AppT (Name -> Type
ConT ''PathInfo) (Name -> Type
VarT Name
key) | Name
key <- [Name]
keys ] Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ Cxt
cx
Dec
i <- Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD Q Cxt
context (Name -> [Q Type] -> Q Type
mkType ''PathInfo [Name -> [Q Type] -> Q Type
mkType Name
name ((Name -> Q Type) -> [Name] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT [Name]
keys)])
[ [(Name, Int)] -> Q Dec
toPathSegmentsFn [(Name, Int)]
cons
, [(Name, Int)] -> Q Dec
fromPathSegmentsFn [(Name, Int)]
cons
]
[Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
i]
where
toPathSegmentsFn :: [(Name, Int)] -> DecQ
toPathSegmentsFn :: [(Name, Int)] -> Q Dec
toPathSegmentsFn [(Name, Int)]
cons
= do Name
inp <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"inp"
let body :: Q Exp
body = Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
inp) ([Q Match] -> Q Exp) -> [Q Match] -> Q Exp
forall a b. (a -> b) -> a -> b
$
[ do [Name]
args <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
nArgs ([Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"arg")
let matchCon :: Q Pat
matchCon = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
args)
conStr :: [Char]
conStr = [Char] -> [Char]
formatter (Name -> [Char]
nameBase Name
conName)
Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match Q Pat
matchCon (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB ([Char] -> [Name] -> Q Exp
toURLWork [Char]
conStr [Name]
args)) []
| (Name
conName, Int
nArgs) <- [(Name, Int)]
cons ]
toURLWork :: String -> [Name] -> ExpQ
toURLWork :: [Char] -> [Name] -> Q Exp
toURLWork [Char]
conStr [Name]
args
= (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Q Exp
a Q Exp
b -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [| (++) |] Q Exp
a) Q Exp
b) ([| [pack conStr] |] Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: [ [| toPathSegments $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
arg) |] | Name
arg <- [Name]
args ])
Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'toPathSegments [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
inp] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []]
fromPathSegmentsFn :: [(Name,Int)] -> DecQ
fromPathSegmentsFn :: [(Name, Int)] -> Q Dec
fromPathSegmentsFn [(Name, Int)]
cons
= do let body :: Q Exp
body = ((Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\Q Exp
a Q Exp
b -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [| (<|>) |] Q Exp
a) Q Exp
b)
[ Name -> Int -> Q Exp
parseCon Name
conName Int
nArgs
| (Name
conName, Int
nArgs) <- [(Name, Int)]
cons])
parseCon :: Name -> Int -> ExpQ
parseCon :: Name -> Int -> Q Exp
parseCon Name
conName Int
nArgs = (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\Q Exp
a Q Exp
b -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [| ap |] Q Exp
a) Q Exp
b)
([| segment (pack $([Char] -> Q Exp
forall (m :: * -> *). Quote m => [Char] -> m Exp
stringE ([Char] -> [Char]
formatter ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
nameBase Name
conName))) >> return $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName) |]
Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: (Int -> Q Exp -> [Q Exp]
forall a. Int -> a -> [a]
replicate Int
nArgs [| fromPathSegments |]))
Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'fromPathSegments [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []]
mkType :: Name -> [TypeQ] -> TypeQ
mkType :: Name -> [Q Type] -> Q Type
mkType Name
con = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
con)
data Class = Tagged [(Name, Int)] Cxt [Name]
parseInfo :: Name -> Q Class
parseInfo :: Name -> Q Class
parseInfo Name
name
= do Info
info <- Name -> Q Info
reify Name
name
case Info
info of
TyConI (DataD Cxt
cx Name
_ [TyVarBndr ()]
keys Maybe Type
_ [Con]
cs [DerivClause]
_) -> Class -> Q Class
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Class -> Q Class) -> Class -> Q Class
forall a b. (a -> b) -> a -> b
$ [(Name, Int)] -> Cxt -> [Name] -> Class
Tagged ((Con -> (Name, Int)) -> [Con] -> [(Name, Int)]
forall a b. (a -> b) -> [a] -> [b]
map Con -> (Name, Int)
conInfo [Con]
cs) Cxt
cx ([Name] -> Class) -> [Name] -> Class
forall a b. (a -> b) -> a -> b
$ (TyVarBndr () -> Name) -> [TyVarBndr ()] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr () -> Name
forall {flag}. TyVarBndr flag -> Name
conv [TyVarBndr ()]
keys
TyConI (NewtypeD Cxt
cx Name
_ [TyVarBndr ()]
keys Maybe Type
_ Con
con [DerivClause]
_)-> Class -> Q Class
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Class -> Q Class) -> Class -> Q Class
forall a b. (a -> b) -> a -> b
$ [(Name, Int)] -> Cxt -> [Name] -> Class
Tagged [Con -> (Name, Int)
conInfo Con
con] Cxt
cx ([Name] -> Class) -> [Name] -> Class
forall a b. (a -> b) -> a -> b
$ (TyVarBndr () -> Name) -> [TyVarBndr ()] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr () -> Name
forall {flag}. TyVarBndr flag -> Name
conv [TyVarBndr ()]
keys
Info
_ -> [Char] -> Q Class
forall a. HasCallStack => [Char] -> a
error ([Char]
"Unexpected " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> TypeRep -> [Char]
forall a. Show a => a -> [Char]
show (Info -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf Info
info) [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
": " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Info -> [Char]
forall a. Show a => a -> [Char]
show Info
info)
where conInfo :: Con -> (Name, Int)
conInfo (NormalC Name
n [BangType]
args) = (Name
n, [BangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
args)
conInfo (RecC Name
n [VarBangType]
args) = (Name
n, [VarBangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [VarBangType]
args)
conInfo (InfixC BangType
_ Name
n BangType
_) = (Name
n, Int
2)
conInfo (ForallC [TyVarBndr Specificity]
_ Cxt
_ Con
con) = Con -> (Name, Int)
conInfo Con
con
#if MIN_VERSION_template_haskell(2,17,0)
conv :: TyVarBndr flag -> Name
conv (PlainTV Name
nm flag
_) = Name
nm
conv (KindedTV Name
nm flag
_ Type
_) = Name
nm
#else
conv (PlainTV nm) = nm
conv (KindedTV nm _) = nm
#endif
standard :: String -> String
standard :: [Char] -> [Char]
standard =
[Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"-" ([[Char]] -> [Char]) -> ([Char] -> [[Char]]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower) ([[Char]] -> [[Char]])
-> ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Splitter Char -> [Char] -> [[Char]]
forall a. Splitter a -> [a] -> [[a]]
split Splitter Char
splitter
where
splitter :: Splitter Char
splitter = Splitter Char -> Splitter Char
forall a. Splitter a -> Splitter a
dropInitBlank (Splitter Char -> Splitter Char)
-> ((Char -> Bool) -> Splitter Char)
-> (Char -> Bool)
-> Splitter Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Splitter Char -> Splitter Char
forall a. Splitter a -> Splitter a
keepDelimsL (Splitter Char -> Splitter Char)
-> ((Char -> Bool) -> Splitter Char)
-> (Char -> Bool)
-> Splitter Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Splitter Char
forall a. (a -> Bool) -> Splitter a
whenElt ((Char -> Bool) -> Splitter Char)
-> (Char -> Bool) -> Splitter Char
forall a b. (a -> b) -> a -> b
$ Char -> Bool
isUpper
mkRoute :: Name -> Q [Dec]
mkRoute :: Name -> Q [Dec]
mkRoute Name
url =
do (Tagged [(Name, Int)]
cons Cxt
_ [Name]
_) <- Name -> Q Class
parseInfo Name
url
Dec
fn <- Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ([Char] -> Name
mkName [Char]
"route") ([Q Clause] -> Q Dec) -> [Q Clause] -> Q Dec
forall a b. (a -> b) -> a -> b
$
((Name, Int) -> Q Clause) -> [(Name, Int)] -> [Q Clause]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
con, Int
numArgs) ->
do
[Name]
args <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
numArgs ([Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"arg")
[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
con ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
args] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE ([Char] -> Name
mkName ([Char] -> [Char]
headLower (Name -> [Char]
nameBase Name
con)))) ((Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
args)) []
) [(Name, Int)]
cons
[Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
fn]
where
headLower :: String -> String
headLower :: [Char] -> [Char]
headLower (Char
c:[Char]
cs) = Char -> Char
toLower Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
cs
parseMethods :: Name -> Q [Name]
parseMethods :: Name -> Q [Name]
parseMethods Name
con =
do Info
info <- Name -> Q Info
reify Name
con
case Info
info of
(DataConI Name
_ Type
ty Name
_) ->
do IO () -> Q ()
forall a. IO a -> Q a
runIO (IO () -> Q ()) -> IO () -> Q ()
forall a b. (a -> b) -> a -> b
$ Type -> IO ()
forall a. Show a => a -> IO ()
print Type
ty
IO () -> Q ()
forall a. IO a -> Q a
runIO (IO () -> Q ()) -> IO () -> Q ()
forall a b. (a -> b) -> a -> b
$ Type -> IO ()
forall a. Show a => a -> IO ()
print (Type -> IO ()) -> Type -> IO ()
forall a b. (a -> b) -> a -> b
$ Type -> Type
lastTerm Type
ty
[Name] -> Q [Name]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name] -> Q [Name]) -> [Name] -> Q [Name]
forall a b. (a -> b) -> a -> b
$ Type -> [Name]
extractMethods (Type -> Type
lastTerm Type
ty)
extractMethods :: Type -> [Name]
Type
ty =
case Type
ty of
(AppT (ConT Name
con) (ConT Name
method)) ->
[Name
method]
(AppT (ConT Name
con) Type
methods) ->
Type -> [Name]
extractMethods' Type
methods
where
extractMethods' :: Type -> [Name]
extractMethods' :: Type -> [Name]
extractMethods' Type
t = (Type -> Name) -> Cxt -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\(ConT Name
n) -> Name
n) (Type -> Cxt
leafs Type
t)
lastTerm :: Type -> Type
lastTerm :: Type -> Type
lastTerm t :: Type
t@(AppT Type
l Type
r)
| Type -> Bool
hasArrowT Type
l = Type -> Type
lastTerm Type
r
| Bool
otherwise = Type
t
lastTerm Type
t = Type
t
hasArrowT :: Type -> Bool
hasArrowT :: Type -> Bool
hasArrowT Type
ArrowT = Bool
True
hasArrowT (AppT Type
l Type
r) = Type -> Bool
hasArrowT Type
l Bool -> Bool -> Bool
|| Type -> Bool
hasArrowT Type
r
hasArrowT Type
_ = Bool
False
leafs :: Type -> [Type]
leafs :: Type -> Cxt
leafs (AppT l :: Type
l@(AppT Type
_ Type
_) Type
r) = Type -> Cxt
leafs Type
l Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ Type -> Cxt
leafs Type
r
leafs (AppT Type
_ Type
r) = Type -> Cxt
leafs Type
r
leafs Type
t = [Type
t]