{-# 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 = derivePathInfo' standard
derivePathInfo' :: (String -> String)
-> Name
-> Q [Dec]
derivePathInfo' formatter name
= do c <- parseInfo name
case c of
Tagged cons cx keys ->
do let context = [ mkCtx ''PathInfo [varT key] | key <- keys ] ++ map return cx
i <- instanceD (sequence context) (mkType ''PathInfo [mkType name (map varT keys)])
[ toPathSegmentsFn cons
, fromPathSegmentsFn cons
]
return [i]
where
#if MIN_VERSION_template_haskell(2,4,0)
mkCtx = classP
#else
mkCtx = mkType
#endif
toPathSegmentsFn :: [(Name, Int)] -> DecQ
toPathSegmentsFn cons
= do inp <- newName "inp"
let body = caseE (varE inp) $
[ do args <- replicateM nArgs (newName "arg")
let matchCon = conP conName (map varP args)
conStr = formatter (nameBase conName)
match matchCon (normalB (toURLWork conStr args)) []
| (conName, nArgs) <- cons ]
toURLWork :: String -> [Name] -> ExpQ
toURLWork conStr args
= foldr1 (\a b -> appE (appE [| (++) |] a) b) ([| [pack conStr] |] : [ [| toPathSegments $(varE arg) |] | arg <- args ])
funD 'toPathSegments [clause [varP inp] (normalB body) []]
fromPathSegmentsFn :: [(Name,Int)] -> DecQ
fromPathSegmentsFn cons
= do let body = (foldl1 (\a b -> appE (appE [| (<|>) |] a) b)
[ parseCon conName nArgs
| (conName, nArgs) <- cons])
parseCon :: Name -> Int -> ExpQ
parseCon conName nArgs = foldl1 (\a b -> appE (appE [| ap |] a) b)
([| segment (pack $(stringE (formatter $ nameBase conName))) >> return $(conE conName) |]
: (replicate nArgs [| fromPathSegments |]))
funD 'fromPathSegments [clause [] (normalB body) []]
mkType :: Name -> [TypeQ] -> TypeQ
mkType con = foldl appT (conT con)
data Class = Tagged [(Name, Int)] Cxt [Name]
parseInfo :: Name -> Q Class
parseInfo name
= do info <- reify name
case info of
#if MIN_VERSION_template_haskell(2,11,0)
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
#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
_ -> error $ "derivePathInfo - invalid input: " ++ pprint info
where conInfo (NormalC n args) = (n, length args)
conInfo (RecC n args) = (n, length args)
conInfo (InfixC _ n _) = (n, 2)
conInfo (ForallC _ _ con) = conInfo con
#if MIN_VERSION_template_haskell(2,4,0)
conv (PlainTV nm) = nm
conv (KindedTV nm _) = nm
#else
conv = id
#endif
standard :: String -> String
standard =
intercalate "-" . map (map toLower) . split splitter
where
splitter = dropInitBlank . keepDelimsL . whenElt $ isUpper
mkRoute :: Name -> Q [Dec]
mkRoute url =
do (Tagged cons _ _) <- parseInfo url
fn <- funD (mkName "route") $
map (\(con, numArgs) ->
do
args <- replicateM numArgs (newName "arg")
clause [conP con $ map varP args] (normalB $ foldl' appE (varE (mkName (headLower (nameBase con)))) (map varE args)) []
) cons
return [fn]
where
headLower :: String -> String
headLower (c:cs) = toLower c : cs
parseMethods :: Name -> Q [Name]
parseMethods con =
do info <- reify con
case info of
#if MIN_VERSION_template_haskell(2,11,0)
(DataConI _ ty _) ->
#else
(DataConI _ ty _ _) ->
#endif
do runIO $ print ty
runIO $ print $ lastTerm ty
return $ extractMethods (lastTerm ty)
extractMethods :: Type -> [Name]
extractMethods ty =
case ty of
(AppT (ConT con) (ConT method)) ->
[method]
(AppT (ConT con) methods) ->
extractMethods' methods
where
extractMethods' :: Type -> [Name]
extractMethods' t = map (\(ConT n) -> n) (leafs t)
lastTerm :: Type -> Type
lastTerm t@(AppT l r)
| hasArrowT l = lastTerm r
| otherwise = t
lastTerm t = t
hasArrowT :: Type -> Bool
hasArrowT ArrowT = True
hasArrowT (AppT l r) = hasArrowT l || hasArrowT r
hasArrowT _ = False
leafs :: Type -> [Type]
leafs (AppT l@(AppT _ _) r) = leafs l ++ leafs r
leafs (AppT _ r) = leafs r
leafs t = [t]