Test.hs

{-# OPTIONS_GHC -Wall -fno-warn-missing-signatures #-}
--module Database.MySQL.Simple.QQ.Test where

import Control.Applicative ((<$>))
import System.Exit (ExitCode(..), exitWith)

import Data.Generics (everywhere, mkT)
import Data.Generics.Text (gshow)
import Data.List (isPrefixOf)

import Database.MySQL.Simple.Quasi

import Language.Haskell.TH (runQ)
import Language.Haskell.TH.Ppr (pprint)
import Language.Haskell.TH.Quote (quoteExp)
import qualified Language.Haskell.TH.Syntax as TH
import Language.Haskell.Meta.Parse (parseExp)

qual :: [(String, String)] -> String -> String
qual prefixTgts = go prefixTgts
  where
    go _ [] = []
    go ((prefix, tgt):more) src
      | tgt `isPrefixOf` src = prefix ++ tgt ++ go prefixTgts (drop (length tgt) src)
      | otherwise = go more src
    go [] (c:cs) = c : go prefixTgts cs


collapseForall :: TH.Exp -> TH.Exp
collapseForall (TH.SigE e t) = TH.SigE e $ collapseForallT t
  where
    collapseForallT (TH.ForallT ts [] (TH.ForallT [] ctxt inner)) = TH.ForallT ts ctxt inner
    collapseForallT x = x
collapseForall e = e

-- | Code from qquery uses NameG but haskell-src-meta uses NameQ.
-- This hack turns all NameG into NameQ ready for comparison:
canonName :: TH.Name -> TH.Name
canonName = TH.mkName . show 

unqualName :: TH.Name -> TH.Name
unqualName = TH.mkName . TH.nameBase

asCode :: TH.Exp -> String
asCode = pprint . everywhere (mkT unqualName)

dupeQueries :: String -> String
dupeQueries ('$':'\"':rest)
  = let (queryStr, '\"':more) = span (/= '\"') rest
    in "(\"" ++ queryStr ++ "\", Data.String.fromString \"" ++ queryStr ++ "\")" ++ dupeQueries more
dupeQueries (c:cs) = c : dupeQueries cs
dupeQueries [] = []

(==>) :: String -> String -> IO Bool
(==>) src expS = do
  act <- everywhere (mkT canonName) <$> runQ (quoteExp qquery src)
  let expS' = qual [("Database.MySQL.Simple.QQ.", "QQuery") -- Handles QQuery_ too
                   ,("Database.MySQL.Simple.QueryResults.", "QueryResults")
                   ,("Database.MySQL.Simple.Param.", "Param")
                   ,("Database.MySQL.Simple.Types.", "fromOnly") -- Try fromOnly before Only
                   ,("Database.MySQL.Simple.Types.", "Only")
                   ] . dupeQueries $ expS
  case collapseForall <$> parseExp expS' of
    Left e -> do putStrLn $ "Problem parsing expected output: " ++ e
                 return False
    Right x | x == act -> return True
            | otherwise -> do mapM_ putStrLn
                                [ "Mismatch. Expected:", "  " ++ asCode x, "  " ++ gshow x
                                , "Actual:", "  " ++ asCode act, "  " ++ gshow act]
                              return False

simple = "select * from users" ==> "QQuery_ GHC.Base.id $\"select * from users\" :: forall r. QueryResults r => QQuery_ r"

ret1 = "select id{Int} from users" ==> "QQuery_ fromOnly $\"select id from users\" :: QQuery_ Int" 

ret2 = "select id{Int}, name{String} from users" ==> "QQuery_ GHC.Base.id $\"select id, name from users\" :: QQuery_ (Int, String)"

ret4 = "select id{Int}, f.*{String, Bool}, name{Double} from users, f" ==>
       "QQuery_ GHC.Base.id $\"select id, f.*, name from users, f\" :: QQuery_ (Int, String, Bool, Double)"

subst1 = "select * from users where name = ?{String}" ==>
         "QQuery Only GHC.Base.id $\"select * from users where name = ?\" :: forall r. QueryResults r => QQuery String r"

subst1b = "select * from users where name = ?" ==>
          "QQuery Only GHC.Base.id $\"select * from users where name = ?\" :: forall q r. (Param q, QueryResults r) => QQuery q r"

subst3 = "select id{Maybe Int} from users where name = ?{Int} and name2 = ?{Bool} and name3 = ?{Maybe Double}" ==>
          "QQuery GHC.Base.id fromOnly $\"select id from users where name = ? and name2 = ? and name3 = ?\" :: QQuery (Int, Bool, Maybe Double) (Maybe Int)"

subst3b = "select * from users where name = ? and name2 = ? and name3 = ?" ==>
          "QQuery GHC.Base.id GHC.Base.id $\"select * from users where name = ? and name2 = ? and name3 = ?\" :: forall q q1 q2 r. (Param q, Param q1, Param q2, QueryResults r) => QQuery (q, q1, q2) r"


escaped = "select \\{curled} from whatever where text = 'hello\\?'" ==>
          "QQuery_ GHC.Base.id $\"select {curled} from whatever where text = 'hello?'\" :: forall r. QueryResults r => QQuery_ r"

main :: IO ()
main = do passed <- and <$> sequence [simple, ret1, ret2, ret4, escaped, subst1, subst1b,
            subst3, subst3b]
          exitWith $ if passed then ExitSuccess else ExitFailure 1