TemplateHaskellSpec.hs

{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}

module Data.Acid.TemplateHaskellSpec where

import Test.Hspec hiding (context)

import Data.SafeCopy (SafeCopy)
import Control.DeepSeq (force)
import Control.Exception (evaluate)
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Control.Monad.Reader
import Control.Monad.State

import Data.Acid
import Data.Acid.TemplateHaskell

spec :: Spec
spec = do
    let name = mkName "foo"
        nameT = ConT name
        upperName = mkName "Foo"
        upperNameT = ConT upperName

    describe "makeEventInstance" $ do
        it "works with monomorphic types" $ do
            eventType <- runQ [t| Int -> Query Char () |]
            makeEventInstance name eventType
                `quoteShouldBe`
                    [d| instance QueryEvent $(return upperNameT) |]

        it "requires instances on polymorphic types" $ do
            let a = VarT (mkName "a")
                a' = return a
            eventType <- runQ [t| (Ord $(a')) => $(a') -> Update Char $(a') |]

            makeEventInstance name eventType
                `quoteShouldBe`
                    [d| instance (Ord $(a')) => UpdateEvent $(return upperNameT)
                    |]


    describe "analyseType" $ do
        it "can work with the Query type" $ do
            typ <- runQ [t| Int -> Query String Char |]

            analyseType name typ
                `shouldBe` TypeAnalysis
                    { tyvars = []
                    , context = []
                    , argumentTypes = [ConT ''Int]
                    , stateType = ConT ''String
                    , resultType = ConT ''Char
                    , isUpdate = False
                    }

        it "can work with the Update type" $ do
            typ <- runQ [t| Int -> Update String Char |]

            analyseType name typ
                `shouldBe` TypeAnalysis
                    { tyvars = []
                    , context = []
                    , argumentTypes = [ConT ''Int]
                    , stateType = ConT ''String
                    , resultType = ConT ''Char
                    , isUpdate = True
                    }

        it "can work with MonadReader" $ do
            typ <- runQ [t| forall m. (MonadReader Int m) => Int -> m () |]
            analyseType name typ
                `shouldBe` TypeAnalysis
                    { tyvars = []
                    , context = []
                    , argumentTypes = [ConT ''Int]
                    , stateType = ConT ''Int
                    , resultType = TupleT 0
                    , isUpdate = False
                    }

        it "can work with MonadState" $ do
            typ <- runQ [t| forall m. (MonadState Int m) => Int -> m () |]
            analyseType name typ
                `shouldBe` TypeAnalysis
                    { tyvars = []
                    , context = []
                    , argumentTypes = [ConT ''Int]
                    , stateType = ConT ''Int
                    , resultType = TupleT 0
                    , isUpdate = True
                    }

        it "can work with many type variables (note that eventCxts later rejects this)" $ do
            let m = mkName "m"
            typ <- runQ [t| (MonadReader Int $(varT m)) => Int -> Query Int ($(varT m) ()) |]
            analyseType name typ
                `shouldBe` TypeAnalysis
                    { tyvars = []
                    , context =
                        [ ConT ''MonadReader
                            `AppT` ConT ''Int
                            `AppT` VarT m
                        ]
                    , argumentTypes = [ConT ''Int]
                    , stateType = ConT ''Int
                    , resultType = VarT m `AppT` TupleT 0
                    , isUpdate = False
                    }

    describe "eventCxts" $ do
        let binders = []
            stateType = ConT ''Char
        it "rejects types with constrainted type variables unknown to state" $ do
            let predicate eventType =
                    evaluate
                        . force
                        . map show
                        $ eventCxts stateType binders name eventType
            eventType <- runQ [t| forall a. (Ord a) => Int -> Query Char a |]

            predicate eventType
                `shouldThrow`
                    anyErrorCall

        it "accepts types with unconstrained type variables" $ do
            eventType <- runQ [t| forall a. Int -> Query Char a |]

            eventCxts stateType binders name eventType
                `shouldBe`
                    []
        let x = mkName "x"

        it "accepts constrained type variables in the state" $ do
            let binders :: [TyVarBndrUnit]
#if MIN_VERSION_template_haskell(2,17,0)
                binders = [PlainTV (mkName "x") ()]
#else
                binders = [PlainTV (mkName "x")]
#endif
                stateType = ConT ''Maybe `AppT` VarT x
            eventType <- runQ [t| forall a. (Ord a) => Int -> Query (Maybe a) Int|]

            eventCxts stateType binders name eventType
                `shouldBe`
                    [ConT ''Ord `AppT` VarT x]

        it "can rename a polymorphic state" $ do
            eventType <- runQ [t| forall r m. (MonadReader r m, Ord r) => Int -> m Char |]
            eventCxts stateType binders name eventType
                `shouldBe`
                    [ConT ''Ord `AppT` ConT ''Char]


quoteShouldBe :: (Eq a, Show a) => Q a -> Q [a] -> Expectation
quoteShouldBe qa qb = do
    actual <- runQ qa
    [expected] <- runQ qb
    actual `shouldBe` expected