module Web.Apiary.TH.Capture where
import Control.Monad
import Network.Wai
import Text.Read
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Data.Int
import Data.Word
import Control.Monad.Apiary
preCapture :: [Char] -> [T.Text]
preCapture ('/':s) = T.splitOn "/" $ T.pack s
preCapture s = T.splitOn "/" $ T.pack s
capture :: QuasiQuoter
capture = QuasiQuoter
{ quoteExp = capture' . preCapture
, quotePat = \_ -> error "No quotePat."
, quoteType = \_ -> error "No quoteType."
, quoteDec = \_ -> error "No quoteDec."
}
class Param a where
readParam :: T.Text -> Maybe a
instance Param Char where
readParam s | T.null s = Nothing
| otherwise = Just $ T.head s
instance Param Int where readParam = readMaybe . T.unpack
instance Param Int8 where readParam = readMaybe . T.unpack
instance Param Int16 where readParam = readMaybe . T.unpack
instance Param Int32 where readParam = readMaybe . T.unpack
instance Param Int64 where readParam = readMaybe . T.unpack
instance Param Integer where readParam = readMaybe . T.unpack
instance Param Word where readParam = readMaybe . T.unpack
instance Param Word8 where readParam = readMaybe . T.unpack
instance Param Word16 where readParam = readMaybe . T.unpack
instance Param Word32 where readParam = readMaybe . T.unpack
instance Param Word64 where readParam = readMaybe . T.unpack
instance Param Double where readParam = readMaybe . T.unpack
instance Param Float where readParam = readMaybe . T.unpack
instance Param T.Text where
readParam = Just
instance Param TL.Text where
readParam = Just . TL.fromStrict
instance Param String where
readParam = Just . T.unpack
integralE :: Integral i => i -> ExpQ
integralE = litE . integerL . fromIntegral
capture' :: [T.Text] -> ExpQ
capture' cap = [| function $ \ $(varP $ mkName "cont") request ->
$(caseE [|pathInfo request|]
[ match pat (guards >>= \g -> body >>= \b -> normalB (doE $ g ++ b)) []
, match wildP (normalB [|mzero|]) []
]) |]
where
varNames = zip cap $ map (('v':) . show) [0 :: Int ..]
pat = listP $ map (varP . mkName . snd) varNames
isType s | T.null s = False
| T.head s == ':' = True
| otherwise = False
guards = return $
map (\(a,v) -> noBindS [|guard $ $(varE $ mkName v) == $(stringE $ T.unpack a) |]) $
filter (not . isType . fst) varNames
body = do
let ss = map (\(a,v) -> do
ty <- lookupType a
bindS (varP . mkName $ v ++ "'")
[| (readParam $(varE $ mkName v) :: Maybe $(conT ty) ) |])
$ filter (isType . fst) varNames
rt = foldr (\i b -> varE 'sSnoc `appE` b `appE` i) (varE $ mkName "cont") . reverse .
map (varE . mkName . (++ "'") . snd) $ filter (isType . fst) varNames
return $ ss ++ [noBindS [| return $rt |]]
lookupType n = lookupTypeName (T.unpack $ T.tail n) >>= \case
Nothing -> fail $ "capture': type not found: " ++ T.unpack (T.tail n)
Just ty -> return ty