TH.hs

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
module Network.Lastfm.TH
  ( ResponseType(..)
  , xml, json
  , instances, newtypes
  ) where

import Language.Haskell.TH


-- Desired type of Lastfm response
data ResponseType = XML | JSON


-- Construct XML wrapper to specified API function
xml ∷ [String] → Q [Dec]
xml = mapM func
  where
   func xs = funD (mkName xs) [clause [] (normalB $ appE (varE (mkName ("API." ++ xs))) [e| XML |]) []]


-- Construct JSON wrapper to specified API function
json ∷ [String] → Q [Dec]
json = mapM func
  where
   func xs = funD (mkName xs) [clause [] (normalB $ appE (varE (mkName ("API." ++ xs))) [e| JSON |]) []]


instances ∷ String → [(String, String)] → Q [Dec]
instances f = mapM (instanceDeclaration "Argument")
  where
   instanceDeclaration (mkName → tc) (mkName → n, m) = instanceD (cxt []) (appT (conT tc) (conT n)) [first, second]
    where
     first = funD (mkName "key") [clause [] (normalB [e| const m |]) []]
     second = let var = mkName "a"
                  func = mkName f
              in funD (mkName "value") [clause [conP n [varP var]] (normalB $ appE (varE func) (varE var)) []]


newtypes ∷ String → [String] → Q [Dec]
newtypes (mkName → t) (map mkName → ns) = mapM newtypeDeclaration ns
  where
   newtypeDeclaration n = newtypeD (cxt []) n [] (normalC n [strictType notStrict (conT t)]) []