{-# 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 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 = (String -> String) -> Name -> Q [Dec]
derivePathInfo' String -> String
standard
derivePathInfo' :: (String -> String)
-> Name
-> Q [Dec]
derivePathInfo' :: (String -> String) -> Name -> Q [Dec]
derivePathInfo' String -> String
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 (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 -> TypeQ -> [DecQ] -> DecQ
instanceD Q Cxt
context (Name -> [TypeQ] -> TypeQ
mkType ''PathInfo [Name -> [TypeQ] -> TypeQ
mkType Name
name ((Name -> TypeQ) -> [Name] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TypeQ
varT [Name]
keys)])
[ [(Name, Int)] -> DecQ
toPathSegmentsFn [(Name, Int)]
cons
, [(Name, Int)] -> DecQ
fromPathSegmentsFn [(Name, Int)]
cons
]
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
i]
where
toPathSegmentsFn :: [(Name, Int)] -> DecQ
toPathSegmentsFn :: [(Name, Int)] -> DecQ
toPathSegmentsFn [(Name, Int)]
cons
= do Name
inp <- String -> Q Name
newName String
"inp"
let body :: ExpQ
body = ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
inp) ([MatchQ] -> ExpQ) -> [MatchQ] -> ExpQ
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 (String -> Q Name
newName String
"arg")
let matchCon :: PatQ
matchCon = Name -> [PatQ] -> PatQ
conP Name
conName ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
args)
conStr :: String
conStr = String -> String
formatter (Name -> String
nameBase Name
conName)
PatQ -> BodyQ -> [DecQ] -> MatchQ
match PatQ
matchCon (ExpQ -> BodyQ
normalB (String -> [Name] -> ExpQ
toURLWork String
conStr [Name]
args)) []
| (Name
conName, Int
nArgs) <- [(Name, Int)]
cons ]
toURLWork :: String -> [Name] -> ExpQ
toURLWork :: String -> [Name] -> ExpQ
toURLWork String
conStr [Name]
args
= (ExpQ -> ExpQ -> ExpQ) -> [ExpQ] -> ExpQ
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\ExpQ
a ExpQ
b -> ExpQ -> ExpQ -> ExpQ
appE (ExpQ -> ExpQ -> ExpQ
appE [| (++) |] ExpQ
a) ExpQ
b) ([| [pack conStr] |] ExpQ -> [ExpQ] -> [ExpQ]
forall a. a -> [a] -> [a]
: [ [| toPathSegments $(varE arg) |] | Name
arg <- [Name]
args ])
Name -> [ClauseQ] -> DecQ
funD 'toPathSegments [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [Name -> PatQ
varP Name
inp] (ExpQ -> BodyQ
normalB ExpQ
body) []]
fromPathSegmentsFn :: [(Name,Int)] -> DecQ
fromPathSegmentsFn :: [(Name, Int)] -> DecQ
fromPathSegmentsFn [(Name, Int)]
cons
= do let body :: ExpQ
body = ((ExpQ -> ExpQ -> ExpQ) -> [ExpQ] -> ExpQ
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\ExpQ
a ExpQ
b -> ExpQ -> ExpQ -> ExpQ
appE (ExpQ -> ExpQ -> ExpQ
appE [| (<|>) |] ExpQ
a) ExpQ
b)
[ Name -> Int -> ExpQ
parseCon Name
conName Int
nArgs
| (Name
conName, Int
nArgs) <- [(Name, Int)]
cons])
parseCon :: Name -> Int -> ExpQ
parseCon :: Name -> Int -> ExpQ
parseCon Name
conName Int
nArgs = (ExpQ -> ExpQ -> ExpQ) -> [ExpQ] -> ExpQ
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\ExpQ
a ExpQ
b -> ExpQ -> ExpQ -> ExpQ
appE (ExpQ -> ExpQ -> ExpQ
appE [| ap |] ExpQ
a) ExpQ
b)
([| segment (pack $(stringE (formatter $ nameBase conName))) >> return $(conE conName) |]
ExpQ -> [ExpQ] -> [ExpQ]
forall a. a -> [a] -> [a]
: (Int -> ExpQ -> [ExpQ]
forall a. Int -> a -> [a]
replicate Int
nArgs [| fromPathSegments |]))
Name -> [ClauseQ] -> DecQ
funD 'fromPathSegments [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB ExpQ
body) []]
mkType :: Name -> [TypeQ] -> TypeQ
mkType :: Name -> [TypeQ] -> TypeQ
mkType Name
con = (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
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 (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
conv [TyVarBndr]
keys
TyConI (NewtypeD Cxt
cx Name
_ [TyVarBndr]
keys Maybe Type
_ Con
con [DerivClause]
_)-> Class -> Q Class
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
conv [TyVarBndr]
keys
where conInfo :: Con -> (Name, Int)
conInfo (NormalC Name
n [BangType]
args) = (Name
n, [BangType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
args)
conInfo (RecC Name
n [VarBangType]
args) = (Name
n, [VarBangType] -> 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]
_ Cxt
_ Con
con) = Con -> (Name, Int)
conInfo Con
con
#if MIN_VERSION_template_haskell(2,17,0)
conv (PlainTV nm _) = nm
conv (KindedTV nm _ _) = nm
#else
conv :: TyVarBndr -> Name
conv (PlainTV Name
nm) = Name
nm
conv (KindedTV Name
nm Type
_) = Name
nm
#endif
standard :: String -> String
standard :: String -> String
standard =
String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"-" ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Splitter Char -> String -> [String]
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 -> [ClauseQ] -> DecQ
funD (String -> Name
mkName String
"route") ([ClauseQ] -> DecQ) -> [ClauseQ] -> DecQ
forall a b. (a -> b) -> a -> b
$
((Name, Int) -> ClauseQ) -> [(Name, Int)] -> [ClauseQ]
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 (String -> Q Name
newName String
"arg")
[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [Name -> [PatQ] -> PatQ
conP Name
con ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
args] (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (String -> Name
mkName (String -> String
headLower (Name -> String
nameBase Name
con)))) ((Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE [Name]
args)) []
) [(Name, Int)]
cons
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
fn]
where
headLower :: String -> String
headLower :: String -> String
headLower (Char
c:String
cs) = Char -> Char
toLower Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
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 (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]