th-test-utils (empty) → 1.0.0

raw patch · 7 files changed

+368/−0 lines, 7 filesdep +basedep +tastydep +tasty-hunit

Dependencies added: base, tasty, tasty-hunit, template-haskell, th-test-utils, transformers

Files

CHANGELOG.md +7/−0
LICENSE +11/−0
README.md +44/−0
src/Language/Haskell/TH/TestUtils.hs +176/−0
test/Main.hs +36/−0
test/TH.hs +30/−0
th-test-utils.cabal +64/−0

+ CHANGELOG.md view

@@ -0,0 +1,7 @@+## Upcoming++## 1.0.0++Initial release:++* Add `tryQ`, `tryQErr`, `tryQErr'` functions

+ LICENSE view

@@ -0,0 +1,11 @@+Copyright 2019 LeapYear++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,44 @@+# th-test-utils++![CircleCI](https://img.shields.io/circleci/build/github/LeapYear/th-test-utils.svg)+![Hackage](https://img.shields.io/hackage/v/th-test-utils.svg)++This package contains utility functions for testing Template Haskell code.++Currently, this package only exposes a single function, `tryQ` (and derivatives),+that allows testing whether a given Template Haskell expression fails.++## Usage++```haskell+-- e.g. $(qConcat ["hello", "world"]) generates "helloworld" at compile time+qConcat :: [String] -> Q Exp+qConcat [] = fail "Cannot concat empty list"+qConcat xs = ...++-- e.g. [numberify| one |] generates `1` at compile time+numberify :: QuasiQuoter+numberify = ...+```++```haskell+-- example using tasty-hunit+main :: IO ()+main = defaultMain $ testGroup "my-project"+  [ testCase "qConcat 1" $+      $(tryQ $ qConcat ["hello", "world"]) @?= (Right "helloworld" :: Either String String)+  , testCase "qConcat 2" $+      $(tryQ $ qConcat [])                 @?= (Left "Cannot concat empty list" :: Either String String)+  , testCase "numberify 1" $+      $(tryQ $ quoteExp numberify "one")   @?= (Right 1 :: Either String Int)+  , testCase "numberify 2" $+      $(tryQ $ quoteExp numberify "foo")   @?= (Left "not a number" :: Either String Int)++  -- can also return error message as `Maybe String` or `String` (which errors+  -- if the function doesn't error)+  , testCase "numberify 3" $+      $(tryQErr $ quoteExp numberify "foo") @?= Just "not a number"+  , testCase "numberify 4" $+      $(tryQErr' $ quoteExp numberify "foo") @?= "not a number"+  ]+```

+ src/Language/Haskell/TH/TestUtils.hs view

@@ -0,0 +1,176 @@+{-|+Module      :  Language.Haskell.TH.TestUtils+Maintainer  :  Brandon Chinn <brandon@leapyear.io>+Stability   :  experimental+Portability :  portable++This module defines utilites for testing Template Haskell code.+-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell #-}++#if MIN_VERSION_base(4,9,0)+# define HAS_MONADFAIL 1+#endif++module Language.Haskell.TH.TestUtils+  ( -- * Error recovery+    -- $tryQ+    tryQ'+  , tryQ+  , tryQErr+  , tryQErr'+  ) where++import Control.Monad ((>=>))+import qualified Control.Monad.Fail as Fail+#if MIN_VERSION_template_haskell(2,13,0)+import Control.Monad.IO.Class (MonadIO)+#endif+import qualified Control.Monad.Trans.Class as Trans+import Control.Monad.Trans.Except (ExceptT, catchE, runExceptT, throwE)+import Control.Monad.Trans.State (StateT, put, runStateT)+import Language.Haskell.TH (Exp, Q, appE, runQ)+#if MIN_VERSION_template_haskell(2,12,0)+import qualified Language.Haskell.TH as TH+#endif+import Language.Haskell.TH.Syntax (Quasi(..), lift)++-- $tryQ+--+-- Unfortunately, there is no built-in way to get an error message of a Template Haskell+-- computation, since 'Language.Haskell.TH.recover' throws away the error message. If+-- 'Language.Haskell.TH.recover' was defined differently, we could maybe do:+--+-- > recover' :: (String -> Q a) -> Q a -> Q a+-- >+-- > spliceFail :: Q Exp+-- > spliceFail = fail "This splice fails"+-- >+-- > spliceInt :: Q Exp+-- > spliceInt = [| 1 |]+-- >+-- > test1 :: Either String Int+-- > test1 = $(recover' (pure . Left) $ Right <$> spliceFail) -- generates `Left "This splice fails"`+-- >+-- > test2 :: Either String Int+-- > test2 = $(recover' (pure . Left) $ Right <$> spliceInt) -- generates `Right 1`+--+-- But for now, we'll have to use 'tryQ':+--+-- > test1 :: Either String Int+-- > test1 = $(tryQ spliceFail) -- generates `Left "This splice fails"`+-- >+-- > test2 :: Either String Int+-- > test2 = $(tryQ spliceInt) -- generates `Right 1`+--+-- ref. https://ghc.haskell.org/trac/ghc/ticket/2340++newtype TryQ a = TryQ { unTryQ :: ExceptT () (StateT (Maybe String) Q) a }+  deriving+    ( Functor+    , Applicative+    , Monad+#if MIN_VERSION_template_haskell(2,13,0)+    , MonadIO+#endif+    )++liftQ :: Q a -> TryQ a+liftQ = TryQ . Trans.lift . Trans.lift++instance Fail.MonadFail TryQ where+  fail _ = TryQ $ throwE ()++instance Quasi TryQ where+  qNewName name = liftQ $ qNewName name++  qReport False msg = liftQ $ qReport False msg+  qReport True msg = TryQ . Trans.lift . put $ Just msg++  qRecover (TryQ handler) (TryQ action) = TryQ $ catchE action (const handler)+  qLookupName b name = liftQ $ qLookupName b name+  qReify name = liftQ $ qReify name+  qReifyFixity name = liftQ $ qReifyFixity name+  qReifyInstances name types = liftQ $ qReifyInstances name types+  qReifyRoles name = liftQ $ qReifyRoles name+  qReifyAnnotations ann = liftQ $ qReifyAnnotations ann+  qReifyModule m = liftQ $ qReifyModule m+  qReifyConStrictness name = liftQ $ qReifyConStrictness name+  qLocation = liftQ qLocation+  qRunIO m = liftQ $ qRunIO m+  qAddDependentFile fp = liftQ $ qAddDependentFile fp+  qAddTopDecls decs = liftQ $ qAddTopDecls decs+  qAddModFinalizer q = liftQ $ qAddModFinalizer q+  qGetQ = liftQ qGetQ+  qPutQ x = liftQ $ qPutQ x+  qIsExtEnabled ext = liftQ $ qIsExtEnabled ext+  qExtsEnabled = liftQ qExtsEnabled++#if MIN_VERSION_template_haskell(2,13,0)+  qAddCorePlugin s = liftQ $ qAddCorePlugin s+#endif++#if MIN_VERSION_template_haskell(2,14,0)+  qAddTempFile s = liftQ $ qAddTempFile s+  qAddForeignFilePath lang s = liftQ $ qAddForeignFilePath lang s+#elif MIN_VERSION_template_haskell(2,12,0)+  qAddForeignFile lang s = liftQ $ qAddForeignFile lang s+#endif++-- | Run the given Template Haskell computation, returning either an error message or the final+-- result.+tryQ' :: Q a -> Q (Either String a)+tryQ' = fmap cast . (`runStateT` Nothing) . runExceptT . unTryQ . runQ+  where+    cast (Left (), Nothing) = Left "Q monad failure"+    cast (Left (), Just msg) = Left msg+    cast (Right a, _) = Right a++-- | Run the given Template Haskell computation, returning a splicable expression that resolves+-- to 'Left' the error message or 'Right' the final result.+--+-- > -- Left "This splice fails"+-- > $(tryQ spliceFail) :: Either String Int+-- >+-- > -- Right 1+-- > $(tryQ spliceInt) :: Either String Int+tryQ :: Q Exp -> Q Exp+tryQ = tryQ' >=> either+  (appE (typeAppString [| Left |]) . lift)+  (appE (typeAppString [| Right |]) . pure)++-- | 'tryQ', except returns 'Just' the error message or 'Nothing' if the computation succeeded.+--+-- > -- Just "This splice fails"+-- > $(tryQErr spliceFail) :: Maybe String+-- >+-- > -- Nothing+-- > $(tryQErr spliceInt) :: Maybe String+tryQErr :: Q a -> Q Exp+tryQErr = tryQ' >=> either+  (appE (typeAppString [| Just |]) . lift)+  (const (typeAppString [| Nothing |]))++-- | 'tryQ', except returns the error message or fails if the computation succeeded.+--+-- > -- "This splice fails"+-- > $(tryQErr' spliceFail) :: String+-- >+-- > -- compile time error: "Q monad unexpectedly succeeded"+-- > $(tryQErr' spliceInt) :: String+tryQErr' :: Q a -> Q Exp+tryQErr' = tryQ' >=> either+  lift+  (const $ fail "Q monad unexpectedly succeeded")++{- Helpers -}++typeAppString :: Q Exp -> Q Exp+typeAppString expQ =+#if MIN_VERSION_template_haskell(2,12,0)+    TH.appTypeE expQ [t| String |]+#else+    expQ+#endif

+ test/Main.hs view

@@ -0,0 +1,36 @@+{-# LANGUAGE TemplateHaskell #-}++import Data.Void (Void)+import Test.Tasty+import Test.Tasty.HUnit++import Language.Haskell.TH.TestUtils+import TH++main :: IO ()+main = defaultMain $ testGroup "th-test-utils"+  [ testFirstConstrForType+  , testExplode+  ]++testFirstConstrForType :: TestTree+testFirstConstrForType = testGroup "firstConstrForType"+  [ testCase "tryQ Maybe" $+    $(tryQ $ firstConstrForType "Maybe") @?= (Right "Nothing" :: Either String String)+  , testCase "tryQErr Maybe" $+    $(tryQErr $ firstConstrForType "Maybe") @?= (Nothing :: Maybe String)+  , testCase "tryQ NonExistent" $+    $(tryQ $ firstConstrForType "NonExistent") @?= (Left "Type does not exist: NonExistent" :: Either String String)+  , testCase "tryQErr Show" $+    $(tryQErr $ firstConstrForType "Show") @?= Just "Not a data type: Show"+  , testCase "tryQErr' Void" $+    $(tryQErr' $ firstConstrForType "Void") @?= "Data type has no constructors: Void"+  ]++testExplode :: TestTree+testExplode = testGroup "explode"+  [ testCase "abc" $+    $(tryQ $ explode "abc") @?= (Right ["a", "b", "c"] :: Either String [String])+  , testCase "\"\"" $+    $(tryQ $ explode "") @?= (Left "Cannot explode empty string" :: Either String [String])+  ]

+ test/TH.hs view

@@ -0,0 +1,30 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}++module TH where++import Language.Haskell.TH+import Language.Haskell.TH.Syntax (lift)++firstConstrForType :: String -> ExpQ+firstConstrForType typeName = lookupTypeName typeName >>= \case+  Nothing -> fail $ "Type does not exist: " ++ typeName+  Just name -> reify name >>= \case+#if MIN_VERSION_template_haskell(2,11,0)+    TyConI (DataD _ _ _ _ cons _) -> firstConstr cons+    TyConI (NewtypeD _ _ _ _ con _) -> firstConstr [con]+#else+    TyConI (DataD _ _ _ cons _) -> firstConstr cons+    TyConI (NewtypeD _ _ _ con _) -> firstConstr [con]+#endif+    _ -> fail $ "Not a data type: " ++ typeName+  where+    firstConstr [] = fail $ "Data type has no constructors: " ++ typeName+    firstConstr (c:_) = lift . nameBase =<< case c of+      NormalC name _ -> pure name+      RecC name _ -> pure name+      _ -> fail $ "Weird constructor: " ++ typeName++explode :: String -> ExpQ+explode [] = fail "Cannot explode empty string"+explode xs = listE $ map (litE . stringL . (:[])) xs

+ th-test-utils.cabal view

@@ -0,0 +1,64 @@+cabal-version: >= 1.10++-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: 9cf4225c54ff62801b9655ef24f782ad7e797f7d169ded1b549120289000fc74++name:           th-test-utils+version:        1.0.0+synopsis:       Utility functions for testing Template Haskell code+description:    Utility functions for testing Template Haskell code, including+                functions for testing failures in the Q monad.+category:       Testing+homepage:       https://github.com/LeapYear/th-test-utils#readme+bug-reports:    https://github.com/LeapYear/th-test-utils/issues+author:         Brandon Chinn <brandon@leapyear.io>+maintainer:     Brandon Chinn <brandon@leapyear.io>+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/LeapYear/th-test-utils++library+  exposed-modules:+      Language.Haskell.TH.TestUtils+  other-modules:+      Paths_th_test_utils+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      base >=4.9 && <5+    , template-haskell >=2.11.1.0 && <2.15+    , transformers >=0.5.2 && <0.5.7+  if impl(ghc >= 8.0)+    ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances+  default-language: Haskell2010++test-suite th-test-utils-test+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      TH+      Paths_th_test_utils+  hs-source-dirs:+      test+  ghc-options: -Wall+  build-depends:+      base >=4.9 && <5+    , tasty >=0.11.3 && <1.3+    , tasty-hunit >=0.9.2 && <0.10.1+    , template-haskell >=2.11.1.0 && <2.15+    , th-test-utils+    , transformers >=0.5.2 && <0.5.7+  if impl(ghc >= 8.0)+    ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances+  default-language: Haskell2010