Dispatch.hs

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE StandaloneDeriving #-}

module FP.API.Dispatch where

import Data.Char (toLower)
import Data.Maybe (mapMaybe)
import Data.Traversable (forM)
import Language.Haskell.TH
import Language.Fay.Yesod (Returns)
import FP.API.Types (Returns')
import Prelude

mkFayCommands :: [(Name, Name, String -> String)] -> Q [Dec]
mkFayCommands cmdTypes =
  fmap concat $ forM cmdTypes $ \(datatype, runName, changeName) -> do
    (TyConI (DataD _ _ _ cs _)) <- reify datatype
    sequence [ mkFayCommand runName name changeName (map snd fs)
             | NormalC name fs <- cs
             ]

mkFayCommand :: Name -> Name -> (String -> String) -> [Type] -> Q Dec
mkFayCommand runName conName nameModifier fields = do
  args <- forM fields $ \ty -> case unAppsT ty of
    -- Don't include the "Returns" field of the command
    (ConT n:_) | n == ''Returns || n == ''Returns'
      -> return (Nothing, Nothing)
    -- Otherwise, have an argument and use it in the command
    _ -> do
      n <- newName "x"
      return (Just $ VarP n, Just $ VarE n)
  let funcName = mkName $ nameModifier $ decapitalize $ nameBase conName
      expr = AppE (VarE runName) $
        foldl AppE (ConE conName) $ mapMaybe snd args
  return $ FunD funcName [Clause (mapMaybe fst args) (NormalB expr) []]

decapitalize :: String -> String
decapitalize [] = []
decapitalize (x:xs) = toLower x : xs

appsE' :: [Exp] -> Exp
appsE' = foldl1 AppE

unAppsT :: Type -> [Type]
unAppsT = reverse . helper
  where
  helper (AppT l r) = r : helper l
  helper x          = [x]