diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# 0.1 +* TODO: Update README.md with all libraries +* Initial commit diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Ryan Scott + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * 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. + + * Neither the name of Ryan Scott nor the names of other + 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 +OWNER 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,21 @@ +# `text-show-instances` [![Hackage version](https://img.shields.io/hackage/v/text-show-instances.svg)](http://hackage.haskell.org/package/text-show-instances) [![Build Status](https://travis-ci.org/RyanGlScott/text-show-instances.svg)](https://travis-ci.org/RyanGlScott/text-show-instances) + +`text-show-instances` is a supplemental library to [`text-show`](https://github.com/RyanGlScott/text-show) that provides additional `Show` instances for data types in common Haskell libraries not encompassed by `text-show`. Currently, `text-show-instances` covers these libraries: + +* [`containers`](http://hackage.haskell.org/package/containers) +* [`directory`](http://hackage.haskell.org/package/directory) +* [`hpc`](http://hackage.haskell.org/package/hpc) +* [`old-locale`](http://hackage.haskell.org/package/old-locale) +* [`old-time`](http://hackage.haskell.org/package/old-time) +* [`random`](http://hackage.haskell.org/package/random) +* [`semigroups`](http://hackage.haskell.org/package/semigroups) +* [`tagged`](http://hackage.haskell.org/package/tagged) +* [`template-haskell`](http://hackage.haskell.org/package/template-haskell) +* [`time`](http://hackage.haskell.org/package/time) +* [`transformers`](http://hackage.haskell.org/package/transformers) +* [`unix`](http://hackage.haskell.org/package/unix) +* [`unordered-containers`](http://hackage.haskell.org/package/unordered-containers) +* [`vector`](http://hackage.haskell.org/package/vector) +* [`xhtml`](http://hackage.haskell.org/package/xhtml) + +One can use these instances by importing `Text.Show.Text.Instances`. Alternatively, there are monomorphic versions of the `showb` function available in the other submodules of `Text.Show.Text`. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/include/inline.h b/include/inline.h new file mode 100644 --- /dev/null +++ b/include/inline.h @@ -0,0 +1,13 @@ +#ifndef INLINE_H +#define INLINE_H + +#define OPEN_PRAGMA {-# +#define CLOSE_PRAGMA #-} + +#if __GLASGOW_HASKELL__ >= 702 +#define INLINE_INST_FUN(F) OPEN_PRAGMA INLINE F CLOSE_PRAGMA +#else +#define INLINE_INST_FUN(F) +#endif + +#endif diff --git a/src/Text/Show/Text/Control.hs b/src/Text/Show/Text/Control.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Control.hs @@ -0,0 +1,14 @@ +{-| +Module: Text.Show.Text.Control +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Imports 'Show' instances for @Control@ modules. +-} +module Text.Show.Text.Control () where + +import Text.Show.Text.Control.Applicative.Trans () +import Text.Show.Text.Control.Monad.Trans () diff --git a/src/Text/Show/Text/Control/Applicative/Trans.hs b/src/Text/Show/Text/Control/Applicative/Trans.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Control/Applicative/Trans.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE CPP, OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Text.Show.Text.Control.Applicative.Trans +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for applicative functor transformers. + +/Since: 0.1/ +-} +module Text.Show.Text.Control.Applicative.Trans ( + showbBackwardsPrec + , showbLiftPrec + ) where + +import Control.Applicative.Backwards (Backwards(..)) +import Control.Applicative.Lift (Lift(..)) + +import Prelude hiding (Show) + +import Text.Show.Text (Show(showbPrec), Show1(showbPrec1), Builder, + showbUnary, showbUnary1) + +#include "inline.h" + +-- | Convert a 'Backwards' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbBackwardsPrec :: (Show1 f, Show a) => Int -> Backwards f a -> Builder +showbBackwardsPrec p (Backwards x) = showbUnary1 "Backwards" p x +{-# INLINE showbBackwardsPrec #-} + +-- | Convert a 'Lift' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbLiftPrec :: (Show1 f, Show a) => Int -> Lift f a -> Builder +showbLiftPrec p (Pure x) = showbUnary "Pure" p x +showbLiftPrec p (Other y) = showbUnary1 "Other" p y +{-# INLINE showbLiftPrec #-} + +instance (Show1 f, Show a) => Show (Backwards f a) where + showbPrec = showbBackwardsPrec + INLINE_INST_FUN(showbPrec) + +instance Show1 f => Show1 (Backwards f) where + showbPrec1 = showbBackwardsPrec + INLINE_INST_FUN(showbPrec1) + +instance (Show1 f, Show a) => Show (Lift f a) where + showbPrec = showbLiftPrec + INLINE_INST_FUN(showbPrec) + +instance Show1 f => Show1 (Lift f) where + showbPrec1 = showbLiftPrec + INLINE_INST_FUN(showbPrec1) diff --git a/src/Text/Show/Text/Control/Monad/Trans.hs b/src/Text/Show/Text/Control/Monad/Trans.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Control/Monad/Trans.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE CPP, OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-warnings-deprecations #-} +{-| +Module: Text.Show.Text.Control.Monad.Trans +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for monad transformers. + +/Since: 0.1/ +-} +module Text.Show.Text.Control.Monad.Trans ( + showbErrorTPrec + , showbExceptTPrec + , showbIdentityTPrec + , showbListTPrec + , showbMaybeTPrec + , showbWriterTLazyPrec + , showbWriterTStrictPrec + ) where + +import Control.Monad.Trans.Error (ErrorT(..)) +import Control.Monad.Trans.Except (ExceptT(..)) +import Control.Monad.Trans.Identity (IdentityT(..)) +import Control.Monad.Trans.List (ListT(..)) +import Control.Monad.Trans.Maybe (MaybeT(..)) +import qualified Control.Monad.Trans.Writer.Lazy as WL (WriterT(..)) +import qualified Control.Monad.Trans.Writer.Strict as WS (WriterT(..)) + +import Prelude hiding (Show) + +import Text.Show.Text (Show(showbPrec), Show1(showbPrec1), + Builder, showbUnary1) + +#include "inline.h" + +-- | Convert an 'ErrorT' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbErrorTPrec :: (Show e, Show1 m, Show a) => Int -> ErrorT e m a -> Builder +showbErrorTPrec p (ErrorT m) = showbUnary1 "ErrorT" p m +{-# INLINE showbErrorTPrec #-} + +-- | Convert an 'ExceptT' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbExceptTPrec :: (Show e, Show1 m, Show a) => Int -> ExceptT e m a -> Builder +showbExceptTPrec p (ExceptT m) = showbUnary1 "ExceptT" p m +{-# INLINE showbExceptTPrec #-} + +-- | Convert an 'IdentityT' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbIdentityTPrec :: (Show1 f, Show a) => Int -> IdentityT f a -> Builder +showbIdentityTPrec p (IdentityT m) = showbUnary1 "IdentityT" p m +{-# INLINE showbIdentityTPrec #-} + +-- | Convert a 'ListT' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbListTPrec :: (Show1 m, Show a) => Int -> ListT m a -> Builder +showbListTPrec p (ListT m) = showbUnary1 "ListT" p m +{-# INLINE showbListTPrec #-} + +-- | Convert a 'MaybeT' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbMaybeTPrec :: (Show1 m, Show a) => Int -> MaybeT m a -> Builder +showbMaybeTPrec p (MaybeT m) = showbUnary1 "MaybeT" p m +{-# INLINE showbMaybeTPrec #-} + +-- | Convert a lazy 'WL.WriterT' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbWriterTLazyPrec :: (Show w, Show1 m, Show a) => Int -> WL.WriterT w m a -> Builder +showbWriterTLazyPrec p (WL.WriterT m) = showbUnary1 "WriterT" p m +{-# INLINE showbWriterTLazyPrec #-} + +-- | Convert a strict 'WS.WriterT' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbWriterTStrictPrec :: (Show w, Show1 m, Show a) => Int -> WS.WriterT w m a -> Builder +showbWriterTStrictPrec p (WS.WriterT m) = showbUnary1 "WriterT" p m +{-# INLINE showbWriterTStrictPrec #-} + +instance (Show e, Show1 m, Show a) => Show (ErrorT e m a) where + showbPrec = showbErrorTPrec + INLINE_INST_FUN(showbPrec) + +instance (Show e, Show1 m) => Show1 (ErrorT e m) where + showbPrec1 = showbErrorTPrec + INLINE_INST_FUN(showbPrec1) + +instance (Show e, Show1 m, Show a) => Show (ExceptT e m a) where + showbPrec = showbExceptTPrec + INLINE_INST_FUN(showbPrec) + +instance (Show e, Show1 m) => Show1 (ExceptT e m) where + showbPrec1 = showbExceptTPrec + INLINE_INST_FUN(showbPrec1) + +instance (Show1 f, Show a) => Show (IdentityT f a) where + showbPrec = showbIdentityTPrec + INLINE_INST_FUN(showbPrec) + +instance Show1 f => Show1 (IdentityT f) where + showbPrec1 = showbIdentityTPrec + INLINE_INST_FUN(showbPrec1) + +instance (Show1 m, Show a) => Show (ListT m a) where + showbPrec = showbListTPrec + INLINE_INST_FUN(showbPrec) + +instance Show1 m => Show1 (ListT m) where + showbPrec1 = showbListTPrec + INLINE_INST_FUN(showbPrec1) + +instance (Show1 m, Show a) => Show (MaybeT m a) where + showbPrec = showbMaybeTPrec + INLINE_INST_FUN(showbPrec) + +instance Show1 m => Show1 (MaybeT m) where + showbPrec1 = showbMaybeTPrec + INLINE_INST_FUN(showbPrec1) + +instance (Show w, Show1 m, Show a) => Show (WL.WriterT w m a) where + showbPrec = showbWriterTLazyPrec + INLINE_INST_FUN(showbPrec) + +instance (Show w, Show1 m) => Show1 (WL.WriterT w m) where + showbPrec1 = showbWriterTLazyPrec + INLINE_INST_FUN(showbPrec1) + +instance (Show w, Show1 m, Show a) => Show (WS.WriterT w m a) where + showbPrec = showbWriterTStrictPrec + INLINE_INST_FUN(showbPrec) + +instance (Show w, Show1 m) => Show1 (WS.WriterT w m) where + showbPrec1 = showbWriterTStrictPrec + INLINE_INST_FUN(showbPrec1) diff --git a/src/Text/Show/Text/Data.hs b/src/Text/Show/Text/Data.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data.hs @@ -0,0 +1,20 @@ +{-| +Module: Text.Show.Text.Data +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Imports 'Show' instances for @Data@ modules. +-} +module Text.Show.Text.Data () where + +import Text.Show.Text.Data.Containers () +import Text.Show.Text.Data.Functor.Trans () +import Text.Show.Text.Data.List.NonEmpty () +import Text.Show.Text.Data.Semigroup () +import Text.Show.Text.Data.Tagged () +import Text.Show.Text.Data.Time () +import Text.Show.Text.Data.UnorderedContainers () +import Text.Show.Text.Data.Vector () diff --git a/src/Text/Show/Text/Data/Containers.hs b/src/Text/Show/Text/Data/Containers.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Containers.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE CPP, TemplateHaskell #-} +{-# OPTIONS -fno-warn-orphans #-} +{-| +Module: Text.Show.Text.Data.Containers +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for data types in the @containers@ library. + +/Since: 0.1/ +-} +module Text.Show.Text.Data.Containers ( + showbIntMapPrec + , showbIntSetPrec + , showbMapPrec + , showbSequencePrec + , showbViewLPrec + , showbViewRPrec + , showbSetPrec + , showbTreePrec + ) where + +import qualified Data.Foldable as F + +import qualified Data.IntMap as IM +import Data.IntMap (IntMap) +import qualified Data.IntSet as IS +import Data.IntSet (IntSet) +import qualified Data.Map as M +import Data.Map (Map) +import Data.Sequence (Seq, ViewL, ViewR) +import qualified Data.Set as Set +import Data.Set (Set) +import Data.Tree (Tree) + +import Prelude hiding (Show) + +import Text.Show.Text (Builder, Show(showbPrec), Show1(showbPrec1)) +import Text.Show.Text.Data.Integral () +import Text.Show.Text.Data.List () +import Text.Show.Text.Data.Tuple () +import Text.Show.Text.TH (deriveShowPragmas, defaultInlineShowbPrec) +import Text.Show.Text.Utils (showbUnaryList) + +#include "inline.h" + +-- | Convert an 'IntMap' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbIntMapPrec :: Show v => Int -> IntMap v -> Builder +showbIntMapPrec p = showbUnaryList p . IM.toList +{-# INLINE showbIntMapPrec #-} + +-- | Convert an 'IntSet' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbIntSetPrec :: Int -> IntSet -> Builder +showbIntSetPrec p = showbUnaryList p . IS.toList +{-# INLINE showbIntSetPrec #-} + +-- | Convert a 'Map' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbMapPrec :: (Show k, Show v) => Int -> Map k v -> Builder +showbMapPrec p = showbUnaryList p . M.toList +{-# INLINE showbMapPrec #-} + +-- | Convert a 'Sequence' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbSequencePrec :: Show a => Int -> Seq a -> Builder +showbSequencePrec p = showbUnaryList p . F.toList +{-# INLINE showbSequencePrec #-} + +-- | Convert a 'ViewL' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbViewLPrec :: Show a => Int -> ViewL a -> Builder +showbViewLPrec = showbPrec +{-# INLINE showbViewLPrec #-} + +-- | Convert a 'ViewR' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbViewRPrec :: Show a => Int -> ViewR a -> Builder +showbViewRPrec = showbPrec +{-# INLINE showbViewRPrec #-} + +-- | Convert a 'Set' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbSetPrec :: Show a => Int -> Set a -> Builder +showbSetPrec p = showbUnaryList p . Set.toList +{-# INLINE showbSetPrec #-} + +-- | Convert a 'Tree' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbTreePrec :: Show a => Int -> Tree a -> Builder +showbTreePrec = showbPrec +{-# INLINE showbTreePrec #-} + +instance Show v => Show (IntMap v) where + showbPrec = showbIntMapPrec + INLINE_INST_FUN(showbPrec) + +instance Show IntSet where + showbPrec = showbIntSetPrec + INLINE_INST_FUN(showbPrec) + +instance (Show k, Show v) => Show (Map k v) where + showbPrec = showbMapPrec + INLINE_INST_FUN(showbPrec) + +instance Show a => Show (Seq a) where + showbPrec = showbSequencePrec + INLINE_INST_FUN(showbPrec) + +instance Show a => Show (Set a) where + showbPrec = showbSetPrec + INLINE_INST_FUN(showbPrec) + +$(deriveShowPragmas defaultInlineShowbPrec ''ViewL) +$(deriveShowPragmas defaultInlineShowbPrec ''ViewR) +$(deriveShowPragmas defaultInlineShowbPrec ''Tree) + +instance Show1 IntMap where + showbPrec1 = showbIntMapPrec + INLINE_INST_FUN(showbPrec1) + +instance Show k => Show1 (Map k) where + showbPrec1 = showbMapPrec + INLINE_INST_FUN(showbPrec1) + +instance Show1 Seq where + showbPrec1 = showbSequencePrec + INLINE_INST_FUN(showbPrec1) + +instance Show1 ViewL where + showbPrec1 = showbViewLPrec + INLINE_INST_FUN(showbPrec1) + +instance Show1 ViewR where + showbPrec1 = showbViewRPrec + INLINE_INST_FUN(showbPrec1) + +instance Show1 Set where + showbPrec1 = showbSetPrec + INLINE_INST_FUN(showbPrec1) + +instance Show1 Tree where + showbPrec1 = showbTreePrec + INLINE_INST_FUN(showbPrec1) diff --git a/src/Text/Show/Text/Data/Functor/Trans.hs b/src/Text/Show/Text/Data/Functor/Trans.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Functor/Trans.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE CPP, OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Text.Show.Text.Data.Functor.Trans +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for functor transformers. Note that an instance for +the 'Identity' transformer is found in @text-show@, since it is a part of +@base-4.8.0.0@ and later. + +/Since: 0.1/ +-} +module Text.Show.Text.Data.Functor.Trans ( + showbComposePrec + , showbConstantPrec + , showbProductPrec + , showbReversePrec + , showbSumPrec + ) where + +import Data.Functor.Compose (Compose(..)) +import Data.Functor.Constant (Constant(..)) +import Data.Functor.Product (Product(..)) +import Data.Functor.Reverse (Reverse(..)) +import Data.Functor.Sum (Sum(..)) + +import Prelude hiding (Show) + +import Text.Show.Text (Show(showbPrec), Show1(showbPrec1), Builder, + showbUnary, showbUnary1, showbBinary1) + +#include "inline.h" + +-- kludge to get type with the same instances as g a +newtype Apply g a = Apply (g a) + +instance (Show1 g, Show a) => Show (Apply g a) where + showbPrec p (Apply x) = showbPrec1 p x + INLINE_INST_FUN(showbPrec) + +-- | Convert a 'Compose' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbComposePrec :: (Functor f, Show1 f, Show1 g, Show a) => Int -> Compose f g a -> Builder +showbComposePrec p (Compose x) = showbUnary1 "Compose" p $ fmap Apply x +{-# INLINE showbComposePrec #-} + +-- | Convert a 'Constant' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbConstantPrec :: Show a => Int -> Constant a b -> Builder +showbConstantPrec p (Constant x) = showbUnary "Constant" p x +{-# INLINE showbConstantPrec #-} + +-- | Convert a 'Product' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbProductPrec :: (Show1 f, Show1 g, Show a) => Int -> Product f g a -> Builder +showbProductPrec p (Pair x y) = showbBinary1 "Pair" p x y +{-# INLINE showbProductPrec #-} + +-- | Convert a 'Reverse' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbReversePrec :: (Show1 f, Show a) => Int -> Reverse f a -> Builder +showbReversePrec p (Reverse x) = showbUnary1 "Reverse" p x +{-# INLINE showbReversePrec #-} + +-- | Convert a 'Sum' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbSumPrec :: (Show1 f, Show1 g, Show a) => Int -> Sum f g a -> Builder +showbSumPrec p (InL x) = showbUnary1 "InL" p x +showbSumPrec p (InR y) = showbUnary1 "InR" p y +{-# INLINE showbSumPrec #-} + +instance (Functor f, Show1 f, Show1 g, Show a) => Show (Compose f g a) where + showbPrec = showbComposePrec + INLINE_INST_FUN(showbPrec) + +instance (Functor f, Show1 f, Show1 g) => Show1 (Compose f g) where + showbPrec1 = showbComposePrec + INLINE_INST_FUN(showbPrec1) + +instance Show a => Show (Constant a b) where + showbPrec = showbConstantPrec + INLINE_INST_FUN(showbPrec) + +instance Show a => Show1 (Constant a) where + showbPrec1 = showbConstantPrec + INLINE_INST_FUN(showbPrec1) + +instance (Show1 f, Show1 g, Show a) => Show (Product f g a) where + showbPrec = showbProductPrec + INLINE_INST_FUN(showbPrec) + +instance (Show1 f, Show1 g) => Show1 (Product f g) where + showbPrec1 = showbProductPrec + INLINE_INST_FUN(showbPrec1) + +instance (Show1 f, Show a) => Show (Reverse f a) where + showbPrec = showbReversePrec + INLINE_INST_FUN(showbPrec) + +instance Show1 f => Show1 (Reverse f) where + showbPrec1 = showbReversePrec + INLINE_INST_FUN(showbPrec1) + +instance (Show1 f, Show1 g, Show a) => Show (Sum f g a) where + showbPrec = showbSumPrec + INLINE_INST_FUN(showbPrec) + +instance (Show1 f, Show1 g) => Show1 (Sum f g) where + showbPrec1 = showbSumPrec + INLINE_INST_FUN(showbPrec1) diff --git a/src/Text/Show/Text/Data/List/NonEmpty.hs b/src/Text/Show/Text/Data/List/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/List/NonEmpty.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Text.Show.Text.Data.List.NonEmpty +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' function for 'NonEmpty' lists. + +/Since: 0.1/ +-} +module Text.Show.Text.Data.List.NonEmpty (showbNonEmptyPrec) where + +import Data.List.NonEmpty (NonEmpty) + +import Prelude hiding (Show) + +import Text.Show.Text (Show(showbPrec), Builder) +import Text.Show.Text.TH (deriveShowPragmas, defaultInlineShowbPrec) + +-- | Convert a 'NonEmpty' list to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbNonEmptyPrec :: Show a => Int -> NonEmpty a -> Builder +showbNonEmptyPrec = showbPrec +{-# INLINE showbNonEmptyPrec #-} + +$(deriveShowPragmas defaultInlineShowbPrec ''NonEmpty) diff --git a/src/Text/Show/Text/Data/Semigroup.hs b/src/Text/Show/Text/Data/Semigroup.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Semigroup.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Text.Show.Text.Data.Semigroup +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for @Semigroup@ data types. + +/Since: 0.1/ +-} +module Text.Show.Text.Data.Semigroup ( + showbMinPrec + , showbMaxPrec + , showbFirstPrec + , showbLastPrec + , showbWrappedMonoidPrec + , showbOptionPrec + ) where + +import Data.Semigroup (Min, Max, First, Last, WrappedMonoid, Option) + +import Prelude hiding (Show) + +import Text.Show.Text (Show(showbPrec), Builder) +import Text.Show.Text.TH (deriveShowPragmas, defaultInlineShowbPrec) + +-- | Convert a 'Min' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbMinPrec :: Show a => Int -> Min a -> Builder +showbMinPrec = showbPrec +{-# INLINE showbMinPrec #-} + +-- | Convert a 'Max' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbMaxPrec :: Show a => Int -> Max a -> Builder +showbMaxPrec = showbPrec +{-# INLINE showbMaxPrec #-} + +-- | Convert a 'First' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbFirstPrec :: Show a => Int -> First a -> Builder +showbFirstPrec = showbPrec +{-# INLINE showbFirstPrec #-} + +-- | Convert a 'Last' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbLastPrec :: Show a => Int -> Last a -> Builder +showbLastPrec = showbPrec +{-# INLINE showbLastPrec #-} + +-- | Convert a 'WrappedMonoid' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbWrappedMonoidPrec :: Show m => Int -> WrappedMonoid m -> Builder +showbWrappedMonoidPrec = showbPrec +{-# INLINE showbWrappedMonoidPrec #-} + +-- | Convert an 'Option' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbOptionPrec :: Show a => Int -> Option a -> Builder +showbOptionPrec = showbPrec +{-# INLINE showbOptionPrec #-} + +$(deriveShowPragmas defaultInlineShowbPrec ''Min) +$(deriveShowPragmas defaultInlineShowbPrec ''Max) +$(deriveShowPragmas defaultInlineShowbPrec ''First) +$(deriveShowPragmas defaultInlineShowbPrec ''Last) +$(deriveShowPragmas defaultInlineShowbPrec ''WrappedMonoid) +$(deriveShowPragmas defaultInlineShowbPrec ''Option) diff --git a/src/Text/Show/Text/Data/Tagged.hs b/src/Text/Show/Text/Data/Tagged.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Tagged.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE CPP, OverloadedStrings #-} +{-# OPTIONS -fno-warn-orphans #-} +{-| +Module: Text.Show.Text.Data.Tagged +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' function for 'Tagged' values. + +/Since: 0.1/ +-} +module Text.Show.Text.Data.Tagged (showbTaggedPrec) where + +import Data.Tagged (Tagged(..)) +import Prelude hiding (Show) +import Text.Show.Text (Show(showbPrec), Show1(showbPrec1), + Builder, showbUnary) + +#include "inline.h" + +-- | Convert a 'Tagged' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbTaggedPrec :: Show b => Int -> Tagged s b -> Builder +showbTaggedPrec p (Tagged b) = showbUnary "Tagged" p b +{-# INLINE showbTaggedPrec #-} + +instance Show b => Show (Tagged s b) where + showbPrec = showbTaggedPrec + INLINE_INST_FUN(showbPrec) + +instance Show1 (Tagged s) where + showbPrec1 = showbTaggedPrec + INLINE_INST_FUN(showbPrec1) diff --git a/src/Text/Show/Text/Data/Time.hs b/src/Text/Show/Text/Data/Time.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Time.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE CPP, OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Text.Show.Text.Data.Time +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for data types in the @time@ library. + +/Since: 0.1/ +-} +module Text.Show.Text.Data.Time ( + showbDay + , showbDiffTime + , showbUTCTime + , showbNominalDiffTime + , showbAbsoluteTime + , showbTimeZone + , showbTimeOfDay + , showbLocalTime + , showbZonedTime + ) where + +import Data.Fixed (Pico) +import Data.Time.Calendar (Day, toGregorian) +import Data.Time.Clock (DiffTime, UTCTime, NominalDiffTime) +import Data.Time.Clock.TAI (AbsoluteTime, taiToUTCTime) +import Data.Time.Format (NumericPadOption) +import Data.Time.LocalTime (TimeZone(..), TimeOfDay(..), LocalTime(..), ZonedTime(..), + utc, utcToLocalTime, utcToZonedTime) + +import Prelude hiding (Show) + +import Text.Show.Text (Builder, Show(showb), fromString, + lengthB, replicateB, showbSpace, + FromStringShow(..)) +import Text.Show.Text.Data.Fixed (showbFixed) +import Text.Show.Text.Data.Integral () +import Text.Show.Text.Utils ((<>), s) + +#include "inline.h" + +-- | Convert a 'Day' into a 'Builder'. +-- +-- /Since: 0.1/ +showbDay :: Day -> Builder +showbDay = showbGregorian +{-# INLINE showbDay #-} + +-- | Convert a 'DiffTime' into a 'Builder'. +-- +-- /Since: 0.1/ +showbDiffTime :: DiffTime -> Builder +showbDiffTime = showb . FromStringShow +{-# INLINE showbDiffTime #-} + +-- | Convert a 'UTCTime' into a 'Builder'. +-- +-- /Since: 0.1/ +showbUTCTime :: UTCTime -> Builder +showbUTCTime = showb . utcToZonedTime utc +{-# INLINE showbUTCTime #-} + +-- | Convert a 'NominalDiffTime' into a 'Builder'. +-- +-- /Since: 0.1/ +showbNominalDiffTime :: NominalDiffTime -> Builder +showbNominalDiffTime = showb . FromStringShow +{-# INLINE showbNominalDiffTime #-} + +-- | Convert a 'AbsoluteTime' into a 'Builder'. +-- +-- /Since: 0.1/ +showbAbsoluteTime :: AbsoluteTime -> Builder +showbAbsoluteTime t = showbLocalTime (utcToLocalTime utc $ taiToUTCTime (const 0) t) + <> " TAI" -- ugly, but standard apparently +{-# INLINE showbAbsoluteTime #-} + +-- | Convert a 'TimeZone' into a 'Builder'. +-- +-- /Since: 0.1/ +showbTimeZone :: TimeZone -> Builder +showbTimeZone zone@(TimeZone _ _ "") = timeZoneOffsetBuilder zone +showbTimeZone (TimeZone _ _ name) = fromString name +{-# INLINE showbTimeZone #-} + +-- | Convert a 'TimeOfDay' into a 'Builder'. +-- +-- /Since: 0.1/ +showbTimeOfDay :: TimeOfDay -> Builder +showbTimeOfDay (TimeOfDay h m sec) = showb2 zeroOpt h + <> s ':' + <> showb2 zeroOpt m + <> s ':' + <> showb2Fixed zeroOpt sec +{-# INLINE showbTimeOfDay #-} + +-- | Convert a 'LocalTime' into a 'Builder'. +-- +-- /Since: 0.1/ +showbLocalTime :: LocalTime -> Builder +showbLocalTime (LocalTime d t) = showbGregorian d <> showbSpace <> showb t +{-# INLINE showbLocalTime #-} + +-- | Convert a 'ZonedTime' into a 'Builder'. +-- +-- /Since: 0.1/ +showbZonedTime :: ZonedTime -> Builder +showbZonedTime (ZonedTime t zone) = showb t <> showbSpace <> showb zone +{-# INLINE showbZonedTime #-} + +pad1 :: NumericPadOption -> Builder -> Builder +pad1 (Just c) b = s c <> b +pad1 _ b = b +{-# INLINE pad1 #-} + +padN :: Int -> Char -> Builder -> Builder +padN i _ b | i <= 0 = b +padN i c b = replicateB (fromIntegral i) (s c) <> b +{-# INLINE padN #-} + +showb2 :: (Num t, Ord t, Show t) => NumericPadOption -> t -> Builder +showb2 = showbPaddedMin 2 +{-# INLINE showb2 #-} + +showb2Fixed :: NumericPadOption -> Pico -> Builder +showb2Fixed opt x | x < 10 = pad1 opt $ showbFixed True x +showb2Fixed _ x = showbFixed True x +{-# INLINE showb2Fixed #-} + +showb4 :: (Num t, Ord t, Show t) => NumericPadOption -> t -> Builder +showb4 = showbPaddedMin 4 +{-# INLINE showb4 #-} + +showbGregorian :: Day -> Builder +showbGregorian date = showb4 zeroOpt y + <> s '-' + <> showb2 zeroOpt m + <> s '-' + <> showb2 zeroOpt d + where + (y,m,d) = toGregorian date +{-# INLINE showbGregorian #-} + +showbPaddedMin :: (Num t, Ord t, Show t) => Int -> NumericPadOption -> t -> Builder +showbPaddedMin _ Nothing i = showb i +showbPaddedMin pl opt i | i < 0 = s '-' <> showbPaddedMin pl opt (negate i) +showbPaddedMin pl (Just c) i = + let b = showb i + in padN (pl - fromIntegral (lengthB b)) c b +{-# INLINE showbPaddedMin #-} + +showbT :: NumericPadOption -> Int -> Builder +showbT opt t = showb4 opt ((div t 60) * 100 + (mod t 60)) +{-# INLINE showbT #-} + +timeZoneOffsetBuilder' :: NumericPadOption -> TimeZone -> Builder +timeZoneOffsetBuilder' opt (TimeZone t _ _) | t < 0 = s '-' <> showbT opt (negate t) +timeZoneOffsetBuilder' opt (TimeZone t _ _) = s '+' <> showbT opt t +{-# INLINE timeZoneOffsetBuilder' #-} + +timeZoneOffsetBuilder :: TimeZone -> Builder +timeZoneOffsetBuilder = timeZoneOffsetBuilder' $ Just '0' +{-# INLINE timeZoneOffsetBuilder #-} + +zeroOpt :: NumericPadOption +zeroOpt = Just '0' +{-# INLINE zeroOpt #-} + +instance Show Day where + showb = showbDay + INLINE_INST_FUN(showb) + +instance Show DiffTime where + showb = showbDiffTime + INLINE_INST_FUN(showb) + +instance Show UTCTime where + showb = showbUTCTime + INLINE_INST_FUN(showb) + +instance Show NominalDiffTime where + showb = showbNominalDiffTime + INLINE_INST_FUN(showb) + +instance Show AbsoluteTime where + showb = showbAbsoluteTime + INLINE_INST_FUN(showb) + +instance Show TimeZone where + showb = showbTimeZone + INLINE_INST_FUN(showb) + +instance Show TimeOfDay where + showb = showbTimeOfDay + INLINE_INST_FUN(showb) + +instance Show LocalTime where + showb = showbLocalTime + INLINE_INST_FUN(showb) + +instance Show ZonedTime where + showb = showbZonedTime + INLINE_INST_FUN(showb) diff --git a/src/Text/Show/Text/Data/UnorderedContainers.hs b/src/Text/Show/Text/Data/UnorderedContainers.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/UnorderedContainers.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Text.Show.Text.Data.UnorderedContainers +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for 'HashMap's and 'HashSet's. + +/Since: 0.1/ +-} +module Text.Show.Text.Data.UnorderedContainers (showbHashMapPrec, showbHashSetPrec) where + +import qualified Data.HashMap.Lazy as HM (toList) +import Data.HashMap.Lazy (HashMap) +import qualified Data.HashSet as HS (toList) +import Data.HashSet (HashSet) + +import Prelude hiding (Show) + +import Text.Show.Text (Show(showbPrec), Show1(showbPrec1), Builder) +import Text.Show.Text.Utils (showbUnaryList) + +#include "inline.h" + +-- | Convert a 'HashMap' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbHashMapPrec :: (Show k, Show v) => Int -> HashMap k v -> Builder +showbHashMapPrec p = showbUnaryList p . HM.toList +{-# INLINE showbHashMapPrec #-} + +-- | Convert a 'HashSet' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbHashSetPrec :: Show a => Int -> HashSet a -> Builder +showbHashSetPrec p = showbUnaryList p . HS.toList +{-# INLINE showbHashSetPrec #-} + +instance (Show k, Show v) => Show (HashMap k v) where + showbPrec = showbHashMapPrec + INLINE_INST_FUN(showbPrec) + +instance Show a => Show (HashSet a) where + showbPrec = showbHashSetPrec + INLINE_INST_FUN(showbPrec) + +instance Show k => Show1 (HashMap k) where + showbPrec1 = showbHashMapPrec + INLINE_INST_FUN(showbPrec1) + +instance Show1 HashSet where + showbPrec1 = showbHashSetPrec + INLINE_INST_FUN(showbPrec1) diff --git a/src/Text/Show/Text/Data/Vector.hs b/src/Text/Show/Text/Data/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Data/Vector.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE CPP, TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Text.Show.Text.Data.Vector +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for @Vector@ types. + +/Since: 0.1/ +-} +module Text.Show.Text.Data.Vector ( + showbVectorPrec + , showbVectorGenericPrec + , showbVectorPrimitivePrec + , showbVectorStorablePrec + , showbVectorUnboxedPrec + , showbSizePrec + ) where + +import qualified Data.Vector as B (Vector) +import Data.Vector.Fusion.Stream.Size (Size) +import qualified Data.Vector.Generic as G (Vector) +import Data.Vector.Generic (toList) +import qualified Data.Vector.Primitive as P (Vector) +import Data.Vector.Primitive (Prim) +import qualified Data.Vector.Storable as S (Vector) +import qualified Data.Vector.Unboxed as U (Vector) +import Data.Vector.Unboxed (Unbox) + +import Foreign.Storable (Storable) + +import Prelude hiding (Show) + +import Text.Show.Text (Show(showbPrec), Show1(showbPrec1), Builder) +import Text.Show.Text.TH (deriveShowPragmas, defaultInlineShowbPrec) +import Text.Show.Text.Utils (showbUnaryList) + +#include "inline.h" + +-- | Convert a boxed 'B.Vector' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbVectorPrec :: Show a => Int -> B.Vector a -> Builder +showbVectorPrec = showbVectorGenericPrec +{-# INLINE showbVectorPrec #-} + +-- | Convert a generic 'G.Vector' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbVectorGenericPrec :: (G.Vector v a, Show a) => Int -> v a -> Builder +showbVectorGenericPrec p = showbUnaryList p . toList +{-# INLINE showbVectorGenericPrec #-} + +-- | Convert a primitive 'P.Vector' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbVectorPrimitivePrec :: (Show a, Prim a) => Int -> P.Vector a -> Builder +showbVectorPrimitivePrec = showbVectorGenericPrec +{-# INLINE showbVectorPrimitivePrec #-} + +-- | Convert a storable 'S.Vector' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbVectorStorablePrec :: (Show a, Storable a) => Int -> S.Vector a -> Builder +showbVectorStorablePrec = showbVectorGenericPrec +{-# INLINE showbVectorStorablePrec #-} + +-- | Convert an unboxed 'U.Vector' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbVectorUnboxedPrec :: (Show a, Unbox a) => Int -> U.Vector a -> Builder +showbVectorUnboxedPrec = showbVectorGenericPrec +{-# INLINE showbVectorUnboxedPrec #-} + +-- | Convert a 'Size' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbSizePrec :: Int -> Size -> Builder +showbSizePrec = showbPrec +{-# INLINE showbSizePrec #-} + +instance Show a => Show (B.Vector a) where + showbPrec = showbVectorPrec + INLINE_INST_FUN(showbPrec) + +instance (Show a, Prim a) => Show (P.Vector a) where + showbPrec = showbVectorPrimitivePrec + INLINE_INST_FUN(showbPrec) + +instance (Show a, Storable a) => Show (S.Vector a) where + showbPrec = showbVectorStorablePrec + INLINE_INST_FUN(showbPrec) + +instance (Show a, Unbox a) => Show (U.Vector a) where + showbPrec = showbVectorUnboxedPrec + INLINE_INST_FUN(showbPrec) + +instance Show1 B.Vector where + showbPrec1 = showbVectorPrec + INLINE_INST_FUN(showbPrec1) + +$(deriveShowPragmas defaultInlineShowbPrec ''Size) diff --git a/src/Text/Show/Text/Graphics.hs b/src/Text/Show/Text/Graphics.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Graphics.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE CPP #-} +{-| +Module: Text.Show.Text.Graphics +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Imports 'Show' instances for @Graphics@ modules. +-} +module Text.Show.Text.Graphics () where + +#if defined(mingw32_HOST_OS) +import Text.Show.Text.Graphics.Win32 () +#endif diff --git a/src/Text/Show/Text/Graphics/Win32.hs b/src/Text/Show/Text/Graphics/Win32.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Graphics/Win32.hs diff --git a/src/Text/Show/Text/Instances.hs b/src/Text/Show/Text/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Instances.hs @@ -0,0 +1,20 @@ +{-| +Module: Text.Show.Text.Instances +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Additional @Show@ instances not provided by @text-show@. + +/Since: 0.1/ +-} +module Text.Show.Text.Instances () where + +import Text.Show.Text.Data () +import Text.Show.Text.Graphics () +import Text.Show.Text.Language () +import Text.Show.Text.System () +import Text.Show.Text.Text () +import Text.Show.Text.Trace () diff --git a/src/Text/Show/Text/Language.hs b/src/Text/Show/Text/Language.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Language.hs @@ -0,0 +1,13 @@ +{-| +Module: Text.Show.Text.Language +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Imports 'Show' instances for @Language@ modules. +-} +module Text.Show.Text.Language () where + +import Text.Show.Text.Language.Haskell.TH () diff --git a/src/Text/Show/Text/Language/Haskell/TH.hs b/src/Text/Show/Text/Language/Haskell/TH.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Language/Haskell/TH.hs @@ -0,0 +1,551 @@ +{-# LANGUAGE CPP, TemplateHaskell #-} +#if !(MIN_VERSION_template_haskell(2,10,0)) +{-# LANGUAGE MagicHash #-} +#endif +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Text.Show.Text.Language.Haskell.TH +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for data types in the @template-haskell@ library. + +/Since: 0.1/ +-} +module Text.Show.Text.Language.Haskell.TH ( +#if MIN_VERSION_template_haskell(2,9,0) + showbAnnLookupPrec + , showbAnnTargetPrec, +#endif + showbBodyPrec + , showbCallconv +#if MIN_VERSION_template_haskell(2,5,0) && !(MIN_VERSION_template_haskell(2,7,0)) + , showbClassInstancePrec +#endif + , showbClausePrec + , showbConPrec + , showbDecPrec + , showbExpPrec + , showbFamFlavour + , showbFixityPrec + , showbFixityDirection + , showbForeignPrec + , showbFunDepPrec + , showbGuardPrec + , showbInfoPrec +#if MIN_VERSION_template_haskell(2,8,0) + , showbInline +#else + , showbInlineSpecPrec +#endif +#if !(MIN_VERSION_template_haskell(2,8,0)) + , showbKindPrec +#endif + , showbLitPrec + , showbLocPrec + , showbMatchPrec + , showbModNamePrec +#if MIN_VERSION_template_haskell(2,9,0) + , showbModulePrec + , showbModuleInfoPrec +#endif + , showbName + , showbName' + , showbOccNamePrec + , showbPatPrec +#if MIN_VERSION_template_haskell(2,8,0) + , showbPhasesPrec +#endif + , showbPkgNamePrec + , showbPragmaPrec +#if !(MIN_VERSION_template_haskell(2,10,0)) + , showbPredPrec +#endif + , showbRangePrec +#if MIN_VERSION_template_haskell(2,9,0) + , showbRole +#endif +#if MIN_VERSION_template_haskell(2,8,0) + , showbRuleBndrPrec + , showbRuleMatch +#endif + , showbSafety + , showbStmtPrec + , showbStrict +#if MIN_VERSION_template_haskell(2,8,0) + , showbTyLitPrec +#endif + , showbTypePrec + , showbTyVarBndrPrec +#if MIN_VERSION_template_haskell(2,9,0) + , showbTySynEqnPrec +#endif + ) where + +import Data.Char (isAlpha) +import Data.Maybe (fromJust) +import qualified Data.Text.Lazy as TL (Text, dropWhile, null, tail) +import Data.Text.Lazy (uncons) + +#if !(MIN_VERSION_template_haskell(2,10,0)) +import GHC.Exts (Int(I#)) +#endif + +import Language.Haskell.TH.Syntax + +import Prelude hiding (Show) + +import Text.Show.Text (Show(showb, showbPrec), Builder, + fromString, toLazyText) +import Text.Show.Text.Data.Integral (showbIntPrec) +import Text.Show.Text.TH (deriveShowPragmas, defaultInlineShowb, + defaultInlineShowbPrec) +import Text.Show.Text.Utils ((<>), s) + +#include "inline.h" + +-- | Convert a 'Body' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbBodyPrec :: Int -> Body -> Builder +showbBodyPrec = showbPrec +{-# INLINE showbBodyPrec #-} + +-- | Convert a 'Callconv' to a 'Builder'. +-- +-- /Since: 0.1/ +showbCallconv :: Callconv -> Builder +showbCallconv = showb +{-# INLINE showbCallconv #-} + +-- | Convert a 'Clause' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbClausePrec :: Int -> Clause -> Builder +showbClausePrec = showbPrec +{-# INLINE showbClausePrec #-} + +-- | Convert a 'Con' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbConPrec :: Int -> Con -> Builder +showbConPrec = showbPrec +{-# INLINE showbConPrec #-} + +-- | Convert a 'Dec' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbDecPrec :: Int -> Dec -> Builder +showbDecPrec = showbPrec +{-# INLINE showbDecPrec #-} + +-- | Convert an 'Exp' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbExpPrec :: Int -> Exp -> Builder +showbExpPrec = showbPrec +{-# INLINE showbExpPrec #-} + +-- | Convert a 'FamFlavour' to a 'Builder'. +-- +-- /Since: 0.1/ +showbFamFlavour :: FamFlavour -> Builder +showbFamFlavour = showb +{-# INLINE showbFamFlavour #-} + +-- | Convert a 'Fixity' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbFixityPrec :: Int -> Fixity -> Builder +showbFixityPrec = showbPrec +{-# INLINE showbFixityPrec #-} + +-- | Convert a 'FixityDirection' to a 'Builder'. +-- +-- /Since: 0.1/ +showbFixityDirection :: FixityDirection -> Builder +showbFixityDirection = showb +{-# INLINE showbFixityDirection #-} + +-- | Convert a 'Foreign' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbForeignPrec :: Int -> Foreign -> Builder +showbForeignPrec = showbPrec +{-# INLINE showbForeignPrec #-} + +-- | Convert a 'FunDep' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbFunDepPrec :: Int -> FunDep -> Builder +showbFunDepPrec = showbPrec +{-# INLINE showbFunDepPrec #-} + +-- | Convert a 'Guard' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbGuardPrec :: Int -> Guard -> Builder +showbGuardPrec = showbPrec +{-# INLINE showbGuardPrec #-} + +-- | Convert an 'Info' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbInfoPrec :: Int -> Info -> Builder +showbInfoPrec = showbPrec +{-# INLINE showbInfoPrec #-} + +-- | Convert a 'Lit' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbLitPrec :: Int -> Dec -> Builder +showbLitPrec = showbPrec +{-# INLINE showbLitPrec #-} + +-- | Convert a 'Loc' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbLocPrec :: Int -> Loc -> Builder +showbLocPrec = showbPrec +{-# INLINE showbLocPrec #-} + +-- | Convert a 'Match' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbMatchPrec :: Int -> Match -> Builder +showbMatchPrec = showbPrec +{-# INLINE showbMatchPrec #-} + +-- | Convert a 'ModName' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbModNamePrec :: Int -> ModName -> Builder +showbModNamePrec = showbPrec +{-# INLINE showbModNamePrec #-} + +-- | Convert a 'Name' to a 'Builder'. +-- +-- /Since: 0.1/ +showbName :: Name -> Builder +showbName = showbName' Alone +{-# INLINE showbName #-} + +-- | Convert a 'Name' to a 'Builder' with the given 'NameIs' settings. +-- +-- /Since: 0.1/ +showbName' :: NameIs -> Name -> Builder +showbName' ni nm = case ni of + Alone -> nms + Applied + | pnam -> nms + | otherwise -> s '(' <> nms <> s ')' + Infix + | pnam -> s '`' <> nms <> s '`' + | otherwise -> nms + where + -- For now, we make the NameQ and NameG print the same, even though + -- NameQ is a qualified name (so what it means depends on what the + -- current scope is), and NameG is an original name (so its meaning + -- should be independent of what's in scope. + -- We may well want to distinguish them in the end. + -- Ditto NameU and NameL + nms :: Builder + nms = case nm of + Name occ NameS -> occB occ + Name occ (NameQ m) -> modB m <> s '.' <> occB occ + Name occ (NameG _ _ m) -> modB m <> s '.' <> occB occ + Name occ (NameU u) -> occB occ <> s '_' <> showbIntPrec 0 (mkInt u) + Name occ (NameL u) -> occB occ <> s '_' <> showbIntPrec 0 (mkInt u) + +#if MIN_VERSION_template_haskell(2,10,0) + mkInt = id +#else + mkInt i# = I# i# +#endif + + occB :: OccName -> Builder + occB = fromString . occString + + modB :: ModName -> Builder + modB = fromString . modString + + pnam :: Bool + pnam = classify $ toLazyText nms + + -- True if we are function style, e.g. f, [], (,) + -- False if we are operator style, e.g. +, :+ + classify :: TL.Text -> Bool + classify t + | TL.null t = False -- shouldn't happen; . operator is handled below + | otherwise = case fromJust $ uncons t of + (x, xs) -> if isAlpha x || (x `elem` "_[]()") + then let t' = TL.dropWhile (/= '.') xs + in if TL.null t' + then True + else classify $ TL.tail t' + else False + + +-- | Convert an 'OccName' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbOccNamePrec :: Int -> OccName -> Builder +showbOccNamePrec = showbPrec +{-# INLINE showbOccNamePrec #-} + +-- | Convert a 'Pat' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbPatPrec :: Int -> Pat -> Builder +showbPatPrec = showbPrec +{-# INLINE showbPatPrec #-} + +-- | Convert a 'PkgName' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbPkgNamePrec :: Int -> PkgName -> Builder +showbPkgNamePrec = showbPrec +{-# INLINE showbPkgNamePrec #-} + +-- | Convert a 'Pragma' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbPragmaPrec :: Int -> Pragma -> Builder +showbPragmaPrec = showbPrec +{-# INLINE showbPragmaPrec #-} + +-- | Convert a 'Range' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbRangePrec :: Int -> Range -> Builder +showbRangePrec = showbPrec +{-# INLINE showbRangePrec #-} + +-- | Convert a 'Safety' to a 'Builder'. +-- +-- /Since: 0.1/ +showbSafety :: Safety -> Builder +showbSafety = showb +{-# INLINE showbSafety #-} + +-- | Convert a 'Stmt' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbStmtPrec :: Int -> Stmt -> Builder +showbStmtPrec = showbPrec +{-# INLINE showbStmtPrec #-} + +-- | Convert a 'Strict' to a 'Builder'. +-- +-- /Since: 0.1/ +showbStrict :: Strict -> Builder +showbStrict = showb +{-# INLINE showbStrict #-} + +-- | Convert a 'Type' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbTypePrec :: Int -> Type -> Builder +showbTypePrec = showbPrec +{-# INLINE showbTypePrec #-} + +-- | Convert a 'TyVarBndr' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbTyVarBndrPrec :: Int -> TyVarBndr -> Builder +showbTyVarBndrPrec = showbPrec +{-# INLINE showbTyVarBndrPrec #-} + +#if MIN_VERSION_template_haskell(2,5,0) && !(MIN_VERSION_template_haskell(2,7,0)) +-- | Convert a 'ClassInstance' to a 'Builder' with the given precedence. +-- This function is only available with @template-haskell@ 2.5.0.0 or 2.6.0.0. +-- +-- /Since: 0.1/ +showbClassInstancePrec :: Int -> ClassInstance -> Builder +showbClassInstancePrec = showbPrec +{-# INLINE showbClassInstancePrec #-} +#endif + +#if MIN_VERSION_template_haskell(2,8,0) +-- | Convert an 'Inline' to a 'Builder'. +-- This function is only available with @template-haskell-2.8.0.0@ or later. +-- +-- /Since: 0.1/ +showbInline :: Inline -> Builder +showbInline = showb +{-# INLINE showbInline #-} + +-- | Convert a 'Phases' to a 'Builder' with the given precedence. +-- This function is only available with @template-haskell-2.8.0.0@ or later. +-- +-- /Since: 0.1/ +showbPhasesPrec :: Int -> Phases -> Builder +showbPhasesPrec = showbPrec +{-# INLINE showbPhasesPrec #-} + +-- | Convert a 'RuleMatch' to a 'Builder'. +-- This function is only available with @template-haskell-2.8.0.0@ or later. +-- +-- /Since: 0.1/ +showbRuleMatch :: RuleMatch -> Builder +showbRuleMatch = showb +{-# INLINE showbRuleMatch #-} + +-- | Convert a 'RuleBndr' to a 'Builder' with the given precedence. +-- This function is only available with @template-haskell-2.8.0.0@ or later. +-- +-- /Since: 0.1/ +showbRuleBndrPrec :: Int -> RuleBndr -> Builder +showbRuleBndrPrec = showbPrec +{-# INLINE showbRuleBndrPrec #-} + +-- | Convert a 'TyLit' to a 'Builder' with the given precedence. +-- This function is only available with @template-haskell-2.8.0.0@ or later. +-- +-- /Since: 0.1/ +showbTyLitPrec :: Int -> TyLit -> Builder +showbTyLitPrec = showbPrec +{-# INLINE showbTyLitPrec #-} +#else +-- | Convert an 'InlineSpec' to a 'Builder' with the given precedence. +-- This function is only available with @template-haskell-2.7.0.0@ or earlier. +-- +-- /Since: 0.1/ +showbInlineSpecPrec :: Int -> InlineSpec -> Builder +showbInlineSpecPrec = showbPrec +{-# INLINE showbInlineSpecPrec #-} + +-- | Convert a 'Kind' to a 'Builder' with the given precedence. +-- This function is only available with @template-haskell-2.7.0.0@ or earlier, as +-- 'Kind' is a type synonym for 'Type' in @template-haskell-2.8.0.0@ or later. +-- +-- /Since: 0.1/ +showbKindPrec :: Int -> Kind -> Builder +showbKindPrec = showbPrec +{-# INLINE showbKindPrec #-} +#endif + +#if MIN_VERSION_template_haskell(2,9,0) +-- | Convert an 'AnnLookup' to a 'Builder' with the given precedence. +-- This function is only available with @template-haskell-2.9.0.0@ or later. +-- +-- /Since: 0.1/ +showbAnnLookupPrec :: Int -> AnnLookup -> Builder +showbAnnLookupPrec = showbPrec +{-# INLINE showbAnnLookupPrec #-} + +-- | Convert an 'AnnTarget' to a 'Builder' with the given precedence. +-- This function is only available with @template-haskell-2.9.0.0@ or later. +-- +-- /Since: 0.1/ +showbAnnTargetPrec :: Int -> AnnTarget -> Builder +showbAnnTargetPrec = showbPrec +{-# INLINE showbAnnTargetPrec #-} + +-- | Convert a 'Module' to a 'Builder' with the given precedence. +-- This function is only available with @template-haskell-2.9.0.0@ or later. +-- +-- /Since: 0.1/ +showbModulePrec :: Int -> Module -> Builder +showbModulePrec = showbPrec +{-# INLINE showbModulePrec #-} + +-- | Convert a 'ModuleInfo' to a 'Builder' with the given precedence. +-- This function is only available with @template-haskell-2.9.0.0@ or later. +-- +-- /Since: 0.1/ +showbModuleInfoPrec :: Int -> ModuleInfo -> Builder +showbModuleInfoPrec = showbPrec +{-# INLINE showbModuleInfoPrec #-} + +-- | Convert a 'Role' to a 'Builder'. +-- This function is only available with @template-haskell-2.9.0.0@ or later. +-- +-- /Since: 0.1/ +showbRole :: Role -> Builder +showbRole = showb +{-# INLINE showbRole #-} + +-- | Convert a 'TySynEqn' to a 'Builder' with the given precedence. +-- This function is only available with @template-haskell-2.9.0.0@ or later. +-- +-- /Since: 0.1/ +showbTySynEqnPrec :: Int -> TySynEqn -> Builder +showbTySynEqnPrec = showbPrec +{-# INLINE showbTySynEqnPrec #-} +#endif + +#if !(MIN_VERSION_template_haskell(2,10,0)) +-- | Convert a 'Pred' to a 'Builder' with the given precedence. +-- This function is only available with @template-haskell-2.9.0.0@ or earlier, as +-- 'Pred' is a type synonym for 'Type' in @template-haskell-2.10.0.0@ or later. +-- +-- /Since: 0.1/ +showbPredPrec :: Int -> Pred -> Builder +showbPredPrec = showbPrec +{-# INLINE showbPredPrec #-} +#endif + +$(deriveShowPragmas defaultInlineShowbPrec ''Body) +$(deriveShowPragmas defaultInlineShowb ''Callconv) +$(deriveShowPragmas defaultInlineShowbPrec ''Clause) +$(deriveShowPragmas defaultInlineShowbPrec ''Con) +$(deriveShowPragmas defaultInlineShowbPrec ''Dec) +$(deriveShowPragmas defaultInlineShowbPrec ''Exp) +$(deriveShowPragmas defaultInlineShowb ''FamFlavour) +$(deriveShowPragmas defaultInlineShowbPrec ''Fixity) +$(deriveShowPragmas defaultInlineShowb ''FixityDirection) +$(deriveShowPragmas defaultInlineShowbPrec ''Foreign) +$(deriveShowPragmas defaultInlineShowbPrec ''FunDep) +$(deriveShowPragmas defaultInlineShowbPrec ''Guard) +$(deriveShowPragmas defaultInlineShowbPrec ''Info) +$(deriveShowPragmas defaultInlineShowbPrec ''Lit) +$(deriveShowPragmas defaultInlineShowbPrec ''Loc) +$(deriveShowPragmas defaultInlineShowbPrec ''Match) +$(deriveShowPragmas defaultInlineShowbPrec ''ModName) + +instance Show Name where + showb = showbName + INLINE_INST_FUN(showb) + +$(deriveShowPragmas defaultInlineShowbPrec ''OccName) +$(deriveShowPragmas defaultInlineShowbPrec ''Pat) +$(deriveShowPragmas defaultInlineShowbPrec ''PkgName) +$(deriveShowPragmas defaultInlineShowbPrec ''Pragma) +$(deriveShowPragmas defaultInlineShowbPrec ''Range) +$(deriveShowPragmas defaultInlineShowb ''Safety) +$(deriveShowPragmas defaultInlineShowbPrec ''Stmt) +$(deriveShowPragmas defaultInlineShowb ''Strict) +$(deriveShowPragmas defaultInlineShowbPrec ''Type) +$(deriveShowPragmas defaultInlineShowbPrec ''TyVarBndr) + +#if MIN_VERSION_template_haskell(2,5,0) && !(MIN_VERSION_template_haskell(2,7,0)) +$(deriveShowPragmas defaultInlineShowbPrec ''ClassInstance) +#endif + +#if MIN_VERSION_template_haskell(2,8,0) +$(deriveShowPragmas defaultInlineShowb ''Inline) +$(deriveShowPragmas defaultInlineShowbPrec ''Phases) +$(deriveShowPragmas defaultInlineShowbPrec ''RuleBndr) +$(deriveShowPragmas defaultInlineShowb ''RuleMatch) +$(deriveShowPragmas defaultInlineShowbPrec ''TyLit) +#else +$(deriveShowPragmas defaultInlineShowb ''InlineSpec) +$(deriveShowPragmas defaultInlineShowbPrec ''Kind) +#endif + +#if MIN_VERSION_template_haskell(2,9,0) +$(deriveShowPragmas defaultInlineShowbPrec ''AnnLookup) +$(deriveShowPragmas defaultInlineShowbPrec ''AnnTarget) +$(deriveShowPragmas defaultInlineShowbPrec ''Module) +$(deriveShowPragmas defaultInlineShowbPrec ''ModuleInfo) +$(deriveShowPragmas defaultInlineShowb ''Role) +$(deriveShowPragmas defaultInlineShowbPrec ''TySynEqn) +#endif + +#if !(MIN_VERSION_template_haskell(2,10,0)) +$(deriveShowPragmas defaultInlineShowbPrec ''Pred) +#endif diff --git a/src/Text/Show/Text/System.hs b/src/Text/Show/Text/System.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/System.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE CPP #-} +{-| +Module: Text.Show.Text.System +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Imports 'Show' instances for @System@ modules. +-} +module Text.Show.Text.System () where + +import Text.Show.Text.System.Locale () +import Text.Show.Text.System.Random () +import Text.Show.Text.System.Time () + +#if defined(mingw32_HOST_OS) +import Text.Show.Text.System.Win32 () +#else +import Text.Show.Text.System.Posix () +#endif diff --git a/src/Text/Show/Text/System/Directory.hs b/src/Text/Show/Text/System/Directory.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/System/Directory.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Text.Show.Text.System.Directory +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' function for 'Permissions'. + +/Since: 0.1/ +-} +module Text.Show.Text.System.Directory (showbPermissionsPrec) where + +import Prelude hiding (Show) + +import System.Directory (Permissions) + +import Text.Show.Text (Show(showbPrec), Builder) +import Text.Show.Text.TH (deriveShowPragmas, defaultInlineShowbPrec) + +-- | Convert 'Permissions' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbPermissionsPrec :: Int -> Permissions -> Builder +showbPermissionsPrec = showbPrec +{-# INLINE showbPermissionsPrec #-} + +$(deriveShowPragmas defaultInlineShowbPrec ''Permissions) diff --git a/src/Text/Show/Text/System/Locale.hs b/src/Text/Show/Text/System/Locale.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/System/Locale.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Text.Show.Text.System.Locale +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' function for 'TimeLocale'. + +/Since: 0.1/ +-} +module Text.Show.Text.System.Locale (showbTimeLocalePrec) where + +import System.Locale (TimeLocale) + +import Prelude hiding (Show) + +import Text.Show.Text (Show(showbPrec), Builder) +import Text.Show.Text.TH (deriveShowPragmas, defaultInlineShowbPrec) + +-- | Convert a 'TimeLocale' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbTimeLocalePrec :: Int -> TimeLocale -> Builder +showbTimeLocalePrec = showbPrec +{-# INLINE showbTimeLocalePrec #-} + +$(deriveShowPragmas defaultInlineShowbPrec ''TimeLocale) diff --git a/src/Text/Show/Text/System/Posix.hs b/src/Text/Show/Text/System/Posix.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/System/Posix.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Text.Show.Text.System.Posix +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for data types in the @unix@ library. This module is +only available on Unix-like operating systems (i.e., not Windows). + +/Since: 0.1/ +-} +module Text.Show.Text.System.Posix ( + showbRTLDFlags + , showbDLPrec + , showbProcessStatusPrec + , showbGroupEntryPrec + , showbUserEntryPrec + ) where + +import System.Posix.DynamicLinker (RTLDFlags, DL) +import System.Posix.Process (ProcessStatus) +import System.Posix.User (GroupEntry, UserEntry) + +import Text.Show.Text (Builder, showb, showbPrec) +import Text.Show.Text.TH (deriveShowPragmas, defaultInlineShowb, defaultInlineShowbPrec) + +-- | Convert an 'RTLDFlags' value to a 'Builder'. +-- +-- /Since: 0.1/ +showbRTLDFlags :: RTLDFlags -> Builder +showbRTLDFlags = showb +{-# INLINE showbRTLDFlags #-} + +-- | Convert a 'DL' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbDLPrec :: Int -> DL -> Builder +showbDLPrec = showbPrec +{-# INLINE showbDLPrec #-} + +-- | Convert a 'ProcessStatus' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbProcessStatusPrec :: Int -> ProcessStatus -> Builder +showbProcessStatusPrec = showbPrec +{-# INLINE showbProcessStatusPrec #-} + +-- | Convert a 'GroupEntry' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbGroupEntryPrec :: Int -> GroupEntry -> Builder +showbGroupEntryPrec = showbPrec +{-# INLINE showbGroupEntryPrec #-} + +-- | Convert a 'UserEntry' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbUserEntryPrec :: Int -> UserEntry -> Builder +showbUserEntryPrec = showbPrec +{-# INLINE showbUserEntryPrec #-} + +$(deriveShowPragmas defaultInlineShowb ''RTLDFlags) +$(deriveShowPragmas defaultInlineShowbPrec ''DL) +$(deriveShowPragmas defaultInlineShowbPrec ''ProcessStatus) +$(deriveShowPragmas defaultInlineShowbPrec ''GroupEntry) +$(deriveShowPragmas defaultInlineShowbPrec ''UserEntry) diff --git a/src/Text/Show/Text/System/Random.hs b/src/Text/Show/Text/System/Random.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/System/Random.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Text.Show.Text.System.Random +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' function for 'StdGen'. + +/Since: 0.1/ +-} +module Text.Show.Text.System.Random (showbStdGenPrec) where + +import Prelude hiding (Show) +import System.Random (StdGen) +import Text.Show.Text (Show(showbPrec), Builder, FromStringShow(..)) + +#include "inline.h" + +-- | Convert a 'StdGen' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbStdGenPrec :: Int -> StdGen -> Builder +showbStdGenPrec p = showbPrec p . FromStringShow +{-# INLINE showbStdGenPrec #-} + +instance Show StdGen where + showbPrec = showbStdGenPrec + INLINE_INST_FUN(showbPrec) diff --git a/src/Text/Show/Text/System/Time.hs b/src/Text/Show/Text/System/Time.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/System/Time.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE CPP, TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Text.Show.Text.System.Time +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for data types in the @old-time@ library. + +/Since: 0.1/ +-} +module Text.Show.Text.System.Time ( + showbClockTime + , showbTimeDiffPrec + , showbCalendarTimePrec + , showbMonth + , showbDay + ) where + +import Prelude hiding (Show) + +import System.IO.Unsafe (unsafePerformIO) +import System.Time (ClockTime, TimeDiff, CalendarTime, Month, Day, + calendarTimeToString, toCalendarTime) + +import Text.Show.Text (Show(showb, showbPrec), Builder, fromString) +import Text.Show.Text.TH (deriveShowPragmas, defaultInlineShowb, defaultInlineShowbPrec) + +#include "inline.h" + +-- | Convert a 'ClockTime' to a 'Builder'. +-- +-- /Since: 0.1/ +showbClockTime :: ClockTime -> Builder +showbClockTime = fromString . calendarTimeToString . unsafePerformIO . toCalendarTime +{-# INLINE showbClockTime #-} + +-- | Convert a 'TimeDiff' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbTimeDiffPrec :: Int -> TimeDiff -> Builder +showbTimeDiffPrec = showbPrec +{-# INLINE showbTimeDiffPrec #-} + +-- | Convert a 'CalendarTime' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbCalendarTimePrec :: Int -> CalendarTime -> Builder +showbCalendarTimePrec = showbPrec +{-# INLINE showbCalendarTimePrec #-} + +-- | Convert a 'Month' to a 'Builder'. +-- +-- /Since: 0.1/ +showbMonth :: Month -> Builder +showbMonth = showb +{-# INLINE showbMonth #-} + +-- | Convert a 'Day' to a 'Builder'. +-- +-- /Since: 0.1/ +showbDay :: Day -> Builder +showbDay = showb +{-# INLINE showbDay #-} + +instance Show ClockTime where + showb = showbClockTime + INLINE_INST_FUN(showb) + +$(deriveShowPragmas defaultInlineShowbPrec ''TimeDiff) +$(deriveShowPragmas defaultInlineShowbPrec ''CalendarTime) +$(deriveShowPragmas defaultInlineShowb ''Month) +$(deriveShowPragmas defaultInlineShowb ''Day) diff --git a/src/Text/Show/Text/System/Win32.hs b/src/Text/Show/Text/System/Win32.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/System/Win32.hs diff --git a/src/Text/Show/Text/Text.hs b/src/Text/Show/Text/Text.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Text.hs @@ -0,0 +1,13 @@ +{-| +Module: Text.Show.Text.Text +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Imports 'Show' instances for @Text@ modules. +-} +module Text.Show.Text.Text () where + +import Text.Show.Text.Text.PrettyPrint () diff --git a/src/Text/Show/Text/Text/PrettyPrint.hs b/src/Text/Show/Text/Text/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Text/PrettyPrint.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE CPP, TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Text.Show.Text.Text.PrettyPrint +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for data types in the @pretty@ library. + +/Since: 0.1/ +-} +module Text.Show.Text.Text.PrettyPrint ( + showbDoc + , showbMode + , showbStylePrec + , showbTextDetailsPrec +#if MIN_VERSION_pretty(1,1,2) + , showbPrettyLevelPrec +#endif + ) where + +#if !(MIN_VERSION_base(4,8,0)) +import Data.Monoid (mempty) +#endif + +import Prelude hiding (Show) + +import Text.PrettyPrint.HughesPJ (Doc, Mode, Style(..), TextDetails(..), + fullRender, style) +#if MIN_VERSION_pretty(1,1,2) +import Text.PrettyPrint.HughesPJClass (PrettyLevel) +#endif +import Text.Show.Text (Show(showb, showbPrec), Builder, fromString) +import Text.Show.Text.TH (deriveShowPragmas, defaultInlineShowb, defaultInlineShowbPrec) +import Text.Show.Text.Utils ((<>), s) + +#include "inline.h" + +-- | Convert a 'Doc' to a 'Builder'. +-- +-- /Since: 0.1/ +showbDoc :: Doc -> Builder +showbDoc doc = fullRender (mode style) (lineLength style) + (ribbonsPerLine style) + txtPrinter mempty doc +{-# INLINE showbDoc #-} + +txtPrinter :: TextDetails -> Builder -> Builder +txtPrinter (Chr c) b = s c <> b +txtPrinter (Str s') b = fromString s' <> b +txtPrinter (PStr s') b = fromString s' <> b +{-# INLINE txtPrinter #-} + +-- | Convert a 'Mode' to a 'Builder'. +-- +-- /Since: 0.1/ +showbMode :: Mode -> Builder +showbMode = showb +{-# INLINE showbMode #-} + +-- | Convert a 'Style' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbStylePrec :: Int -> Style -> Builder +showbStylePrec = showbPrec +{-# INLINE showbStylePrec #-} + +-- | Convert 'TextDetails' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbTextDetailsPrec :: Int -> TextDetails -> Builder +showbTextDetailsPrec = showbPrec +{-# INLINE showbTextDetailsPrec #-} + +#if MIN_VERSION_pretty(1,1,2) +-- | Convert a 'PrettyLevel' value to a 'Builder' with the given precedence. +-- This function is only available with @pretty-1.1.2.0@ or later. +-- +-- /Since: 0.1/ +showbPrettyLevelPrec :: Int -> PrettyLevel -> Builder +showbPrettyLevelPrec = showbPrec +{-# INLINE showbPrettyLevelPrec #-} +#endif + +instance Show Doc where + showb = showbDoc + INLINE_INST_FUN(showb) + +$(deriveShowPragmas defaultInlineShowb ''Mode) +$(deriveShowPragmas defaultInlineShowbPrec ''Style) +$(deriveShowPragmas defaultInlineShowbPrec ''TextDetails) + +#if MIN_VERSION_pretty(1,1,2) +$(deriveShowPragmas defaultInlineShowbPrec ''PrettyLevel) +#endif diff --git a/src/Text/Show/Text/Text/XHtml.hs b/src/Text/Show/Text/Text/XHtml.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Text/XHtml.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE CPP, TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Text.Show.Text.Text.XHtml +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for data types in the @xhtml@ library. + +/Since: 0.1/ +-} +module Text.Show.Text.Text.XHtml ( + showbHtml + , showbHtmlList + , showbHtmlAttr + , showbHotLinkPrec + , showbHtmlTable + ) where + +#if !(MIN_VERSION_base(4,8,0)) +import Data.Monoid (mconcat) +#endif + +import Prelude hiding (Show) + +import Text.Show.Text (Show(..), Builder, FromStringShow(..), fromString) +import Text.Show.Text.Data.Char (showbString) +import Text.Show.Text.TH (deriveShowPragmas, defaultInlineShowbPrec) +import Text.Show.Text.Utils ((<>), s) +import Text.XHtml.Frameset (Html, HtmlAttr, HotLink, + htmlAttrPair, renderHtmlFragment) +import Text.XHtml.Table (HtmlTable) + +#include "inline.h" + +-- | Convert an 'Html' value to a 'Builder'. +-- +-- /Since: 0.1/ +showbHtml :: Html -> Builder +showbHtml = fromString . renderHtmlFragment +{-# INLINE showbHtml #-} + +-- | Convert a list of 'Html' values to a 'Builder'. +-- +-- /Since: 0.1/ +showbHtmlList :: [Html] -> Builder +showbHtmlList = mconcat . map showb +{-# INLINE showbHtmlList #-} + +-- | Convert an 'HtmlAttr' to a 'Builder'. +-- +-- /Since: 0.1/ +showbHtmlAttr :: HtmlAttr -> Builder +showbHtmlAttr ha = case htmlAttrPair ha of + (str, val) -> fromString str <> s '=' <> showbString val +{-# INLINE showbHtmlAttr #-} + +-- | Convert a 'HotLink' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbHotLinkPrec :: Int -> HotLink -> Builder +showbHotLinkPrec = showbPrec +{-# INLINE showbHotLinkPrec #-} + +-- | Convert an 'HtmlTable' to a 'Builder'. +-- +-- /Since: 0.1/ +showbHtmlTable :: HtmlTable -> Builder +showbHtmlTable = showb . FromStringShow +{-# INLINE showbHtmlTable #-} + +instance Show Html where + showb = showbHtml + INLINE_INST_FUN(showb) + + showbList = showbHtmlList + INLINE_INST_FUN(showbList) + +instance Show HtmlAttr where + showb = showbHtmlAttr + INLINE_INST_FUN(showb) + +$(deriveShowPragmas defaultInlineShowbPrec ''HotLink) + +instance Show HtmlTable where + showb = showbHtmlTable + INLINE_INST_FUN(showb) diff --git a/src/Text/Show/Text/Trace.hs b/src/Text/Show/Text/Trace.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Trace.hs @@ -0,0 +1,13 @@ +{-| +Module: Text.Show.Text.Trace +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Imports 'Show' instances for @Trace@ modules. +-} +module Text.Show.Text.Trace () where + +import Text.Show.Text.Trace.Hpc () diff --git a/src/Text/Show/Text/Trace/Hpc.hs b/src/Text/Show/Text/Trace/Hpc.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Trace/Hpc.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE CPP, TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Text.Show.Text.Trace.Hpc +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Monomorphic 'Show' functions for data types in the @hpc@ library. + +/Since: 0.1/ +-} +module Text.Show.Text.Trace.Hpc ( + showbMixPrec + , showbBoxLabelPrec + , showbCondBox + , showbTixPrec + , showbTixModulePrec + , showbHpcPos + , showbHash + ) where + +import Prelude hiding (Show) + +import Text.Show.Text (Show(showb, showbPrec), Builder, FromStringShow(..)) +import Text.Show.Text.Data.Integral (showbIntPrec) +import Text.Show.Text.Data.Time () +import Text.Show.Text.TH (deriveShowPragmas, defaultInlineShowb, defaultInlineShowbPrec) +import Text.Show.Text.Utils ((<>), s) + +import Trace.Hpc.Mix (Mix, BoxLabel, CondBox) +import Trace.Hpc.Tix (Tix, TixModule) +import Trace.Hpc.Util (HpcPos, Hash, fromHpcPos) + +#include "inline.h" + +-- | Convert a 'Mix' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbMixPrec :: Int -> Mix -> Builder +showbMixPrec = showbPrec +{-# INLINE showbMixPrec #-} + +-- | Convert a 'BoxLabel' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbBoxLabelPrec :: Int -> BoxLabel -> Builder +showbBoxLabelPrec = showbPrec +{-# INLINE showbBoxLabelPrec #-} + +-- | Convert a 'CondBox' to a 'Builder'. +-- +-- /Since: 0.1/ +showbCondBox :: CondBox -> Builder +showbCondBox = showb +{-# INLINE showbCondBox #-} + +-- | Convert a 'Tix' value to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbTixPrec :: Int -> Tix -> Builder +showbTixPrec = showbPrec +{-# INLINE showbTixPrec #-} + +-- | Convert a 'TixModule' to a 'Builder' with the given precedence. +-- +-- /Since: 0.1/ +showbTixModulePrec :: Int -> TixModule -> Builder +showbTixModulePrec = showbPrec +{-# INLINE showbTixModulePrec #-} + +-- | Convert a 'HpcPos' to a 'Builder'. +-- +-- /Since: 0.1/ +showbHpcPos :: HpcPos -> Builder +showbHpcPos hp = case fromHpcPos hp of + (l1, c1, l2, c2) -> showbIntPrec 0 l1 + <> (s ':' <> showbIntPrec 0 c1) + <> (s '-' <> showbIntPrec 0 l2) + <> (s ':' <> showbIntPrec 0 c2) +{-# INLINE showbHpcPos #-} + +-- | Convert a 'Hash' to a 'Builder'. +-- +-- /Since: 0.1/ +showbHash :: Hash -> Builder +showbHash = showb . FromStringShow +{-# INLINE showbHash #-} + +$(deriveShowPragmas defaultInlineShowbPrec ''Mix) +$(deriveShowPragmas defaultInlineShowbPrec ''BoxLabel) +$(deriveShowPragmas defaultInlineShowb ''CondBox) +$(deriveShowPragmas defaultInlineShowbPrec ''Tix) +$(deriveShowPragmas defaultInlineShowbPrec ''TixModule) + +instance Show HpcPos where + showb = showbHpcPos + INLINE_INST_FUN(showb) + +instance Show Hash where + showb = showbHash + INLINE_INST_FUN(showb) diff --git a/src/Text/Show/Text/Utils.hs b/src/Text/Show/Text/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Text/Utils.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE CPP, OverloadedStrings #-} +{-| +Module: Text.Show.Text.Utils +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Miscellaneous utility functions. +-} +module Text.Show.Text.Utils where + +#if !(MIN_VERSION_base(4,8,0)) +import Data.Monoid (Monoid(mappend)) +#endif +import Prelude hiding (Show) +import Text.Show.Text (Show, Builder, showbUnary, singleton) + +infixr 6 <> + +-- | Infix 'mappend', defined here for backwards-compatibility with older versions +-- of @base@. +(<>) :: Monoid m => m -> m -> m +(<>) = mappend +{-# INLINE (<>) #-} + +-- | A shorter name for 'singleton' for convenience's sake (since it tends to be used +-- pretty often in @text-show-instances@). +s :: Char -> Builder +s = singleton +{-# INLINE s #-} + +-- | This pattern is used frequently when showing container types. +showbUnaryList :: Show a => Int -> [a] -> Builder +showbUnaryList p = showbUnary "fromList" p +{-# INLINE showbUnaryList #-} diff --git a/tests/Instances/Control/Applicative/Trans.hs b/tests/Instances/Control/Applicative/Trans.hs new file mode 100644 --- /dev/null +++ b/tests/Instances/Control/Applicative/Trans.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Instances.Control.Applicative.Trans +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Provides 'Arbitrary' instances for applicative functor transformers. +-} +module Instances.Control.Applicative.Trans () where + +import Control.Applicative.Backwards (Backwards(..)) +import Control.Applicative.Lift (Lift(..)) + +import Data.Functor ((<$>)) + +import Test.Tasty.QuickCheck (Arbitrary(..), oneof) + +deriving instance Arbitrary (f a) => Arbitrary (Backwards f a) + +instance (Arbitrary a, Arbitrary (f a)) => Arbitrary (Lift f a) where + arbitrary = oneof [Pure <$> arbitrary, Other <$> arbitrary] diff --git a/tests/Instances/Control/Monad/Trans.hs b/tests/Instances/Control/Monad/Trans.hs new file mode 100644 --- /dev/null +++ b/tests/Instances/Control/Monad/Trans.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, + StandaloneDeriving, UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-warnings-deprecations #-} +{-| +Module: Instances.Control.Monad.Trans +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Provides 'Arbitrary' instances for monad transformers. +-} +module Instances.Control.Monad.Trans () where + +import Control.Monad.Trans.Error (ErrorT(..)) +import Control.Monad.Trans.Except (ExceptT(..)) +import Control.Monad.Trans.Identity (IdentityT(..)) +import Control.Monad.Trans.List (ListT(..)) +import Control.Monad.Trans.Maybe (MaybeT(..)) +import qualified Control.Monad.Trans.Writer.Lazy as WL (WriterT(..)) +import qualified Control.Monad.Trans.Writer.Strict as WS (WriterT(..)) + +import Test.Tasty.QuickCheck (Arbitrary) + +deriving instance Arbitrary (m (Either e a)) => Arbitrary (ErrorT e m a) +deriving instance Arbitrary (m (Either e a)) => Arbitrary (ExceptT e m a) +deriving instance Arbitrary (f a) => Arbitrary (IdentityT f a) +deriving instance Arbitrary (m [a]) => Arbitrary (ListT m a) +deriving instance Arbitrary (m (Maybe a)) => Arbitrary (MaybeT m a) +deriving instance Arbitrary (m (a, w)) => Arbitrary (WL.WriterT w m a) +deriving instance Arbitrary (m (a, w)) => Arbitrary (WS.WriterT w m a) diff --git a/tests/Instances/Data/Containers.hs b/tests/Instances/Data/Containers.hs new file mode 100644 --- /dev/null +++ b/tests/Instances/Data/Containers.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Instances.Data.Containers +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Provides 'Arbitrary' instances for data types located in @containers@. +-} +module Instances.Data.Containers () where + +#if !(MIN_VERSION_base(4,8,0)) +import Control.Applicative ((<*>), pure) +#endif + +import Data.Functor ((<$>)) +import Data.Sequence (ViewL(..), ViewR(..)) + +import Test.QuickCheck.Instances () +import Test.Tasty.QuickCheck (Arbitrary(..), oneof) + +instance Arbitrary a => Arbitrary (ViewL a) where + arbitrary = oneof [pure EmptyL, (:<) <$> arbitrary <*> arbitrary] + +instance Arbitrary a => Arbitrary (ViewR a) where + arbitrary = oneof [pure EmptyR, (:>) <$> arbitrary <*> arbitrary] diff --git a/tests/Instances/Data/Functor/Trans.hs b/tests/Instances/Data/Functor/Trans.hs new file mode 100644 --- /dev/null +++ b/tests/Instances/Data/Functor/Trans.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE CPP, FlexibleContexts, GeneralizedNewtypeDeriving, StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Instances.Data.Functor.Trans +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Provides 'Arbitrary' instances for functor transformers. +-} +module Instances.Data.Functor.Trans () where + +#if !(MIN_VERSION_base(4,8,0)) +import Control.Applicative ((<*>)) +#endif + +import Data.Functor ((<$>)) +import Data.Functor.Compose (Compose(..)) +import Data.Functor.Constant (Constant(..)) +import Data.Functor.Product (Product(..)) +import Data.Functor.Reverse (Reverse(..)) +import Data.Functor.Sum (Sum(..)) + +import Test.Tasty.QuickCheck (Arbitrary(..), oneof) + +deriving instance Arbitrary (f (g a)) => Arbitrary (Compose f g a) +deriving instance Arbitrary a => Arbitrary (Constant a b) +deriving instance Arbitrary (f a) => Arbitrary (Reverse f a) + +instance (Arbitrary (f a), Arbitrary (g a)) => Arbitrary (Product f g a) where + arbitrary = Pair <$> arbitrary <*> arbitrary + +instance (Arbitrary (f a), Arbitrary (g a)) => Arbitrary (Sum f g a) where + arbitrary = oneof [InL <$> arbitrary, InR <$> arbitrary] diff --git a/tests/Instances/Data/List/NonEmpty.hs b/tests/Instances/Data/List/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/tests/Instances/Data/List/NonEmpty.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Instances.Data.List.NonEmpty +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Provides an 'Arbitrary' instance for 'NonEmpty' lists. +-} +module Instances.Data.List.NonEmpty () where + +#if !(MIN_VERSION_base(4,8,0)) +import Control.Applicative ((<*>)) +#endif + +import Data.Functor ((<$>)) +import Data.List.NonEmpty (NonEmpty(..)) + +import Test.Tasty.QuickCheck (Arbitrary(..)) + +instance Arbitrary a => Arbitrary (NonEmpty a) where + arbitrary = (:|) <$> arbitrary <*> arbitrary diff --git a/tests/Instances/Data/Semigroup.hs b/tests/Instances/Data/Semigroup.hs new file mode 100644 --- /dev/null +++ b/tests/Instances/Data/Semigroup.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Instances.Data.Semigroup +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Provides 'Arbitrary' instances for @Semigroup@ data types. +-} +module Instances.Data.Semigroup () where + +import Data.Semigroup (Min(..), Max(..), First(..), + Last(..), WrappedMonoid(..), Option(..)) +import Test.Tasty.QuickCheck (Arbitrary) + +deriving instance Arbitrary a => Arbitrary (Min a) +deriving instance Arbitrary a => Arbitrary (Max a) +deriving instance Arbitrary a => Arbitrary (First a) +deriving instance Arbitrary a => Arbitrary (Last a) +deriving instance Arbitrary m => Arbitrary (WrappedMonoid m) +deriving instance Arbitrary a => Arbitrary (Option a) diff --git a/tests/Instances/Data/Tagged.hs b/tests/Instances/Data/Tagged.hs new file mode 100644 --- /dev/null +++ b/tests/Instances/Data/Tagged.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Instances.Data.Tagged +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Provides an 'Arbitrary' instance for 'Tagged' values. +-} +module Instances.Data.Tagged () where + +import Data.Tagged (Tagged(..)) +import Test.Tasty.QuickCheck (Arbitrary) + +deriving instance Arbitrary b => Arbitrary (Tagged s b) diff --git a/tests/Instances/Graphics/Win32.hs b/tests/Instances/Graphics/Win32.hs new file mode 100644 --- /dev/null +++ b/tests/Instances/Graphics/Win32.hs diff --git a/tests/Instances/Language/Haskell/TH.hs b/tests/Instances/Language/Haskell/TH.hs new file mode 100644 --- /dev/null +++ b/tests/Instances/Language/Haskell/TH.hs @@ -0,0 +1,603 @@ +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, StandaloneDeriving #-} +#if !(MIN_VERSION_template_haskell(2,10,0)) +{-# LANGUAGE MagicHash #-} +#endif +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Instances.Language.Haskell.TH +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Provides 'Arbitrary' instances for data types in the @template-haskell@ library. +-} +module Instances.Language.Haskell.TH () where + +#if !(MIN_VERSION_base(4,8,0)) +import Control.Applicative ((<*>), pure) +#endif + +import Data.Functor ((<$>)) + +#if !(MIN_VERSION_template_haskell(2,10,0)) +import GHC.Exts (Int(I#)) +#endif + +import Language.Haskell.TH.Syntax +#if !(MIN_VERSION_template_haskell(2,8,0)) +import Language.Haskell.TH.Syntax.Internals (ModName(..), PkgName(..), OccName(..)) +#endif + +import Test.Tasty.QuickCheck (Arbitrary(..), oneof) + +instance Arbitrary Body where + arbitrary = oneof $ map pure [ GuardedB [(fGuard, fExp)] + , NormalB fExp + ] +-- arbitrary = oneof [GuardedB <$> arbitrary, NormalB <$> arbitrary] + +instance Arbitrary Callconv where + arbitrary = oneof $ map pure [ CCall + , StdCall +#if MIN_VERSION_template_haskell(2,10,0) + , CApi + , Prim + , JavaScript +#endif + ] + +instance Arbitrary Clause where + arbitrary = pure $ Clause [fPat] fBody [fDec] +-- arbitrary = Clause <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary Con where + arbitrary = oneof [ NormalC <$> arbitrary <*> arbitrary + , RecC <$> arbitrary <*> arbitrary + , InfixC <$> arbitrary <*> arbitrary <*> arbitrary + , (flip . flip ForallC) [fPred] fCon <$> arbitrary + ] +-- arbitrary = oneof [ NormalC <$> arbitrary <*> arbitrary +-- , RecC <$> arbitrary <*> arbitrary +-- , InfixC <$> arbitrary <*> arbitrary <*> arbitrary +-- , ForallC <$> arbitrary <*> arbitrary <*> arbitrary +-- ] + +instance Arbitrary Dec where + arbitrary = oneof [ + flip FunD [fClause] <$> arbitrary + , pure $ ValD fPat fBody [fDec] + , DataD [fPred] <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + , NewtypeD [fPred] <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + , TySynD <$> arbitrary <*> arbitrary <*> arbitrary + , (flip . ((flip . (flip .)) .) . ClassD) [fPred] [fDec] + <$> arbitrary <*> arbitrary <*> arbitrary + , (flip . InstanceD) [fPred] [fDec] <$> arbitrary + , SigD <$> arbitrary <*> arbitrary + , ForeignD <$> arbitrary + , PragmaD <$> arbitrary + , FamilyD <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + , DataInstD [fPred] <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + , NewtypeInstD [fPred] <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary +#if MIN_VERSION_template_haskell(2,8,0) + , InfixD <$> arbitrary <*> arbitrary +#endif +#if MIN_VERSION_template_haskell(2,9,0) + , ClosedTypeFamilyD <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + , RoleAnnotD <$> arbitrary <*> arbitrary + , TySynInstD <$> arbitrary <*> arbitrary +#else + , TySynInstD <$> arbitrary <*> arbitrary <*> arbitrary +#endif +#if MIN_VERSION_template_haskell(2,10,0) + , StandaloneDerivD <$> arbitrary <*> arbitrary + , DefaultSigD <$> arbitrary <*> arbitrary +#endif + ] +-- arbitrary = oneof [ +-- FunD <$> arbitrary <*> arbitrary +-- , ValD <$> arbitrary <*> arbitrary <*> arbitrary +-- , DataD <$> arbitrary <*> arbitrary <*> arbitrary +-- <*> arbitrary <*> arbitrary +-- , NewtypeD <$> arbitrary <*> arbitrary <*> arbitrary +-- <*> arbitrary <*> arbitrary +-- , TySynD <$> arbitrary <*> arbitrary <*> arbitrary +-- , ClassD <$> arbitrary <*> arbitrary <*> arbitrary +-- <*> arbitrary <*> arbitrary +-- , InstanceD <$> arbitrary <*> arbitrary <*> arbitrary +-- , SigD <$> arbitrary <*> arbitrary +-- , ForeignD <$> arbitrary +-- , PragmaD <$> arbitrary +-- , FamilyD <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary +-- , DataInstD <$> arbitrary <*> arbitrary <*> arbitrary +-- <*> arbitrary <*> arbitrary +-- , NewtypeInstD <$> arbitrary <*> arbitrary <*> arbitrary +-- <*> arbitrary <*> arbitrary +-- #if MIN_VERSION_template_haskell(2,8,0) +-- , InfixD <$> arbitrary <*> arbitrary +-- #endif +-- #if MIN_VERSION_template_haskell(2,9,0) +-- , ClosedTypeFamilyD <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary +-- , RoleAnnotD <$> arbitrary <*> arbitrary +-- , TySynInstD <$> arbitrary <*> arbitrary +-- #else +-- , TySynInstD <$> arbitrary <*> arbitrary <*> arbitrary +-- #endif +-- #if MIN_VERSION_template_haskell(2,10,0) +-- , StandaloneDerivD <$> arbitrary <*> arbitrary +-- , DefaultSigD <$> arbitrary <*> arbitrary +-- #endif +-- ] + +instance Arbitrary Exp where + arbitrary = oneof [ VarE <$> arbitrary + , ConE <$> arbitrary + , LitE <$> arbitrary + , pure $ AppE fExp fExp + , pure $ InfixE (Just fExp) fExp (Just fExp) + , pure $ LamE [fPat] fExp + , pure $ TupE [fExp] + , pure $ CondE fExp fExp fExp + , pure $ LetE [fDec] fExp + , pure $ CaseE fExp [fMatch] + , pure $ DoE [fStmt] + , pure $ CompE [fStmt] + , pure $ ArithSeqE fRange + , pure $ ListE [fExp] + , SigE fExp <$> arbitrary + , flip RecConE [fFieldExp] <$> arbitrary + , pure $ RecUpdE fExp [fFieldExp] +#if MIN_VERSION_template_haskell(2,6,0) + , pure $ UnboxedTupE [fExp] +#endif +#if MIN_VERSION_template_haskell(2,7,0) + , pure $ UInfixE fExp fExp fExp + , pure $ ParensE fExp +#endif +#if MIN_VERSION_template_haskell(2,8,0) + , pure $ LamCaseE [fMatch] + , pure $ MultiIfE [(fGuard, fExp)] +#endif +#if MIN_VERSION_template_haskell(2,10,0) + , pure $ StaticE fExp +#endif + ] +-- arbitrary = oneof [ VarE <$> arbitrary +-- , ConE <$> arbitrary +-- , LitE <$> arbitrary +-- , AppE <$> arbitrary <*> arbitrary +-- , InfixE <$> arbitrary <*> arbitrary <*> arbitrary +-- , LamE <$> arbitrary <*> arbitrary +-- , TupE <$> arbitrary +-- , CondE <$> arbitrary <*> arbitrary <*> arbitrary +-- , LetE <$> arbitrary <*> arbitrary +-- , CaseE <$> arbitrary <*> arbitrary +-- , DoE <$> arbitrary +-- , CompE <$> arbitrary +-- , ArithSeqE <$> arbitrary +-- , ListE <$> arbitrary +-- , SigE <$> arbitrary <*> arbitrary +-- , RecConE <$> arbitrary <*> arbitrary +-- , RecUpdE <$> arbitrary <*> arbitrary +-- #if MIN_VERSION_template_haskell(2,6,0) +-- , UnboxedTupE <$> arbitrary +-- #endif +-- #if MIN_VERSION_template_haskell(2,7,0) +-- , UInfixE <$> arbitrary <*> arbitrary <*> arbitrary +-- , ParensE <$> arbitrary +-- #endif +-- #if MIN_VERSION_template_haskell(2,8,0) +-- , LamCaseE <$> arbitrary +-- , MultiIfE <$> arbitrary +-- #endif +-- #if MIN_VERSION_template_haskell(2,10,0) +-- , StaticE <$> arbitrary +-- #endif +-- ] + +instance Arbitrary FamFlavour where + arbitrary = oneof $ map pure [TypeFam, DataFam] + +instance Arbitrary Fixity where + arbitrary = Fixity <$> arbitrary <*> arbitrary + +instance Arbitrary FixityDirection where + arbitrary = oneof $ map pure [InfixL, InfixR, InfixN] + +instance Arbitrary Foreign where + arbitrary = oneof [ ImportF <$> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary + , ExportF <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + ] + +instance Arbitrary FunDep where + arbitrary = FunDep <$> arbitrary <*> arbitrary + +instance Arbitrary Guard where + arbitrary = oneof $ map pure [ NormalG fExp + , PatG [fStmt] + ] +-- arbitrary = oneof [NormalG <$> arbitrary, PatG <$> arbitrary] + +instance Arbitrary Info where + arbitrary = oneof [ +#if MIN_VERSION_template_haskell(2,5,0) + pure $ ClassI fDec [fDec] +#else + pure $ ClassI fDec +#endif + , ClassOpI <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + , pure $ TyConI fDec + , PrimTyConI <$> arbitrary <*> arbitrary <*> arbitrary + , DataConI <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + , VarI <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + , TyVarI <$> arbitrary <*> arbitrary +#if MIN_VERSION_template_haskell(2,7,0) + , pure $ FamilyI fDec [fDec] +#endif + ] +-- arbitrary = oneof [ +-- #if MIN_VERSION_template_haskell(2,5,0) +-- ClassI <$> arbitrary <*> arbitrary +-- #else +-- ClassI <$> arbitrary +-- #endif +-- , ClassOpI <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary +-- , TyConI <$> arbitrary +-- , PrimTyConI <$> arbitrary <*> arbitrary <*> arbitrary +-- , DataConI <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary +-- , VarI <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary +-- , TyVarI <$> arbitrary <*> arbitrary +-- #if MIN_VERSION_template_haskell(2,7,0) +-- , FamilyI <$> arbitrary <*> arbitrary +-- #endif +-- ] + +instance Arbitrary Lit where + arbitrary = oneof [ CharL <$> arbitrary + , StringL <$> arbitrary + , IntegerL <$> arbitrary + , RationalL <$> arbitrary + , IntPrimL <$> arbitrary + , WordPrimL <$> arbitrary + , FloatPrimL <$> arbitrary + , DoublePrimL <$> arbitrary +#if MIN_VERSION_template_haskell(2,5,0) + , StringPrimL <$> arbitrary +#endif + ] + +instance Arbitrary Loc where + arbitrary = Loc <$> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary + +#if !(MIN_VERSION_template_haskell(2,10,0)) +deriving instance Show Loc +#endif + +instance Arbitrary Match where + arbitrary = (flip . flip Match) fBody [fDec] <$> arbitrary +-- arbitrary = Match <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary Name where + arbitrary = Name <$> arbitrary <*> arbitrary + +instance Arbitrary NameFlavour where + arbitrary = oneof [ pure NameS + , NameQ <$> arbitrary +#if MIN_VERSION_template_haskell(2,10,0) + , NameU <$> arbitrary + , NameL <$> arbitrary +#else + , (\(I# i#) -> NameU i#) <$> arbitrary + , (\(I# i#) -> NameL i#) <$> arbitrary +#endif + , NameG <$> arbitrary <*> arbitrary <*> arbitrary + ] + +instance Arbitrary NameIs where + arbitrary = oneof $ map pure [Alone, Applied, Infix] + +deriving instance Show NameIs + +instance Arbitrary NameSpace where + arbitrary = oneof $ map pure [VarName, DataName, TcClsName] + +instance Arbitrary Pat where + arbitrary = oneof [ LitP <$> arbitrary + , VarP <$> arbitrary + , pure $ TupP [fPat] + , flip ConP [fPat] <$> arbitrary + , (flip . InfixP) fPat fPat <$> arbitrary + , pure $ TildeP fPat + , pure $ BangP fPat + , flip AsP fPat <$> arbitrary + , pure WildP + , flip RecP [fFieldPat] <$> arbitrary + , pure $ ListP [fPat] + , SigP fPat <$> arbitrary +#if MIN_VERSION_template_haskell(2,5,0) + , pure $ ViewP fExp fPat +#endif +#if MIN_VERSION_template_haskell(2,6,0) + , pure $ UnboxedTupP [fPat] +#endif +#if MIN_VERSION_template_haskell(2,7,0) + , (flip . UInfixP) fPat fPat <$> arbitrary + , pure $ ParensP fPat +#endif + ] +-- arbitrary = oneof [ LitP <$> arbitrary +-- , VarP <$> arbitrary +-- , TupP <$> arbitrary +-- , ConP <$> arbitrary <*> arbitrary +-- , InfixP <$> arbitrary <*> arbitrary <*> arbitrary +-- , TildeP <$> arbitrary +-- , BangP <$> arbitrary +-- , AsP <$> arbitrary <*> arbitrary +-- , pure WildP +-- , RecP <$> arbitrary <*> arbitrary +-- , ListP <$> arbitrary +-- , SigP <$> arbitrary <*> arbitrary +-- #if MIN_VERSION_template_haskell(2,5,0) +-- , ViewP <$> arbitrary <*> arbitrary +-- #endif +-- #if MIN_VERSION_template_haskell(2,6,0) +-- , UnboxedTupP <$> arbitrary +-- #endif +-- #if MIN_VERSION_template_haskell(2,7,0) +-- , UInfixP <$> arbitrary <*> arbitrary <*> arbitrary +-- , ParensP <$> arbitrary +-- #endif +-- ] + +instance Arbitrary Pragma where + arbitrary = oneof + [ +#if MIN_VERSION_template_haskell(2,8,0) + InlineP <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + , SpecialiseP <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + , SpecialiseInstP <$> arbitrary + , RuleP <$> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary + , AnnP <$> arbitrary <*> arbitrary +# if MIN_VERSION_template_haskell(2,10,0) + , LineP <$> arbitrary <*> arbitrary +# endif +#else + InlineP <$> arbitrary <*> arbitrary + , SpecialiseP <$> arbitrary <*> arbitrary <*> arbitrary +#endif + ] + +instance Arbitrary Range where + arbitrary = oneof $ map pure [ FromR fExp + , FromThenR fExp fExp + , FromToR fExp fExp + , FromThenToR fExp fExp fExp + ] +-- arbitrary = oneof [ FromR <$> arbitrary +-- , FromThenR <$> arbitrary <*> arbitrary +-- , FromToR <$> arbitrary <*> arbitrary +-- , FromThenToR <$> arbitrary <*> arbitrary <*> arbitrary +-- ] + +instance Arbitrary Safety where + arbitrary = oneof $ map pure [ Unsafe + , Safe +#if MIN_VERSION_template_haskell(2,6,0) + , Interruptible +#else + , Threadsafe +#endif + ] + +instance Arbitrary Stmt where + arbitrary = oneof $ map pure [ BindS fPat fExp + , LetS [fDec] + , NoBindS fExp + , ParS [[fStmt]] + ] +-- arbitrary = oneof [ BindS <$> arbitrary <*> arbitrary +-- , LetS <$> arbitrary +-- , NoBindS <$> arbitrary +-- , ParS <$> arbitrary +-- ] + +instance Arbitrary Strict where + arbitrary = oneof $ map pure [ IsStrict + , NotStrict +#if MIN_VERSION_template_haskell(2,7,0) + , Unpacked +#endif + ] + +instance Arbitrary Type where + arbitrary = oneof [ pure $ ForallT [fTyVarBndr] [fPred] fType + , VarT <$> arbitrary + , ConT <$> arbitrary + , TupleT <$> arbitrary + , pure ArrowT + , pure ListT + , pure $ AppT fType fType + , pure $ SigT fType fKind +#if MIN_VERSION_template_haskell(2,6,0) + , UnboxedTupleT <$> arbitrary +#endif +#if MIN_VERSION_template_haskell(2,7,0) + , PromotedT <$> arbitrary + , PromotedTupleT <$> arbitrary + , pure PromotedNilT + , pure PromotedConsT + , pure StarT + , pure ConstraintT + , LitT <$> arbitrary +#endif +#if MIN_VERSION_template_haskell(2,10,0) + , pure EqualityT +#endif + ] +-- arbitrary = oneof [ ForallT <$> arbitrary <*> arbitrary <*> arbitrary +-- , VarT <$> arbitrary +-- , ConT <$> arbitrary +-- , TupleT <$> arbitrary +-- , pure ArrowT +-- , pure ListT +-- , AppT <$> arbitrary <*> arbitrary +-- , SigT <$> arbitrary <*> arbitrary +-- #if MIN_VERSION_template_haskell(2,6,0) +-- , UnboxedTupleT <$> arbitrary +-- #endif +-- #if MIN_VERSION_template_haskell(2,7,0) +-- , PromotedT <$> arbitrary +-- , PromotedTupleT <$> arbitrary +-- , pure PromotedNilT +-- , pure PromotedConsT +-- , pure StarT +-- , pure ConstraintT +-- , LitT <$> arbitrary +-- #endif +-- #if MIN_VERSION_template_haskell(2,10,0) +-- , pure EqualityT +-- #endif +-- ] + +instance Arbitrary TyVarBndr where + arbitrary = oneof [ PlainTV <$> arbitrary + , flip KindedTV fKind <$> arbitrary + ] +-- arbitrary = oneof [PlainTV <$> arbitrary, KindedTV <$> arbitrary <*> arbitrary] + +#if MIN_VERSION_template_haskell(2,5,0) && !(MIN_VERSION_template_haskell(2,7,0)) +instance Arbitrary ClassInstance where + arbitrary = ClassInstance <$> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary +#endif + +#if MIN_VERSION_template_haskell(2,8,0) +instance Arbitrary Inline where + arbitrary = oneof $ map pure [NoInline, Inline, Inlinable] + +instance Arbitrary Phases where + arbitrary = oneof [ pure AllPhases + , FromPhase <$> arbitrary + , BeforePhase <$> arbitrary + ] + +instance Arbitrary RuleBndr where + arbitrary = oneof [RuleVar <$> arbitrary, TypedRuleVar <$> arbitrary <*> arbitrary] + +instance Arbitrary RuleMatch where + arbitrary = oneof $ map pure [ConLike, FunLike] + +instance Arbitrary TyLit where + arbitrary = oneof [NumTyLit <$> arbitrary, StrTyLit <$> arbitrary] +#else +instance Arbitrary InlineSpec where + arbitrary = InlineSpec <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary Kind where + arbitrary = oneof [pure StarK, pure $ ArrowK fKind fKind] +-- arbitrary = oneof [pure StarK, ArrowK <$> arbitrary <*> arbitrary] +#endif + +#if MIN_VERSION_template_haskell(2,9,0) +instance Arbitrary AnnLookup where + arbitrary = oneof [AnnLookupModule <$> arbitrary, AnnLookupName <$> arbitrary] + +instance Arbitrary AnnTarget where + arbitrary = oneof [ pure ModuleAnnotation + , TypeAnnotation <$> arbitrary + , ValueAnnotation <$> arbitrary + ] + +instance Arbitrary Module where + arbitrary = Module <$> arbitrary <*> arbitrary + +instance Arbitrary ModuleInfo where + arbitrary = ModuleInfo <$> arbitrary + +instance Arbitrary Role where + arbitrary = oneof $ map pure [NominalR, RepresentationalR, PhantomR, InferR] + +instance Arbitrary TySynEqn where + arbitrary = TySynEqn <$> arbitrary <*> arbitrary +#endif + +#if !(MIN_VERSION_template_haskell(2,10,0)) +instance Arbitrary Pred where + arbitrary = oneof [ flip ClassP [fType] <$> arbitrary + , pure $ EqualP fType fType + ] +-- arbitrary = oneof [ ClassP <$> arbitrary <*> arbitrary +-- , EqualP <$> arbitrary <*> arbitrary +-- ] +#endif + +deriving instance Arbitrary ModName +deriving instance Arbitrary OccName +deriving instance Arbitrary PkgName + +------------------------------------------------------------------------------- +-- Workarounds to make Arbitrary instances faster +------------------------------------------------------------------------------- + +fBody :: Body +fBody = GuardedB [] + +fClause :: Clause +fClause = Clause [] fBody [] + +fCon :: Con +fCon = NormalC fName [] + +fDec :: Dec +fDec = FunD fName [] + +fExp :: Exp +fExp = TupE [] + +fFieldExp :: FieldExp +fFieldExp = (fName, fExp) + +fFieldPat :: FieldPat +fFieldPat = (fName, fPat) + +fGuard :: Guard +fGuard = PatG [] + +fKind :: Kind +#if MIN_VERSION_template_haskell(2,8,0) +fKind = fType +#else +fKind = StarK +#endif + +fMatch :: Match +fMatch = Match fPat fBody [] + +fName :: Name +fName = Name (OccName "") NameS + +fPat :: Pat +fPat = WildP + +fPred :: Pred +#if MIN_VERSION_template_haskell(2,10,0) +fPred = fType +#else +fPred = ClassP fName [] +#endif + +fRange :: Range +fRange = FromR fExp + +fStmt :: Stmt +fStmt = LetS [] + +fType :: Type +fType = ListT + +fTyVarBndr :: TyVarBndr +fTyVarBndr = PlainTV fName diff --git a/tests/Instances/System/Directory.hs b/tests/Instances/System/Directory.hs new file mode 100644 --- /dev/null +++ b/tests/Instances/System/Directory.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Instances.System.Directory +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Provides an 'Arbitrary' instance for 'Permissions'. +-} +module Instances.System.Directory () where + +#if MIN_VERSION_directory(1,1,0) +import Control.Applicative ((<**>)) +import Data.Functor ((<$>)) +import System.Directory (Permissions, emptyPermissions, setOwnerReadable, + setOwnerWritable, setOwnerExecutable, setOwnerSearchable) +import Test.Tasty.QuickCheck (Arbitrary(..)) + +instance Arbitrary Permissions where + arbitrary = ($ emptyPermissions) <$> (setOwnerReadable <$> arbitrary) + <**> (setOwnerWritable <$> arbitrary) + <**> (setOwnerExecutable <$> arbitrary) + <**> (setOwnerSearchable <$> arbitrary) +#endif diff --git a/tests/Instances/System/Locale.hs b/tests/Instances/System/Locale.hs new file mode 100644 --- /dev/null +++ b/tests/Instances/System/Locale.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Instances.System.Locale +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Provides an 'Arbitrary' instance for 'TimeLocale' values. +-} +module Instances.System.Locale () where + +#if !(MIN_VERSION_base(4,8,0)) +import Control.Applicative ((<*>)) +#endif +import Data.Functor ((<$>)) +import System.Locale (TimeLocale(..)) +import Test.Tasty.QuickCheck (Arbitrary(..)) + +instance Arbitrary TimeLocale where + arbitrary = TimeLocale <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary diff --git a/tests/Instances/System/Posix.hs b/tests/Instances/System/Posix.hs new file mode 100644 --- /dev/null +++ b/tests/Instances/System/Posix.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Instances.System.Posix +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Provides 'Arbitrary' instances for data types in the @unix@ library. +-} +module Instances.System.Posix () where + +#if !(MIN_VERSION_base(4,8,0)) +import Control.Applicative ((<*>), pure) +#endif + +import Data.Functor ((<$>)) + +import Foreign.C.Types (CInt(..)) +import Foreign.Ptr (Ptr, nullPtr, plusPtr) + +import System.Exit (ExitCode(..)) +import System.Posix.DynamicLinker (RTLDFlags(..), DL(..)) +import System.Posix.Process (ProcessStatus(..)) +import System.Posix.Types (CGid(..), CUid(..)) +import System.Posix.User (GroupEntry(..), UserEntry(..)) + +import Test.Tasty.QuickCheck (Arbitrary(..), oneof) + +instance Arbitrary RTLDFlags where + arbitrary = oneof $ map pure [RTLD_LAZY, RTLD_NOW, RTLD_GLOBAL, RTLD_LOCAL] + +instance Arbitrary DL where + arbitrary = oneof [pure Null, pure Next, pure Default, DLHandle <$> arbitrary] + +instance Arbitrary ProcessStatus where + arbitrary = oneof [ Exited <$> arbitrary + , Terminated <$> arbitrary <*> arbitrary + , Stopped <$> arbitrary + ] + +instance Arbitrary GroupEntry where + arbitrary = GroupEntry <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary UserEntry where + arbitrary = UserEntry <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary + +------------------------------------------------------------------------------- +-- Miscellaneous Arbitrary instances (taken from text-show) +------------------------------------------------------------------------------- + +instance Arbitrary ExitCode where + arbitrary = oneof [pure ExitSuccess, ExitFailure <$> arbitrary] + +instance Arbitrary (Ptr a) where + arbitrary = plusPtr nullPtr <$> arbitrary + +deriving instance Arbitrary CGid +deriving instance Arbitrary CInt +deriving instance Arbitrary CUid diff --git a/tests/Instances/System/Random.hs b/tests/Instances/System/Random.hs new file mode 100644 --- /dev/null +++ b/tests/Instances/System/Random.hs @@ -0,0 +1,19 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Instances.System.Random +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Provides an 'Arbitrary' instance for 'StdGen' values. +-} +module Instances.System.Random () where + +import Data.Functor ((<$>)) +import System.Random (StdGen, mkStdGen) +import Test.Tasty.QuickCheck (Arbitrary(..)) + +instance Arbitrary StdGen where + arbitrary = mkStdGen <$> arbitrary diff --git a/tests/Instances/System/Win32.hs b/tests/Instances/System/Win32.hs new file mode 100644 --- /dev/null +++ b/tests/Instances/System/Win32.hs diff --git a/tests/Instances/Text/PrettyPrint.hs b/tests/Instances/Text/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/tests/Instances/Text/PrettyPrint.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE CPP, StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Instances.Text.PrettyPrint +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Provides 'Arbitrary' instances for data types in the @pretty@ library +(as well as 'Show' instances if using an old version of @pretty@). +-} +module Instances.Text.PrettyPrint () where + +#if !(MIN_VERSION_base(4,8,0)) +import Control.Applicative ((<*>), pure) +#endif + +import Data.Functor ((<$>)) + +import Test.Tasty.QuickCheck (Arbitrary(..), oneof) + +import Text.PrettyPrint.HughesPJ (Doc, Mode(..), Style(..), TextDetails(..), text) +#if MIN_VERSION_pretty(1,1,2) +import Text.PrettyPrint.HughesPJClass (PrettyLevel(..)) +#endif + +instance Arbitrary Doc where + arbitrary = text <$> arbitrary + +instance Arbitrary Mode where + arbitrary = oneof $ map pure [PageMode, ZigZagMode, LeftMode, OneLineMode] + +instance Arbitrary Style where + arbitrary = Style <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary TextDetails where + arbitrary = oneof [Chr <$> arbitrary, Str <$> arbitrary, PStr <$> arbitrary] + +#if MIN_VERSION_pretty(1,1,2) +deriving instance Arbitrary PrettyLevel +#else +deriving instance Show Mode +deriving instance Show Style +deriving instance Show TextDetails +#endif diff --git a/tests/Instances/Text/XHtml.hs b/tests/Instances/Text/XHtml.hs new file mode 100644 --- /dev/null +++ b/tests/Instances/Text/XHtml.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Instances.Text.XHtml +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Provides 'Arbitrary' instances for data types in the @xhtml@ library. +-} +module Instances.Text.XHtml () where + +#if !(MIN_VERSION_base(4,8,0)) +import Control.Applicative ((<*>)) +#endif + +import Data.Functor ((<$>)) + +import Test.Tasty.QuickCheck (Arbitrary(..), Gen) + +import Text.XHtml.Frameset (Html, HtmlAttr, HotLink(..), strAttr, toHtml) +import Text.XHtml.Table (HtmlTable, cell) + +instance Arbitrary Html where + arbitrary = toHtml <$> (arbitrary :: Gen String) + +instance Arbitrary HtmlAttr where + arbitrary = strAttr <$> arbitrary <*> arbitrary + +instance Arbitrary HotLink where + arbitrary = HotLink <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary HtmlTable where + arbitrary = cell <$> (arbitrary :: Gen Html) diff --git a/tests/Instances/Trace/Hpc.hs b/tests/Instances/Trace/Hpc.hs new file mode 100644 --- /dev/null +++ b/tests/Instances/Trace/Hpc.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module: Instances.Trace.Hpc +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +Provides 'Arbitrary' instances for data types in the @hpc@ library. +-} +module Instances.Trace.Hpc () where + +#if !(MIN_VERSION_base(4,8,0)) +import Control.Applicative ((<*>), pure) +#endif + +import Data.Functor ((<$>)) + +import Test.QuickCheck.Instances () +import Test.Tasty.QuickCheck (Arbitrary(..), oneof) + +import Trace.Hpc.Mix (Mix(..), MixEntry, BoxLabel(..), CondBox(..)) +import Trace.Hpc.Tix (Tix(..), TixModule(..)) +import Trace.Hpc.Util (HpcPos, Hash, toHpcPos) + +instance Arbitrary Mix where + arbitrary = flip (flip . ((flip . (flip .)) .) . Mix) [fMixEntry] + <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary +-- arbitrary = Mix <$> arbitrary <*> arbitrary <*> arbitrary +-- <*> arbitrary <*> arbitrary + +instance Arbitrary BoxLabel where + arbitrary = oneof [ ExpBox <$> arbitrary + , TopLevelBox <$> arbitrary + , LocalBox <$> arbitrary + , BinBox <$> arbitrary <*> arbitrary + ] + +instance Arbitrary CondBox where + arbitrary = oneof $ map pure [GuardBinBox, CondBinBox, QualBinBox] + +instance Arbitrary Tix where + arbitrary = Tix <$> arbitrary + +instance Arbitrary TixModule where + arbitrary = TixModule <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary HpcPos where + arbitrary = toHpcPos <$> ((,,,) <$> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary) + +instance Arbitrary Hash where + arbitrary = fromInteger <$> arbitrary + +------------------------------------------------------------------------------- +-- Workarounds to make Arbitrary instances faster +------------------------------------------------------------------------------- + +fMixEntry :: MixEntry +fMixEntry = (toHpcPos (0, 1, 2, 3), ExpBox True) diff --git a/tests/Properties.hs b/tests/Properties.hs new file mode 100644 --- /dev/null +++ b/tests/Properties.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE CPP #-} +{-| +Module: Properties +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +@QuickCheck@ tests for @text-show-instances@. +-} +module Main (main) where + +import Properties.Control.Applicative.Trans (applicativeFunctorTransformerTests) +import Properties.Control.Monad.Trans (monadTransformerTests) +import Properties.Data.Containers (containersTests) +import Properties.Data.Functor.Trans (functorTransformerTests) +import Properties.Data.List.NonEmpty (nonEmptyListTests) +import Properties.Data.Semigroup (semigroupTests) +import Properties.Data.Tagged (taggedTests) +import Properties.Data.Time (timeTests) +import Properties.Data.UnorderedContainers (unorderedContainersTests) +import Properties.Data.Vector (vectorTests) +#if defined(mingw32_HOST_OS) +import Properties.Graphics.Win32 (win32GraphicsTests) +#endif +import Properties.Language.Haskell.TH (templateHaskellTests) +import Properties.System.Directory (directoryTests) +import Properties.System.Locale (oldLocaleTests) +#if !defined(mingw32_HOST_OS) +import Properties.System.Posix (unixTests) +#endif +import Properties.System.Random (randomTests) +import Properties.System.Time (oldTimeTests) +#if defined(mingw32_HOST_OS) +import Properties.System.Win32 (win32SystemTests) +#endif +import Properties.Text.PrettyPrint (prettyTests) +import Properties.Text.XHtml (xhtmlTests) +import Properties.Trace.Hpc (hpcTests) + +import Test.Tasty (TestTree, defaultMain, testGroup) + +main :: IO () +main = defaultMain testTree + +allTests :: [TestTree] +allTests = concat [ applicativeFunctorTransformerTests + , monadTransformerTests + , containersTests + , functorTransformerTests + , nonEmptyListTests + , semigroupTests + , taggedTests + , timeTests + , unorderedContainersTests + , vectorTests +#if defined(mingw32_HOST_OS) + , win32GraphicsTests +#endif + , templateHaskellTests + , directoryTests + , oldLocaleTests +#if !defined(mingw32_HOST_OS) + , unixTests +#endif + , randomTests + , oldTimeTests +#if defined(mingw32_HOST_OS) + , win32SystemTests +#endif + , prettyTests + , xhtmlTests + , hpcTests + ] + +testTree :: TestTree +testTree = testGroup "QuickCheck properties" allTests diff --git a/tests/Properties/Control/Applicative/Trans.hs b/tests/Properties/Control/Applicative/Trans.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/Control/Applicative/Trans.hs @@ -0,0 +1,31 @@ +{-| +Module: Properties.Control.Applicative.Trans +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +@QuickCheck@ properties for applicative functor transformers. +-} +module Properties.Control.Applicative.Trans (applicativeFunctorTransformerTests) where + +import Control.Applicative.Backwards (Backwards) +import Control.Applicative.Lift (Lift) + +import Instances.Control.Applicative.Trans () + +import Properties.Utils (prop_matchesShow) + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import Text.Show.Text.Control.Applicative.Trans () + +applicativeFunctorTransformerTests :: [TestTree] +applicativeFunctorTransformerTests = + [ testGroup "Text.Show.Text.Control.Applicative.Trans" + [ testProperty "Backwards Maybe Int instance" (prop_matchesShow :: Int -> Backwards Maybe Int -> Bool) + , testProperty "Lift Maybe Int instance" (prop_matchesShow :: Int -> Lift Maybe Int -> Bool) + ] + ] diff --git a/tests/Properties/Control/Monad/Trans.hs b/tests/Properties/Control/Monad/Trans.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/Control/Monad/Trans.hs @@ -0,0 +1,42 @@ +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} +{-| +Module: Properties.Control.Monad.Trans +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +@QuickCheck@ properties for monad transformers. +-} +module Properties.Control.Monad.Trans (monadTransformerTests) where + +import Control.Monad.Trans.Error (ErrorT) +import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.Identity (IdentityT) +import Control.Monad.Trans.List (ListT) +import Control.Monad.Trans.Maybe (MaybeT) +import qualified Control.Monad.Trans.Writer.Lazy as WL (WriterT) +import qualified Control.Monad.Trans.Writer.Strict as WS (WriterT) + +import Instances.Control.Monad.Trans () + +import Properties.Utils (prop_matchesShow) + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import Text.Show.Text.Control.Monad.Trans () + +monadTransformerTests :: [TestTree] +monadTransformerTests = + [ testGroup "Text.Show.Text.Control.Monad.Trans" + [ testProperty "ErrorT Char Maybe Int instance" (prop_matchesShow :: Int -> ErrorT Char Maybe Int -> Bool) + , testProperty "ExceptT Char Maybe Int instance" (prop_matchesShow :: Int -> ExceptT Char Maybe Int -> Bool) + , testProperty "IdentityT Maybe Int instance" (prop_matchesShow :: Int -> IdentityT Maybe Int -> Bool) + , testProperty "ListT Maybe Char instance" (prop_matchesShow :: Int -> ListT Maybe Char -> Bool) + , testProperty "Maybe [] Int instance" (prop_matchesShow :: Int -> MaybeT [] Int -> Bool) + , testProperty "lazy WriterT String Maybe Int instance" (prop_matchesShow :: Int -> WL.WriterT String Maybe Int -> Bool) + , testProperty "strict WriterT String Maybe Int instance" (prop_matchesShow :: Int -> WS.WriterT String Maybe Int -> Bool) + ] + ] diff --git a/tests/Properties/Data/Containers.hs b/tests/Properties/Data/Containers.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/Data/Containers.hs @@ -0,0 +1,42 @@ +{-| +Module: Properties.Data.Containers +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +@QuickCheck@ properties for data types in the @containers@ library. +-} +module Properties.Data.Containers (containersTests) where + +import Data.IntMap (IntMap) +import Data.IntSet (IntSet) +import Data.Map (Map) +import Data.Sequence (Seq, ViewL, ViewR) +import Data.Set (Set) +import Data.Tree (Tree) + +import Instances.Data.Containers () + +import Properties.Utils (prop_matchesShow) + +import Test.QuickCheck.Instances () +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import Text.Show.Text.Data.Containers () + +containersTests :: [TestTree] +containersTests = + [ testGroup "Text.Show.Text.Data.Containers" + [ testProperty "IntMap Char instance" (prop_matchesShow :: Int -> IntMap Char -> Bool) + , testProperty "IntSet instance" (prop_matchesShow :: Int -> IntSet -> Bool) + , testProperty "Map Char Char instance" (prop_matchesShow :: Int -> Map Char Char -> Bool) + , testProperty "Sequence Char" (prop_matchesShow :: Int -> Seq Char -> Bool) + , testProperty "ViewL Int instance" (prop_matchesShow :: Int -> ViewL Int -> Bool) + , testProperty "ViewR Int instance" (prop_matchesShow :: Int -> ViewR Int -> Bool) + , testProperty "Set Char instance" (prop_matchesShow :: Int -> Set Char -> Bool) + , testProperty "Tree Char instance" (prop_matchesShow :: Int -> Tree Char -> Bool) + ] + ] diff --git a/tests/Properties/Data/Functor/Trans.hs b/tests/Properties/Data/Functor/Trans.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/Data/Functor/Trans.hs @@ -0,0 +1,37 @@ +{-| +Module: Properties.Data.Functor.Trans +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +@QuickCheck@ properties for functor transformers. +-} +module Properties.Data.Functor.Trans (functorTransformerTests) where + +import Data.Functor.Compose (Compose) +import Data.Functor.Constant (Constant) +import Data.Functor.Product (Product) +import Data.Functor.Reverse (Reverse) +import Data.Functor.Sum (Sum) + +import Instances.Data.Functor.Trans () + +import Properties.Utils (prop_matchesShow) + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import Text.Show.Text.Data.Functor.Trans () + +functorTransformerTests :: [TestTree] +functorTransformerTests = + [ testGroup "Text.Show.Text.Data.Functor.Trans" + [ testProperty "Compose Maybe [] Char instance" (prop_matchesShow :: Int -> Compose Maybe [] Char -> Bool) + , testProperty "Constant Int Char instance" (prop_matchesShow :: Int -> Constant Int Char -> Bool) + , testProperty "Product Maybe [] Char instance" (prop_matchesShow :: Int -> Product Maybe [] Char -> Bool) + , testProperty "Reverse Maybe Int instance" (prop_matchesShow :: Int -> Reverse Maybe Int -> Bool) + , testProperty "Sum Maybe [] Char instance" (prop_matchesShow :: Int -> Sum Maybe [] Char -> Bool) + ] + ] diff --git a/tests/Properties/Data/List/NonEmpty.hs b/tests/Properties/Data/List/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/Data/List/NonEmpty.hs @@ -0,0 +1,29 @@ +{-| +Module: Properties.Data.List.NonEmpty +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +@QuickCheck@ properties for 'NonEmpty' lists. +-} +module Properties.Data.List.NonEmpty (nonEmptyListTests) where + +import Data.List.NonEmpty (NonEmpty) + +import Instances.Data.List.NonEmpty () + +import Properties.Utils (prop_matchesShow) + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import Text.Show.Text.Data.List.NonEmpty () + +nonEmptyListTests :: [TestTree] +nonEmptyListTests = + [ testGroup "Text.Show.Text.Data.List.NonEmpty" + [ testProperty "NonEmpty Char instance" (prop_matchesShow :: Int -> NonEmpty Char -> Bool) + ] + ] diff --git a/tests/Properties/Data/Semigroup.hs b/tests/Properties/Data/Semigroup.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/Data/Semigroup.hs @@ -0,0 +1,34 @@ +{-| +Module: Properties.Data.Semigroup +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +@QuickCheck@ properties for @Semigroup@ data types. +-} +module Properties.Data.Semigroup (semigroupTests) where + +import Data.Semigroup (Min, Max, First, Last, WrappedMonoid, Option) + +import Instances.Data.Semigroup () + +import Properties.Utils (prop_matchesShow) + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import Text.Show.Text.Data.Semigroup () + +semigroupTests :: [TestTree] +semigroupTests = + [ testGroup "Text.Show.Text.Data.Semigroup" + [ testProperty "Min Int instance" (prop_matchesShow :: Int -> Min Int -> Bool) + , testProperty "Max Int instance" (prop_matchesShow :: Int -> Max Int -> Bool) + , testProperty "First Int instance" (prop_matchesShow :: Int -> First Int -> Bool) + , testProperty "Last Int Char" (prop_matchesShow :: Int -> Last Int -> Bool) + , testProperty "WrappedMonoid Int instance" (prop_matchesShow :: Int -> WrappedMonoid Int -> Bool) + , testProperty "Option Int instance" (prop_matchesShow :: Int -> Option Int -> Bool) + ] + ] diff --git a/tests/Properties/Data/Tagged.hs b/tests/Properties/Data/Tagged.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/Data/Tagged.hs @@ -0,0 +1,29 @@ +{-| +Module: Properties.Data.Tagged +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +@QuickCheck@ properties for 'Tagged' values. +-} +module Properties.Data.Tagged (taggedTests) where + +import Data.Tagged (Tagged) + +import Instances.Data.Tagged () + +import Properties.Utils (prop_matchesShow) + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import Text.Show.Text.Data.Tagged () + +taggedTests :: [TestTree] +taggedTests = + [ testGroup "Text.Show.Text.Data.Tagged" + [ testProperty "Tagged Char Int instance" (prop_matchesShow :: Int -> Tagged Char Int -> Bool) + ] + ] diff --git a/tests/Properties/Data/Time.hs b/tests/Properties/Data/Time.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/Data/Time.hs @@ -0,0 +1,39 @@ +{-| +Module: Properties.Data.Time +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +@QuickCheck@ properties for data types in the @time@ library. +-} +module Properties.Data.Time (timeTests) where + +import Data.Time.Calendar (Day) +import Data.Time.Clock (DiffTime, UTCTime, NominalDiffTime) +import Data.Time.Clock.TAI (AbsoluteTime) +import Data.Time.LocalTime (TimeZone, TimeOfDay, LocalTime, ZonedTime) + +import Properties.Utils (prop_matchesShow) + +import Test.QuickCheck.Instances () +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import Text.Show.Text.Data.Time () + +timeTests :: [TestTree] +timeTests = + [ testGroup "Text.Show.Text.Data.Time" + [ testProperty "Day instance" (prop_matchesShow :: Int -> Day -> Bool) + , testProperty "DiffTime instance" (prop_matchesShow :: Int -> DiffTime -> Bool) + , testProperty "UTCTime instance" (prop_matchesShow :: Int -> UTCTime -> Bool) + , testProperty "NominalDiffTime instance" (prop_matchesShow :: Int -> NominalDiffTime -> Bool) + , testProperty "AbsoluteTime instance" (prop_matchesShow :: Int -> AbsoluteTime -> Bool) + , testProperty "TimeZone instance" (prop_matchesShow :: Int -> TimeZone -> Bool) + , testProperty "TimeOfDay instance" (prop_matchesShow :: Int -> TimeOfDay -> Bool) + , testProperty "LocalTime instance" (prop_matchesShow :: Int -> LocalTime -> Bool) + , testProperty "ZonedTime instance" (prop_matchesShow :: Int -> ZonedTime -> Bool) + ] + ] diff --git a/tests/Properties/Data/UnorderedContainers.hs b/tests/Properties/Data/UnorderedContainers.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/Data/UnorderedContainers.hs @@ -0,0 +1,30 @@ +{-| +Module: Properties.Data.UnorderedContainers +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +@QuickCheck@ properties for 'HashMap's and 'HashSet's. +-} +module Properties.Data.UnorderedContainers (unorderedContainersTests) where + +import Data.HashMap.Lazy (HashMap) +import Data.HashSet (HashSet) + +import Properties.Utils (prop_matchesShow) + +import Test.QuickCheck.Instances () +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import Text.Show.Text.Data.UnorderedContainers () + +unorderedContainersTests :: [TestTree] +unorderedContainersTests = + [ testGroup "Text.Show.Text.Data.UnorderedContainers" + [ testProperty "HashMap Char Char instance" (prop_matchesShow :: Int -> HashMap Char Char -> Bool) + , testProperty "HashSet Char instance" (prop_matchesShow :: Int -> HashSet Char -> Bool) + ] + ] diff --git a/tests/Properties/Graphics/Win32.hs b/tests/Properties/Graphics/Win32.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/Graphics/Win32.hs diff --git a/tests/Properties/Language/Haskell/TH.hs b/tests/Properties/Language/Haskell/TH.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/Language/Haskell/TH.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE CPP #-} +{-| +Module: Properties.Language.Haskell.TH +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +@QuickCheck@ properties for data types in the @template-haskell@ library. +-} +module Properties.Language.Haskell.TH (templateHaskellTests) where + +import Instances.Language.Haskell.TH () + +import Language.Haskell.TH.Syntax + +import Properties.Utils (prop_matchesShow) + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import Text.Show.Text (fromString) +import Text.Show.Text.Language.Haskell.TH (showbName') + +-- | Verifies that `showName'` and `showbName'` have the same output. +prop_showName' :: NameIs -> Name -> Bool +prop_showName' nameIs name = fromString (showName' nameIs name) == showbName' nameIs name + +templateHaskellTests :: [TestTree] +templateHaskellTests = + [ testGroup "Text.Show.Text.Language.Haskell.TH" + [ +#if MIN_VERSION_template_haskell(2,9,0) + testProperty "AnnLookup instance" (prop_matchesShow :: Int -> AnnLookup -> Bool) + , testProperty "AnnTarget instance" (prop_matchesShow :: Int -> AnnTarget -> Bool), +#endif + testProperty "Body instance" (prop_matchesShow :: Int -> Body -> Bool) + , testProperty "Callconv instance" (prop_matchesShow :: Int -> Callconv -> Bool) +#if MIN_VERSION_template_haskell(2,5,0) && !(MIN_VERSION_template_haskell(2,7,0)) + , testProperty "ClassInstance instance" (prop_matchesShow :: Int -> ClassInstance -> Bool) +#endif + , testProperty "Clause instance" (prop_matchesShow :: Int -> Clause -> Bool) + , testProperty "Con instance" (prop_matchesShow :: Int -> Con -> Bool) + , testProperty "Dec instance" (prop_matchesShow :: Int -> Dec -> Bool) + , testProperty "Exp instance" (prop_matchesShow :: Int -> Exp -> Bool) + , testProperty "FamFlavour instance" (prop_matchesShow :: Int -> FamFlavour -> Bool) + , testProperty "Fixity instance" (prop_matchesShow :: Int -> Fixity -> Bool) + , testProperty "FixityDirection instance" (prop_matchesShow :: Int -> FixityDirection -> Bool) + , testProperty "Foreign instance" (prop_matchesShow :: Int -> Foreign -> Bool) + , testProperty "FunDep instance" (prop_matchesShow :: Int -> FunDep -> Bool) + , testProperty "Guard instance" (prop_matchesShow :: Int -> Guard -> Bool) + , testProperty "Info instance" (prop_matchesShow :: Int -> Info -> Bool) +#if MIN_VERSION_template_haskell(2,8,0) + , testProperty "Inline instance" (prop_matchesShow :: Int -> Inline -> Bool) +#else + , testProperty "InlineSpec instance" (prop_matchesShow :: Int -> InlineSpec -> Bool) +#endif +#if !(MIN_VERSION_template_haskell(2,8,0)) + , testProperty "Kind instance" (prop_matchesShow :: Int -> Kind -> Bool) +#endif + , testProperty "Lit instance" (prop_matchesShow :: Int -> Lit -> Bool) + , testProperty "Loc instance" (prop_matchesShow :: Int -> Loc -> Bool) + , testProperty "Match instance" (prop_matchesShow :: Int -> Match -> Bool) + , testProperty "ModName instance" (prop_matchesShow :: Int -> ModName -> Bool) +#if MIN_VERSION_template_haskell(2,9,0) + , testProperty "Module instance" (prop_matchesShow :: Int -> Module -> Bool) + , testProperty "ModuleInfo instance" (prop_matchesShow :: Int -> ModuleInfo -> Bool) +#endif + , testProperty "Name instance" (prop_matchesShow :: Int -> Name -> Bool) + , testProperty "showbName' output" prop_showName' + , testProperty "OccName instance" (prop_matchesShow :: Int -> OccName -> Bool) + , testProperty "Pat instance" (prop_matchesShow :: Int -> Pat -> Bool) +#if MIN_VERSION_template_haskell(2,8,0) + , testProperty "Phases instance" (prop_matchesShow :: Int -> Phases -> Bool) +#endif + , testProperty "PkgName instance" (prop_matchesShow :: Int -> PkgName -> Bool) +#if !(MIN_VERSION_template_haskell(2,10,0)) + , testProperty "Pred instance" (prop_matchesShow :: Int -> Pred -> Bool) +#endif + , testProperty "Pragma instance" (prop_matchesShow :: Int -> Pragma -> Bool) + , testProperty "Range instance" (prop_matchesShow :: Int -> Range -> Bool) +#if MIN_VERSION_template_haskell(2,9,0) + , testProperty "Role instance" (prop_matchesShow :: Int -> Role -> Bool) +#endif +#if MIN_VERSION_template_haskell(2,8,0) + , testProperty "RuleBndr instance" (prop_matchesShow :: Int -> RuleBndr -> Bool) + , testProperty "RuleMatch instance" (prop_matchesShow :: Int -> RuleMatch -> Bool) +#endif + , testProperty "Safety instance" (prop_matchesShow :: Int -> Safety -> Bool) + , testProperty "Stmt instance" (prop_matchesShow :: Int -> Stmt -> Bool) + , testProperty "Strict instance" (prop_matchesShow :: Int -> Strict -> Bool) +#if MIN_VERSION_template_haskell(2,8,0) + , testProperty "TyLit instance" (prop_matchesShow :: Int -> TyLit -> Bool) +#endif + , testProperty "Type instance" (prop_matchesShow :: Int -> Type -> Bool) +#if MIN_VERSION_template_haskell(2,9,0) + , testProperty "TySynEqn instance" (prop_matchesShow :: Int -> TySynEqn -> Bool) +#endif + , testProperty "TyVarBndr instance" (prop_matchesShow :: Int -> TyVarBndr -> Bool) + ] + ] diff --git a/tests/Properties/System/Directory.hs b/tests/Properties/System/Directory.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/System/Directory.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE CPP #-} +{-| +Module: Properties.System.Directory +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +@QuickCheck@ properties for 'Permissions'. +-} +module Properties.System.Directory (directoryTests) where + +import Test.Tasty (TestTree) + +#if MIN_VERSION_directory(1,1,0) +import Instances.System.Directory () + +import Properties.Utils (prop_matchesShow) + +import System.Directory (Permissions) + +import Test.Tasty (testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import Text.Show.Text.System.Directory () +#endif + +directoryTests :: [TestTree] +directoryTests = + [ +#if MIN_VERSION_directory(1,1,0) + testGroup "Text.Show.Text.System.Directory" + [ testProperty "Permissions instance" (prop_matchesShow :: Int -> Permissions -> Bool) + ] +#endif + ] diff --git a/tests/Properties/System/Locale.hs b/tests/Properties/System/Locale.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/System/Locale.hs @@ -0,0 +1,29 @@ +{-| +Module: Properties.System.Locale +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +@QuickCheck@ properties for 'TimeLocale'. +-} +module Properties.System.Locale (oldLocaleTests) where + +import Instances.System.Locale () + +import Properties.Utils (prop_matchesShow) + +import System.Locale (TimeLocale) + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import Text.Show.Text.System.Locale () + +oldLocaleTests :: [TestTree] +oldLocaleTests = + [ testGroup "Text.Show.Text.System.Locale" + [ testProperty "TimeLocale instance" (prop_matchesShow :: Int -> TimeLocale -> Bool) + ] + ] diff --git a/tests/Properties/System/Posix.hs b/tests/Properties/System/Posix.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/System/Posix.hs @@ -0,0 +1,35 @@ +{-| +Module: Properties.System.Posix +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +@QuickCheck@ properties for data types in the @unix@ library. +-} +module Properties.System.Posix (unixTests) where + +import Instances.System.Posix () + +import Properties.Utils (prop_matchesShow) + +import System.Posix.DynamicLinker (RTLDFlags, DL) +import System.Posix.Process (ProcessStatus) +import System.Posix.User (GroupEntry, UserEntry) + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import Text.Show.Text.System.Posix () + +unixTests :: [TestTree] +unixTests = + [ testGroup "Text.Show.Text.System.Posix" + [ testProperty "RTLDFlags instance" (prop_matchesShow :: Int -> RTLDFlags -> Bool) + , testProperty "DL instance" (prop_matchesShow :: Int -> DL -> Bool) + , testProperty "ProcessStatus instance" (prop_matchesShow :: Int -> ProcessStatus -> Bool) + , testProperty "GroupEntry instance" (prop_matchesShow :: Int -> GroupEntry -> Bool) + , testProperty "UserEntry instance" (prop_matchesShow :: Int -> UserEntry -> Bool) + ] + ] diff --git a/tests/Properties/System/Random.hs b/tests/Properties/System/Random.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/System/Random.hs @@ -0,0 +1,29 @@ +{-| +Module: Properties.System.Random +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +@QuickCheck@ properties for 'StdGen' values. +-} +module Properties.System.Random (randomTests) where + +import Instances.System.Random () + +import Properties.Utils (prop_matchesShow) + +import System.Random (StdGen) + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import Text.Show.Text.System.Random () + +randomTests :: [TestTree] +randomTests = + [ testGroup "Text.Show.Text.System.Random" + [ testProperty "StdGen instance" (prop_matchesShow :: Int -> StdGen -> Bool) + ] + ] diff --git a/tests/Properties/System/Time.hs b/tests/Properties/System/Time.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/System/Time.hs @@ -0,0 +1,32 @@ +{-| +Module: Properties.System.Time +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +@QuickCheck@ properties for data types in @old-time@. +-} +module Properties.System.Time (oldTimeTests) where + +import Properties.Utils (prop_matchesShow) + +import System.Time (ClockTime, TimeDiff, CalendarTime, Month, Day) + +import Test.QuickCheck.Instances () +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import Text.Show.Text.System.Time () + +oldTimeTests :: [TestTree] +oldTimeTests = + [ testGroup "Text.Show.Text.System.Time" + [ testProperty "ClockTime instance" (prop_matchesShow :: Int -> ClockTime -> Bool) + , testProperty "TimeDiff instance" (prop_matchesShow :: Int -> TimeDiff -> Bool) + , testProperty "CalendarTime instance" (prop_matchesShow :: Int -> CalendarTime -> Bool) + , testProperty "Month instance" (prop_matchesShow :: Int -> Month -> Bool) + , testProperty "Day instance" (prop_matchesShow :: Int -> Day -> Bool) + ] + ] diff --git a/tests/Properties/System/Win32.hs b/tests/Properties/System/Win32.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/System/Win32.hs diff --git a/tests/Properties/Text/PrettyPrint.hs b/tests/Properties/Text/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/Text/PrettyPrint.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE CPP #-} +{-| +Module: Properties.Text.PrettyPrint +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +@QuickCheck@ properties for 'StdGen' values. +-} +module Properties.Text.PrettyPrint (prettyTests) where + +import Instances.Text.PrettyPrint () + +import Properties.Utils (prop_matchesShow) + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import Text.PrettyPrint.HughesPJ (Doc, Mode, Style, TextDetails) +#if MIN_VERSION_pretty(1,1,2) +import Text.PrettyPrint.HughesPJClass (TextDetails) +#endif +import Text.Show.Text.Text.PrettyPrint () + +prettyTests :: [TestTree] +prettyTests = + [ testGroup "Text.Show.Text.Text.PrettyPrint" + [ testProperty "Doc instance" (prop_matchesShow :: Int -> Doc -> Bool) + , testProperty "Mode instance" (prop_matchesShow :: Int -> Mode -> Bool) + , testProperty "Style instance" (prop_matchesShow :: Int -> Style -> Bool) + , testProperty "TextDetails instance" (prop_matchesShow :: Int -> TextDetails -> Bool) +#if MIN_VERSION_pretty(1,1,2) + , testProperty "PrettyLevel instance" (prop_matchesShow :: Int -> PrettyLevel -> Bool) +#endif + ] + ] diff --git a/tests/Properties/Text/XHtml.hs b/tests/Properties/Text/XHtml.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/Text/XHtml.hs @@ -0,0 +1,33 @@ +{-| +Module: Properties.Text.XHtml +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +@QuickCheck@ properties for data types in the @xhtml@ library. +-} +module Properties.Text.XHtml (xhtmlTests) where + +import Instances.Text.XHtml () + +import Properties.Utils (prop_matchesShow) + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import Text.Show.Text.Text.XHtml () +import Text.XHtml.Frameset (Html, HtmlAttr, HotLink) +import Text.XHtml.Table (HtmlTable) + +xhtmlTests :: [TestTree] +xhtmlTests = + [ testGroup "Text.Show.Text.Text.XHtml" + [ testProperty "Html instance" (prop_matchesShow :: Int -> Html -> Bool) + , testProperty "[Html] instance" (prop_matchesShow :: Int -> [Html] -> Bool) + , testProperty "HtmlAttr instance" (prop_matchesShow :: Int -> HtmlAttr -> Bool) + , testProperty "HotLink instance" (prop_matchesShow :: Int -> HotLink -> Bool) + , testProperty "HtmlTable instance" (prop_matchesShow :: Int -> HtmlTable -> Bool) + ] + ] diff --git a/tests/Properties/Trace/Hpc.hs b/tests/Properties/Trace/Hpc.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/Trace/Hpc.hs @@ -0,0 +1,37 @@ +{-| +Module: Properties.Trace.Hpc +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +@QuickCheck@ properties for data types in the @hpc@ library. +-} +module Properties.Trace.Hpc (hpcTests) where + +import Instances.Trace.Hpc () + +import Properties.Utils (prop_matchesShow) + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import Text.Show.Text.Trace.Hpc () + +import Trace.Hpc.Mix (Mix, BoxLabel, CondBox) +import Trace.Hpc.Tix (Tix, TixModule) +import Trace.Hpc.Util (HpcPos, Hash) + +hpcTests :: [TestTree] +hpcTests = + [ testGroup "Text.Show.Text.Trace.Hpc" + [ testProperty "Mix instance" (prop_matchesShow :: Int -> Mix -> Bool) + , testProperty "BoxLabel instance" (prop_matchesShow :: Int -> BoxLabel -> Bool) + , testProperty "CondBox instance" (prop_matchesShow :: Int -> CondBox -> Bool) + , testProperty "Tix instance" (prop_matchesShow :: Int -> Tix -> Bool) + , testProperty "TixModule instance" (prop_matchesShow :: Int -> TixModule -> Bool) + , testProperty "HpcPos instance" (prop_matchesShow :: Int -> HpcPos -> Bool) + , testProperty "Hash instance" (prop_matchesShow :: Int -> Hash -> Bool) + ] + ] diff --git a/tests/Properties/Utils.hs b/tests/Properties/Utils.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/Utils.hs @@ -0,0 +1,24 @@ +{-| +Module: Properties.Utils +Copyright: (C) 2014 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Experimental +Portability: GHC + +@QuickCheck@ property-related utility functions. +-} +module Properties.Utils (prop_matchesShow) where + +import Prelude hiding (Show) + +import Test.Tasty.QuickCheck (Arbitrary) + +import qualified Text.Show as S (Show) +import qualified Text.Show.Text as T (Show) +import Text.Show.Text (showbPrec, FromStringShow(..)) + +-- | Verifies that a type's @Show@ instances coincide for both 'String's and 'Text', +-- irrespective of precedence. +prop_matchesShow :: (S.Show a, T.Show a, Arbitrary a) => Int -> a -> Bool +prop_matchesShow p x = showbPrec p (FromStringShow x) == showbPrec p x diff --git a/text-show-instances.cabal b/text-show-instances.cabal new file mode 100644 --- /dev/null +++ b/text-show-instances.cabal @@ -0,0 +1,191 @@ +name: text-show-instances +version: 0.1 +synopsis: Additional instances for text-show +description: @text-show-instances@ is a supplemental library to @text-show@ + that provides additional @Show@ instances for data types in + common Haskell libraries not encompassed by @text-show@. + Currently, @text-show-instances@ covers these libraries: + . + * @@ DONE + * @@ DONE + * @@ DONE + * @@ DONE + * @@ DONE + * @@ DONE + * @@ DONE + * @@ DONE + * @@ DONE + * @@ DONE + * @@ DONE + * @@ DONE + * @@ DONE + * @@ DONE + * @@ DONE + * @@ NOT DONE + * @@ DONE + . + One can use these instances by importing + "Text.Show.Text.Instances". Alternatively, there are monomorphic + versions of the @showb@ function available in the other submodules + of "Text.Show.Text". +homepage: https://github.com/RyanGlScott/text-show-instances +bug-reports: https://github.com/RyanGlScott/text-show-instances/issues +license: BSD3 +license-file: LICENSE +author: Ryan Scott +maintainer: Ryan Scott +stability: Experimental +copyright: (C) 2014 Ryan Scott +category: Text +build-type: Simple +extra-source-files: CHANGELOG.md, README.md, include/inline.h +cabal-version: >=1.8 + +source-repository head + type: git + location: git://github.com/RyanGlScott/text-show-instances.git + +flag transformers-four + description: Use a recent version of @transformers@. + default: True + +library + exposed-modules: Text.Show.Text.Instances + + Text.Show.Text.Control.Applicative.Trans + Text.Show.Text.Control.Monad.Trans + Text.Show.Text.Data.Containers + Text.Show.Text.Data.Functor.Trans + Text.Show.Text.Data.List.NonEmpty + Text.Show.Text.Data.Semigroup + Text.Show.Text.Data.Tagged + Text.Show.Text.Data.Time + Text.Show.Text.Data.UnorderedContainers + Text.Show.Text.Data.Vector + Text.Show.Text.Language.Haskell.TH + Text.Show.Text.System.Directory + Text.Show.Text.System.Locale + Text.Show.Text.System.Random + Text.Show.Text.System.Time + Text.Show.Text.Text.PrettyPrint + Text.Show.Text.Text.XHtml + Text.Show.Text.Trace.Hpc + other-modules: Text.Show.Text.Control + Text.Show.Text.Data + Text.Show.Text.Graphics + Text.Show.Text.Language + Text.Show.Text.System + Text.Show.Text.Text + Text.Show.Text.Trace + Text.Show.Text.Utils + build-depends: base >= 4.2 && < 5 + , containers >= 0.1 && < 0.6 + , directory >= 1 && < 1.3 + , hpc >= 0.5 && < 0.7 + , old-locale >= 1 && < 1.1 + , old-time >= 1 && < 1.2 + , pretty >= 1 && < 1.2 + , random >= 1.0.1 && < 1.2 + , semigroups >= 0.8.4 && < 1 + , tagged >= 0.4.4 && < 1 + , template-haskell >= 2.4 && < 2.11 + , text >= 0.2 && < 1.3 + , text-show >= 0.5 && < 0.6 + , time >= 0.1 && < 1.6 + , unordered-containers >= 0.2 && < 0.3 + , vector >= 0.9 && < 0.11 + , xhtml >= 3000.2 && < 3000.3 + hs-source-dirs: src + ghc-options: -Wall + include-dirs: include + includes: inline.h + install-includes: inline.h + + if flag(transformers-four) + build-depends: transformers >= 0.4 && < 0.5 + else + build-depends: transformers >= 0.2.1 && < 0.4 + , transformers-compat >= 0.3 && < 1 + + if os(windows) + build-depends: Win32 >= 2.1 && < 2.4 + exposed-modules: Text.Show.Text.Graphics.Win32 + Text.Show.Text.System.Win32 + else + build-depends: unix >= 2 && < 2.8 + exposed-modules: Text.Show.Text.System.Posix + +test-suite text-show-instances-properties + type: exitcode-stdio-1.0 + main-is: Properties.hs + other-modules: Instances.Control.Applicative.Trans + Instances.Control.Monad.Trans + Instances.Data.Containers + Instances.Data.Functor.Trans + Instances.Data.List.NonEmpty + Instances.Data.Semigroup + Instances.Data.Tagged + Instances.Language.Haskell.TH + Instances.System.Directory + Instances.System.Locale + Instances.System.Random + Instances.Text.PrettyPrint + Instances.Text.XHtml + Instances.Trace.Hpc + Properties.Control.Applicative.Trans + Properties.Control.Monad.Trans + Properties.Data.Containers + Properties.Data.Functor.Trans + Properties.Data.List.NonEmpty + Properties.Data.Semigroup + Properties.Data.Tagged + Properties.Data.Time + Properties.Data.UnorderedContainers + Properties.Language.Haskell.TH + Properties.System.Directory + Properties.System.Locale + Properties.System.Random + Properties.System.Time + Properties.Text.PrettyPrint + Properties.Text.XHtml + Properties.Trace.Hpc + Properties.Utils + build-depends: base >= 4.5 && < 5 + , containers >= 0.1 && < 0.6 + , directory >= 1 && < 1.3 + , hpc >= 0.5 && < 0.7 + , old-locale >= 1 && < 1.1 + , old-time >= 1 && < 1.2 + , pretty >= 1 && < 1.2 + , quickcheck-instances >= 0.1 && < 0.4 + , random >= 1.0.1 && < 1.2 + , semigroups >= 0.8.4 && < 1 + , tagged >= 0.4.4 && < 1 + , tasty >= 0.8 && < 0.11 + , tasty-quickcheck >= 0.8 && < 0.9 + , template-haskell >= 2.4 && < 2.11 + , text-show >= 0.5 && < 0.6 + , text-show-instances == 0.1 + , time >= 0.1 && < 1.6 + , unordered-containers >= 0.2 && < 0.3 + , vector >= 0.9 && < 0.11 + , xhtml >= 3000.2 && < 3000.3 + hs-source-dirs: tests + ghc-options: -Wall + + if flag(transformers-four) + build-depends: transformers >= 0.4 && < 0.5 + else + build-depends: transformers >= 0.2.1 && < 0.4 + , transformers-compat >= 0.3 && < 1 + + if os(windows) + build-depends: Win32 >= 2.1 && < 2.4 + other-modules: Instances.Graphics.Win32 + Instances.System.Win32 + Properties.Graphics.Win32 + Properties.System.Win32 + else + build-depends: unix >= 2 && < 2.8 + other-modules: Instances.System.Posix + Properties.System.Posix