{-# 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

-- | use Template Haskell to create 'PathInfo' instances for a type.
--
-- > $(derivePathInfo ''SiteURL)
--
-- Uses the 'standard' formatter by default.
derivePathInfo :: Name
               -> Q [Dec]
derivePathInfo :: Name -> Q [Dec]
derivePathInfo = ([Char] -> [Char]) -> Name -> Q [Dec]
derivePathInfo' [Char] -> [Char]
standard

-- FIXME: handle when called with a type (not data, newtype)

-- | use Template Haskell to create 'PathInfo' instances for a type.
--
-- This variant allows the user to supply a function that transforms
-- the constructor name to a prettier rendering. It is important that
-- the transformation function generates a unique output for each
-- input. For example, simply converting the string to all lower case
-- is not acceptable, because then 'FooBar' and 'Foobar' would be
-- indistinguishable.
--
-- > $(derivePathInfo' standard ''SiteURL)
--
-- see also: '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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$  [ Type -> Type -> Type
AppT (Name -> Type
ConT ''PathInfo) (Name -> Type
VarT Name
key) | Name
key <- [Name]
keys ] forall a. [a] -> [a] -> [a]
++ Cxt
cx
                  Dec
i <- forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD Q Cxt
context (Name -> [TypeQ] -> TypeQ
mkType ''PathInfo [Name -> [TypeQ] -> TypeQ
mkType Name
name (forall a b. (a -> b) -> [a] -> [b]
map 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
                       ]
                  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 <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"inp"
               let body :: Q Exp
body = forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
inp) forall a b. (a -> b) -> a -> b
$
                            [ do [Name]
args <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
nArgs (forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"arg")
                                 let matchCon :: Q Pat
matchCon = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
args)
                                     conStr :: [Char]
conStr = [Char] -> [Char]
formatter (Name -> [Char]
nameBase Name
conName)
                                 forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match Q Pat
matchCon (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
                       = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Q Exp
a Q Exp
b -> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [| (++) |] Q Exp
a) Q Exp
b) ([| [pack conStr] |] forall a. a -> [a] -> [a]
: [ [| toPathSegments $(varE arg) |] | Name
arg <- [Name]
args ])
               forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'toPathSegments [forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
inp] (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 = (forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\Q Exp
a Q Exp
b -> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (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 = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\Q Exp
a Q Exp
b -> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [| ap |] Q Exp
a) Q Exp
b)
                                                   ([| segment (pack $(stringE (formatter $ nameBase conName))) >> return $(conE conName) |]
                                                   forall a. a -> [a] -> [a]
: (forall a. Int -> a -> [a]
replicate Int
nArgs [| fromPathSegments |]))
               forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'fromPathSegments [forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []]

mkType :: Name -> [TypeQ] -> TypeQ
mkType :: Name -> [TypeQ] -> TypeQ
mkType Name
con = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (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]
_)    -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(Name, Int)] -> Cxt -> [Name] -> Class
Tagged (forall a b. (a -> b) -> [a] -> [b]
map Con -> (Name, Int)
conInfo [Con]
cs) Cxt
cx forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {flag}. TyVarBndr flag -> Name
conv [TyVarBndr ()]
keys
           TyConI (NewtypeD Cxt
cx Name
_ [TyVarBndr ()]
keys Maybe Type
_ Con
con [DerivClause]
_)-> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(Name, Int)] -> Cxt -> [Name] -> Class
Tagged [Con -> (Name, Int)
conInfo Con
con] Cxt
cx forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {flag}. TyVarBndr flag -> Name
conv [TyVarBndr ()]
keys
           Info
_ -> forall a. HasCallStack => [Char] -> a
error ([Char]
"Unexpected " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (forall a. Typeable a => a -> TypeRep
typeOf Info
info) forall a. Semigroup a => a -> a -> a
<> [Char]
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Info
info)
    where conInfo :: Con -> (Name, Int)
conInfo (NormalC Name
n [BangType]
args) = (Name
n, forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
args)
          conInfo (RecC Name
n [VarBangType]
args) = (Name
n, 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

-- | the standard formatter
--
-- Converts @CamelCase@ to @camel-case@.
--
-- see also: 'derivePathInfo' and 'derivePathInfo''
standard :: String -> String
standard :: [Char] -> [Char]
standard =
    forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"-" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Splitter a -> [a] -> [[a]]
split Splitter Char
splitter
  where
    splitter :: Splitter Char
splitter = forall a. Splitter a -> Splitter a
dropInitBlank forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Splitter a -> Splitter a
keepDelimsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> Splitter a
whenElt 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 <- forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ([Char] -> Name
mkName [Char]
"route") forall a b. (a -> b) -> a -> b
$
               forall a b. (a -> b) -> [a] -> [b]
map (\(Name
con, Int
numArgs) ->
                        do -- methods <- parseMethods con
                           -- runIO $ print methods
                           [Name]
args <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
numArgs (forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"arg")
                           forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
con forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
args] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE ([Char] -> Name
mkName ([Char] -> [Char]
headLower (Name -> [Char]
nameBase Name
con)))) (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
args)) []
                   ) [(Name, Int)]
cons
       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 forall a. a -> [a] -> [a]
: [Char]
cs

-- work in progress

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 forall a. IO a -> Q a
runIO forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> IO ()
print Type
ty
                forall a. IO a -> Q a
runIO forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> IO ()
print forall a b. (a -> b) -> a -> b
$ Type -> Type
lastTerm Type
ty
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> [Name]
extractMethods (Type -> Type
lastTerm Type
ty)

extractMethods :: Type -> [Name]
extractMethods :: Type -> [Name]
extractMethods 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 = forall a b. (a -> b) -> [a] -> [b]
map (\(ConT Name
n) -> Name
n) (Type -> Cxt
leafs Type
t)

-- | return the 'Type' after the right-most @->@. Or the original 'Type' if there are no @->@.
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

-- | tests if a 'Type' contains an 'ArrowT' somewhere
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 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]