{-# 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' formatter :: String -> String
formatter name :: Name
name
= do Class
c <- Name -> Q Class
parseInfo Name
name
case Class
c of
Tagged cons :: [(Name, Int)]
cons cx :: Cxt
cx keys :: [Name]
keys ->
do let context :: [Q Pred]
context = [ Name -> [Q Pred] -> Q Pred
mkCtx ''PathInfo [Name -> Q Pred
varT Name
key] | Name
key <- [Name]
keys ] [Q Pred] -> [Q Pred] -> [Q Pred]
forall a. [a] -> [a] -> [a]
++ (Pred -> Q Pred) -> Cxt -> [Q Pred]
forall a b. (a -> b) -> [a] -> [b]
map Pred -> Q Pred
forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
cx
Dec
i <- CxtQ -> Q Pred -> [DecQ] -> DecQ
instanceD ([Q Pred] -> CxtQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q Pred]
context) (Name -> [Q Pred] -> Q Pred
mkType ''PathInfo [Name -> [Q Pred] -> Q Pred
mkType Name
name ((Name -> Q Pred) -> [Name] -> [Q Pred]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pred
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
#if MIN_VERSION_template_haskell(2,4,0)
mkCtx :: Name -> [Q Pred] -> Q Pred
mkCtx = Name -> [Q Pred] -> Q Pred
classP
#else
mkCtx = mkType
#endif
toPathSegmentsFn :: [(Name, Int)] -> DecQ
toPathSegmentsFn :: [(Name, Int)] -> DecQ
toPathSegmentsFn cons :: [(Name, Int)]
cons
= do Name
inp <- String -> Q Name
newName "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 "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)) []
| (conName :: Name
conName, nArgs :: Int
nArgs) <- [(Name, Int)]
cons ]
toURLWork :: String -> [Name] -> ExpQ
toURLWork :: String -> [Name] -> ExpQ
toURLWork conStr :: String
conStr args :: [Name]
args
= (ExpQ -> ExpQ -> ExpQ) -> [ExpQ] -> ExpQ
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\a :: ExpQ
a b :: 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 cons :: [(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 (\a :: ExpQ
a b :: ExpQ
b -> ExpQ -> ExpQ -> ExpQ
appE (ExpQ -> ExpQ -> ExpQ
appE [| (<|>) |] ExpQ
a) ExpQ
b)
[ Name -> Int -> ExpQ
parseCon Name
conName Int
nArgs
| (conName :: Name
conName, nArgs :: Int
nArgs) <- [(Name, Int)]
cons])
parseCon :: Name -> Int -> ExpQ
parseCon :: Name -> Int -> ExpQ
parseCon conName :: Name
conName nArgs :: Int
nArgs = (ExpQ -> ExpQ -> ExpQ) -> [ExpQ] -> ExpQ
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\a :: ExpQ
a b :: 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 -> [Q Pred] -> Q Pred
mkType con :: Name
con = (Q Pred -> Q Pred -> Q Pred) -> Q Pred -> [Q Pred] -> Q Pred
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Pred -> Q Pred -> Q Pred
appT (Name -> Q Pred
conT Name
con)
data Class = Tagged [(Name, Int)] Cxt [Name]
parseInfo :: Name -> Q Class
parseInfo :: Name -> Q Class
parseInfo name :: Name
name
= do Info
info <- Name -> Q Info
reify Name
name
case Info
info of
#if MIN_VERSION_template_haskell(2,11,0)
TyConI (DataD cx :: Cxt
cx _ keys :: [TyVarBndr]
keys _ cs :: [Con]
cs _) -> 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 cx :: Cxt
cx _ keys :: [TyVarBndr]
keys _ con :: Con
con _)-> 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
#else
TyConI (DataD cx _ keys cs _) -> return $ Tagged (map conInfo cs) cx $ map conv keys
TyConI (NewtypeD cx _ keys con _)-> return $ Tagged [conInfo con] cx $ map conv keys
#endif
_ -> String -> Q Class
forall a. HasCallStack => String -> a
error (String -> Q Class) -> String -> Q Class
forall a b. (a -> b) -> a -> b
$ "derivePathInfo - invalid input: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Info -> String
forall a. Ppr a => a -> String
pprint Info
info
where conInfo :: Con -> (Name, Int)
conInfo (NormalC n :: Name
n args :: [BangType]
args) = (Name
n, [BangType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
args)
conInfo (RecC n :: Name
n args :: [VarBangType]
args) = (Name
n, [VarBangType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [VarBangType]
args)
conInfo (InfixC _ n :: Name
n _) = (Name
n, 2)
conInfo (ForallC _ _ con :: Con
con) = Con -> (Name, Int)
conInfo Con
con
#if MIN_VERSION_template_haskell(2,4,0)
conv :: TyVarBndr -> Name
conv (PlainTV nm :: Name
nm) = Name
nm
conv (KindedTV nm :: Name
nm _) = Name
nm
#else
conv = id
#endif
standard :: String -> String
standard :: String -> String
standard =
String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "-" ([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 url :: Name
url =
do (Tagged cons :: [(Name, Int)]
cons _ _) <- Name -> Q Class
parseInfo Name
url
Dec
fn <- Name -> [ClauseQ] -> DecQ
funD (String -> Name
mkName "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 (\(con :: Name
con, numArgs :: 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 "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 (c :: Char
c:cs :: 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 con :: Name
con =
do Info
info <- Name -> Q Info
reify Name
con
case Info
info of
#if MIN_VERSION_template_haskell(2,11,0)
(DataConI _ ty :: Pred
ty _) ->
#else
(DataConI _ ty _ _) ->
#endif
do IO () -> Q ()
forall a. IO a -> Q a
runIO (IO () -> Q ()) -> IO () -> Q ()
forall a b. (a -> b) -> a -> b
$ Pred -> IO ()
forall a. Show a => a -> IO ()
print Pred
ty
IO () -> Q ()
forall a. IO a -> Q a
runIO (IO () -> Q ()) -> IO () -> Q ()
forall a b. (a -> b) -> a -> b
$ Pred -> IO ()
forall a. Show a => a -> IO ()
print (Pred -> IO ()) -> Pred -> IO ()
forall a b. (a -> b) -> a -> b
$ Pred -> Pred
lastTerm Pred
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
$ Pred -> [Name]
extractMethods (Pred -> Pred
lastTerm Pred
ty)
extractMethods :: Type -> [Name]
ty :: Pred
ty =
case Pred
ty of
(AppT (ConT con :: Name
con) (ConT method :: Name
method)) ->
[Name
method]
(AppT (ConT con :: Name
con) methods :: Pred
methods) ->
Pred -> [Name]
extractMethods' Pred
methods
where
extractMethods' :: Type -> [Name]
extractMethods' :: Pred -> [Name]
extractMethods' t :: Pred
t = (Pred -> Name) -> Cxt -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\(ConT n :: Name
n) -> Name
n) (Pred -> Cxt
leafs Pred
t)
lastTerm :: Type -> Type
lastTerm :: Pred -> Pred
lastTerm t :: Pred
t@(AppT l :: Pred
l r :: Pred
r)
| Pred -> Bool
hasArrowT Pred
l = Pred -> Pred
lastTerm Pred
r
| Bool
otherwise = Pred
t
lastTerm t :: Pred
t = Pred
t
hasArrowT :: Type -> Bool
hasArrowT :: Pred -> Bool
hasArrowT ArrowT = Bool
True
hasArrowT (AppT l :: Pred
l r :: Pred
r) = Pred -> Bool
hasArrowT Pred
l Bool -> Bool -> Bool
|| Pred -> Bool
hasArrowT Pred
r
hasArrowT _ = Bool
False
leafs :: Type -> [Type]
leafs :: Pred -> Cxt
leafs (AppT l :: Pred
l@(AppT _ _) r :: Pred
r) = Pred -> Cxt
leafs Pred
l Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ Pred -> Cxt
leafs Pred
r
leafs (AppT _ r :: Pred
r) = Pred -> Cxt
leafs Pred
r
leafs t :: Pred
t = [Pred
t]