twitter-types-0.4.20140809: tests/Fixtures.hs

{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}

module Fixtures where

import Language.Haskell.TH
import Data.Aeson
import Data.Attoparsec.ByteString
import qualified Data.ByteString as S
import Data.Maybe
import System.Directory
import System.FilePath
import System.IO.Unsafe (unsafePerformIO)
import Control.Applicative

parseJSONValue :: S.ByteString -> Value
parseJSONValue = fromJust . maybeResult . parse json

fixturePath :: String
fixturePath = takeDirectory __FILE__ </> "fixtures"

loadFixture :: (S.ByteString -> a) -> String -> IO a
loadFixture conv filename = conv <$> S.readFile (fixturePath </> filename)

fixture :: (S.ByteString -> a) -> String -> a
fixture conv = unsafePerformIO . loadFixture conv

loadFixturesTH :: Name -> Q [Dec]
loadFixturesTH convFn = do
    files <- runIO $ filter (\fn -> takeExtension fn == ".json") <$> getDirectoryContents fixturePath
    concat <$> mapM genEachDefs files
  where
    genEachDefs filename = do
        let funN = mkName $ "fixture_" ++ dropExtension filename
        sigdef <- sigD funN (conT ''Value)
        bind <- valD (varP funN) (normalB [|fixture $(varE convFn) $(litE (stringL filename))|]) []
        return [ sigdef, bind ]