regular-extras 0.2.2 → 0.2.3

raw patch · 9 files changed

+543/−537 lines, 9 filesdep ~QuickChecksetup-changed

Dependency ranges changed: QuickCheck

Files

ChangeLog +12/−10
LICENSE +28/−28
Setup.hs +6/−6
examples/Test.hs +94/−94
regular-extras.cabal +49/−45
src/Generics/Regular/Functions/Arbitrary.hs +141/−141
src/Generics/Regular/Functions/Binary.hs +88/−88
src/Generics/Regular/Functions/Fixpoints.hs +68/−68
src/Generics/Regular/Functions/Seq.hs +57/−57

ChangeLog view

@@ -1,11 +1,13 @@-version 0.2.2: Add support for QuickCheck 2--version 0.2.1: relax dependency on QuickCheck--version 0.2.0: add gdseq (using the deepseq package for base cases)--version 0.1.2: fix bug on hfixpoints--version 0.1.1: fix dependency on regular-+version 0.2.3: Expand accepted versions of QuickCheck 2
+
+version 0.2.2: Add support for QuickCheck 2
+
+version 0.2.1: relax dependency on QuickCheck
+
+version 0.2.0: add gdseq (using the deepseq package for base cases)
+
+version 0.1.2: fix bug on hfixpoints
+
+version 0.1.1: fix dependency on regular
+
 version 0.1: initial release

LICENSE view

@@ -1,28 +1,28 @@-Copyright (c) 2009 Universiteit Utrecht-All rights reserved.--Redistribution and use in source and binary forms, with or without modification,-are permitted provided that the following conditions are met:--1. Redistributions of source code must retain the above copyright notice, this-   list of conditions and the following disclaimer.--2. Redistributions in binary form must reproduce the above copyright notice,-   this list of conditions and the following disclaimer in the documentation-   and/or other materials provided with the distribution.--3. Neither the name of Universiteit Utrecht nor the names of its contributors-   may be used to endorse or promote products derived from this software without-   specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND-ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE-DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 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.-+Copyright (c) 2009 Universiteit Utrecht
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without modification,
+are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice, this
+   list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright notice,
+   this list of conditions and the following disclaimer in the documentation
+   and/or other materials provided with the distribution.
+
+3. Neither the name of Universiteit Utrecht nor the names of its contributors
+   may be used to endorse or promote products derived from this software without
+   specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 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.
+

Setup.hs view

@@ -1,6 +1,6 @@-module Main (main) where--import Distribution.Simple--main :: IO ()-main = defaultMain+module Main (main) where
+
+import Distribution.Simple
+
+main :: IO ()
+main = defaultMain

examples/Test.hs view

@@ -1,94 +1,94 @@-{-# LANGUAGE FlexibleInstances        #-}-{-# LANGUAGE OverlappingInstances     #-}-{-# LANGUAGE TypeOperators            #-}-{-# LANGUAGE TypeFamilies             #-}-{-# LANGUAGE TemplateHaskell          #-}-{-# LANGUAGE EmptyDataDecls           #-}--{-# OPTIONS_GHC -fno-warn-missing-methods #-}--module Test where--import Generics.Regular-import Generics.Regular.Functions.Arbitrary-import Generics.Regular.Functions.Binary-import Generics.Regular.Functions.Seq--import Test.QuickCheck (quickCheck, sized, elements, generate, Gen)-import qualified Test.QuickCheck as Q (Arbitrary(..))-import Data.Binary.Put (runPut)-import Data.Binary.Get (runGet)-import System.Random (newStdGen)-import Data.List (sort, group)----- Datatype representing logical expressions-data Logic = Var String-           | Logic :->:  Logic  -- implication-           | Logic :<->: Logic  -- equivalence-           | Logic :&&:  Logic  -- and (conjunction)-           | Logic :||:  Logic  -- or (disjunction)-           | Not Logic          -- not-           | T                  -- true-           | F                  -- false-           deriving (Eq, Show)---- Instantiating Regular for Logic using TH-$(deriveAll ''Logic "PFLogic")-type instance PF Logic = PFLogic---- Simple datatype for testing data generation-data Choice = A1 | A2 | A3 | A4-  deriving (Show, Eq, Ord)---- Instantiating Regular for Choice using TH-$(deriveAll ''Choice "PFChoice")-type instance PF Choice = PFChoice--------------------------------------------------------------------------------- Testing arbitrary-ex1 = do -        let c arb = newStdGen >>= \r -> return $ generate 123 r arb-            arb1, arb2 :: Gen Choice-            arb1 = arbitrary-            arb2 = sized (arbitraryWith [("A1",1),("A2",1),("A3",3),("A4",5)])-            pp c = sequence (take 10000 (repeat c)) >>=-                     return . map (\x -> (head x, length x)) . group . sort-        c1 <- pp (c arb1)-        c2 <- pp (c arb2)-        putStrLn ("Normal arbitrary: " ++ show c1)-        putStrLn ("Custom arbitrary: " ++ show c2)---- Note that we use overlapping instances for this-instance Arbitrary (K String) where-  harbitrary _ _ _ _ = return $ fmap K $ elements ["p", "q"]--ex2 = do-        let c arb = newStdGen >>= \r -> return $ generate 123 r arb-            arbShort, arbLong :: Gen Logic-            arbShort = arbitraryWith [("Var", 3),("T", 3),("F", 3)] 3-            arbLong  = arbitraryWith [] 20-        c1 <- c arbShort-        c2 <- c arbLong-        putStrLn ("Short expression: " ++ show c1)-        putStrLn ("Long expression: " ++ show c2)---- Testing binary-instance Q.Arbitrary Choice where-  arbitrary = arbitrary--instance Q.Arbitrary Logic where-  arbitrary = arbitrary---- To keep the compiler happy-instance Q.Arbitrary Char---- Testing that deserializing after serializing is the identity-ex3 = let propC :: Choice -> Bool-          propC x = runGet gget (runPut (gput x)) == x-          propL :: Logic -> Bool-          propL x = runGet gget (runPut (gput x)) == x-      in quickCheck propC >> quickCheck propL---- Testing deep seq-ex4 = gdseq (Not (T :->: (error "deep seq works"))) ()+{-# LANGUAGE FlexibleInstances        #-}
+{-# LANGUAGE OverlappingInstances     #-}
+{-# LANGUAGE TypeOperators            #-}
+{-# LANGUAGE TypeFamilies             #-}
+{-# LANGUAGE TemplateHaskell          #-}
+{-# LANGUAGE EmptyDataDecls           #-}
+
+{-# OPTIONS_GHC -fno-warn-missing-methods #-}
+
+module Test where
+
+import Generics.Regular
+import Generics.Regular.Functions.Arbitrary
+import Generics.Regular.Functions.Binary
+import Generics.Regular.Functions.Seq
+
+import Test.QuickCheck (quickCheck, sized, elements, generate, Gen)
+import qualified Test.QuickCheck as Q (Arbitrary(..))
+import Data.Binary.Put (runPut)
+import Data.Binary.Get (runGet)
+import System.Random (newStdGen)
+import Data.List (sort, group)
+
+
+-- Datatype representing logical expressions
+data Logic = Var String
+           | Logic :->:  Logic  -- implication
+           | Logic :<->: Logic  -- equivalence
+           | Logic :&&:  Logic  -- and (conjunction)
+           | Logic :||:  Logic  -- or (disjunction)
+           | Not Logic          -- not
+           | T                  -- true
+           | F                  -- false
+           deriving (Eq, Show)
+
+-- Instantiating Regular for Logic using TH
+$(deriveAll ''Logic "PFLogic")
+type instance PF Logic = PFLogic
+
+-- Simple datatype for testing data generation
+data Choice = A1 | A2 | A3 | A4
+  deriving (Show, Eq, Ord)
+
+-- Instantiating Regular for Choice using TH
+$(deriveAll ''Choice "PFChoice")
+type instance PF Choice = PFChoice
+
+----------------------------------------------------------------------------
+-- Testing arbitrary
+ex1 = do 
+        let c arb = newStdGen >>= \r -> return $ generate 123 r arb
+            arb1, arb2 :: Gen Choice
+            arb1 = arbitrary
+            arb2 = sized (arbitraryWith [("A1",1),("A2",1),("A3",3),("A4",5)])
+            pp c = sequence (take 10000 (repeat c)) >>=
+                     return . map (\x -> (head x, length x)) . group . sort
+        c1 <- pp (c arb1)
+        c2 <- pp (c arb2)
+        putStrLn ("Normal arbitrary: " ++ show c1)
+        putStrLn ("Custom arbitrary: " ++ show c2)
+
+-- Note that we use overlapping instances for this
+instance Arbitrary (K String) where
+  harbitrary _ _ _ _ = return $ fmap K $ elements ["p", "q"]
+
+ex2 = do
+        let c arb = newStdGen >>= \r -> return $ generate 123 r arb
+            arbShort, arbLong :: Gen Logic
+            arbShort = arbitraryWith [("Var", 3),("T", 3),("F", 3)] 3
+            arbLong  = arbitraryWith [] 20
+        c1 <- c arbShort
+        c2 <- c arbLong
+        putStrLn ("Short expression: " ++ show c1)
+        putStrLn ("Long expression: " ++ show c2)
+
+-- Testing binary
+instance Q.Arbitrary Choice where
+  arbitrary = arbitrary
+
+instance Q.Arbitrary Logic where
+  arbitrary = arbitrary
+
+-- To keep the compiler happy
+instance Q.Arbitrary Char
+
+-- Testing that deserializing after serializing is the identity
+ex3 = let propC :: Choice -> Bool
+          propC x = runGet gget (runPut (gput x)) == x
+          propL :: Logic -> Bool
+          propL x = runGet gget (runPut (gput x)) == x
+      in quickCheck propC >> quickCheck propL
+
+-- Testing deep seq
+ex4 = gdseq (Not (T :->: (error "deep seq works"))) ()

regular-extras.cabal view

@@ -1,45 +1,49 @@-name:                   regular-extras-version:                0.2.2-synopsis:               Additional functions for regular: arbitrary,-                        coarbitrary, and binary get/put.-description:--  Additional functions for the regular [1] generic programming library, such-  as arbitrary, coarbitrary, and binary get/put. These are not bundled with the-  library because they introduce dependencies on additional packages.-  .-  \[1] <http://hackage.haskell.org/package/regular>--category:               Generics-copyright:              (c) 2010 Universiteit Utrecht-license:                BSD3-license-file:           LICENSE-author:                 Jose Pedro Magalhaes,-                        Sebastiaan Visser-maintainer:             generics@haskell.org-stability:              experimental-build-type:             Custom-cabal-version:          >= 1.2.1-tested-with:            GHC == 6.10.4, GHC == 6.12.1-extra-source-files:     examples/Test.hs-                        ChangeLog--flag quickcheck2-  description:          Are we using Quickcheck 2?-  default:              True--library-  hs-source-dirs:       src-  exposed-modules:      Generics.Regular.Functions.Arbitrary,-                        Generics.Regular.Functions.Binary,-                        Generics.Regular.Functions.Seq--  other-modules:        Generics.Regular.Functions.Fixpoints-  -  build-depends:        base >= 4.0 && < 5, regular >= 0.3 && < 0.4,-                        binary >= 0.2, deepseq < 2-  if flag(quickcheck2)-    build-depends:      QuickCheck >= 2.1 && < 2.5-  else-    build-depends:      QuickCheck >= 1.2 && < 1.3-  ghc-options:          -Wall+name:                   regular-extras
+version:                0.2.3
+synopsis:               Additional functions for regular: arbitrary,
+                        coarbitrary, and binary get/put.
+description:
+
+  Additional functions for the regular [1] generic programming library, such
+  as arbitrary, coarbitrary, and binary get/put. These are not bundled with the
+  library because they introduce dependencies on additional packages.
+  .
+  \[1] <http://hackage.haskell.org/package/regular>
+
+category:               Generics
+copyright:              (c) 2010 Universiteit Utrecht
+license:                BSD3
+license-file:           LICENSE
+author:                 Jose Pedro Magalhaes,
+                        Sebastiaan Visser
+maintainer:             generics@haskell.org
+stability:              experimental
+build-type:             Custom
+cabal-version:          >= 1.6
+tested-with:            GHC == 6.10.4, GHC == 6.12.1
+extra-source-files:     examples/Test.hs
+                        ChangeLog
+
+source-repository head
+  type: git
+  location: https://github.com/dreixel/regular-extras
+
+flag quickcheck2
+  description:          Are we using Quickcheck 2?
+  default:              True
+
+library
+  hs-source-dirs:       src
+  exposed-modules:      Generics.Regular.Functions.Arbitrary,
+                        Generics.Regular.Functions.Binary,
+                        Generics.Regular.Functions.Seq
+
+  other-modules:        Generics.Regular.Functions.Fixpoints
+  
+  build-depends:        base >= 4.0 && < 5, regular >= 0.3 && < 0.4,
+                        binary >= 0.2, deepseq < 2
+  if flag(quickcheck2)
+    build-depends:      QuickCheck >= 2.1 && < 2.7
+  else
+    build-depends:      QuickCheck >= 1.2 && < 1.3
+  ghc-options:          -Wall

src/Generics/Regular/Functions/Arbitrary.hs view

@@ -1,141 +1,141 @@-{-# LANGUAGE FlexibleContexts         #-}-{-# LANGUAGE FlexibleInstances        #-}-{-# LANGUAGE OverlappingInstances     #-}-{-# LANGUAGE ScopedTypeVariables      #-}-{-# LANGUAGE TypeOperators            #-}-{-# LANGUAGE CPP                      #-}--{-# OPTIONS_GHC -fno-warn-orphans     #-}---------------------------------------------------------------------------------- |--- Module      :  Generics.Regular.Functions.Arbitrary--- Copyright   :  (c) 2009 Universiteit Utrecht--- License     :  BSD3------ Maintainer  :  generics@haskell.org--- Stability   :  experimental--- Portability :  non-portable------ Summary: Generic "Test.QuickCheck" instances.--------------------------------------------------------------------------------module Generics.Regular.Functions.Arbitrary (-  -    -- * Generic arbitrary functionality-    FrequencyTable, Arbitrary(..), arbitraryWith, arbitrary,-    -    -- * Generic coarbitrary functionality-    CoArbitrary(..), corbitrary-  -  ) where--import Generics.Regular.Functions.Fixpoints-import Generics.Regular.Functions.ConNames-import Generics.Regular.Base--import Test.QuickCheck (Gen, frequency, sized, variant)-import qualified Test.QuickCheck as Q-import Data.Maybe (fromJust)---- | A frequency table detailing how often certain constructors should be--- picked. The 'String' corresponds to the constructor name, as returned by--- 'Generics.Regular.Functions.ConNames.conNames'.-type FrequencyTable = [(String,Int)]--frequencies :: [String] -> FrequencyTable -> Int-frequencies [] _ = 0-frequencies (s:ss) ft = let freqs = case lookup s ft of-                                      Just f  -> f-                                      Nothing -> 1-                        in freqs + frequencies ss ft---- | Generic Arbitrary class-class Arbitrary f where -  harbitrary :: (Int -> Gen a) -> FrequencyTable -> Int -> Int-             -> Maybe (Gen (f a))--instance (Fixpoints f, Fixpoints g, ConNames f, Arbitrary f,-            ConNames g, Arbitrary g) => Arbitrary (f :+: g) where-  harbitrary r ft _ n = -    let (Node ff fg)   = hFixpoints (undefined :: (f :+: g) a)-        fConNames      = hconNames (undefined :: f a)-        gConNames      = hconNames (undefined :: g a)-        fFrequency     = calcFreq n (sumTree ff) (frequencies fConNames ft)-        gFrequency     = calcFreq n (sumTree fg) (frequencies gConNames ft)-        calcFreq 0 0 _ = 1-        calcFreq 0 _ _ = 0-        calcFreq _ _ d = d-        rl = maybe [] (\x -> [(fFrequency,fmap L x)]) -               (harbitrary r ft (sumTree ff) n)-        rr = maybe [] (\x -> [(gFrequency,fmap R x)])-               (harbitrary r ft (sumTree fg) n)-    in if null (rl ++ rr) then Nothing else return $ frequency $ rl ++ rr--instance (Arbitrary f, Constructor c) => Arbitrary (C c f) where-  harbitrary r ft m n = fmap (fmap C) (harbitrary r ft m n)-                       -instance Arbitrary I where-  harbitrary r _ m n = return $ fmap I $ r (n `div` m)--instance Arbitrary U where-  harbitrary _ _ _ _ = return $ return U--instance (Q.Arbitrary a) => Arbitrary (K a) where-  harbitrary _ _ _ _ = return $ fmap K $ Q.arbitrary--instance (Arbitrary f, Arbitrary g) => Arbitrary (f :*: g) where-  harbitrary r ft m n = do rl <- harbitrary r ft m n-                           rr <- harbitrary r ft m n-                           return $ do-                             x <- rl-                             y <- rr-                             return (x :*: y)---- | Generic arbitrary function, sized and with custom constructor frequencies.---- This function does not require any particular--- nesting order of the sums of the generic representation, but it does require--- every constructor to be properly tagged with C. Representations generated--- with the supplied Template Haskell code are compliant.-arbitraryWith :: (Regular a, Arbitrary (PF a))-           => FrequencyTable -> Int -> Gen a-arbitraryWith ft = fmap to . fromJust . harbitrary (arbitraryWith ft) ft 1---- | Generic arbitrary function with default sizes and constructor frequencies.-arbitrary :: (Regular a, Arbitrary (PF a)) => Gen a-arbitrary = sized (arbitraryWith [])----- | Generic CoArbitrary class-class CoArbitrary f where -  hcoarbitrary :: (b -> Gen a -> Gen a) -> Int -> f b -> Gen a -> Gen a--instance (CoArbitrary f, CoArbitrary g, ConNames g)-            => CoArbitrary (f :+: g) where-  hcoarbitrary r n (L x) = hcoarbitrary r n x-  hcoarbitrary r n (R x) = hcoarbitrary r (n + length (hconNames x)) x--instance (CoArbitrary f, Constructor c) => CoArbitrary (C c f) where-  hcoarbitrary r n (C x) = variant n . hcoarbitrary r n x--instance CoArbitrary I where-  hcoarbitrary r _ (I x) = r x--instance CoArbitrary U where-  hcoarbitrary _ _ _ = id--#if MIN_VERSION_QuickCheck(2,1,0)-instance (Q.CoArbitrary a) => CoArbitrary (K a) where-#else-instance (Q.Arbitrary a) => CoArbitrary (K a) where-#endif-  hcoarbitrary _ _ (K a) = Q.coarbitrary a--instance (CoArbitrary f, CoArbitrary g) => CoArbitrary (f :*: g) where-  hcoarbitrary r n (x1 :*: x2) = hcoarbitrary r n x1 . hcoarbitrary r n x2---- | Generic coarbitrary function.-corbitrary :: (Regular b, CoArbitrary (PF b))-           => b -> Gen a -> Gen a-corbitrary = hcoarbitrary corbitrary 0 . from+{-# LANGUAGE FlexibleContexts         #-}
+{-# LANGUAGE FlexibleInstances        #-}
+{-# LANGUAGE OverlappingInstances     #-}
+{-# LANGUAGE ScopedTypeVariables      #-}
+{-# LANGUAGE TypeOperators            #-}
+{-# LANGUAGE CPP                      #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans     #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Regular.Functions.Arbitrary
+-- Copyright   :  (c) 2009 Universiteit Utrecht
+-- License     :  BSD3
+--
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Summary: Generic "Test.QuickCheck" instances.
+-----------------------------------------------------------------------------
+
+module Generics.Regular.Functions.Arbitrary (
+  
+    -- * Generic arbitrary functionality
+    FrequencyTable, Arbitrary(..), arbitraryWith, arbitrary,
+    
+    -- * Generic coarbitrary functionality
+    CoArbitrary(..), corbitrary
+  
+  ) where
+
+import Generics.Regular.Functions.Fixpoints
+import Generics.Regular.Functions.ConNames
+import Generics.Regular.Base
+
+import Test.QuickCheck (Gen, frequency, sized, variant)
+import qualified Test.QuickCheck as Q
+import Data.Maybe (fromJust)
+
+-- | A frequency table detailing how often certain constructors should be
+-- picked. The 'String' corresponds to the constructor name, as returned by
+-- 'Generics.Regular.Functions.ConNames.conNames'.
+type FrequencyTable = [(String,Int)]
+
+frequencies :: [String] -> FrequencyTable -> Int
+frequencies [] _ = 0
+frequencies (s:ss) ft = let freqs = case lookup s ft of
+                                      Just f  -> f
+                                      Nothing -> 1
+                        in freqs + frequencies ss ft
+
+-- | Generic Arbitrary class
+class Arbitrary f where 
+  harbitrary :: (Int -> Gen a) -> FrequencyTable -> Int -> Int
+             -> Maybe (Gen (f a))
+
+instance (Fixpoints f, Fixpoints g, ConNames f, Arbitrary f,
+            ConNames g, Arbitrary g) => Arbitrary (f :+: g) where
+  harbitrary r ft _ n = 
+    let (Node ff fg)   = hFixpoints (undefined :: (f :+: g) a)
+        fConNames      = hconNames (undefined :: f a)
+        gConNames      = hconNames (undefined :: g a)
+        fFrequency     = calcFreq n (sumTree ff) (frequencies fConNames ft)
+        gFrequency     = calcFreq n (sumTree fg) (frequencies gConNames ft)
+        calcFreq 0 0 _ = 1
+        calcFreq 0 _ _ = 0
+        calcFreq _ _ d = d
+        rl = maybe [] (\x -> [(fFrequency,fmap L x)]) 
+               (harbitrary r ft (sumTree ff) n)
+        rr = maybe [] (\x -> [(gFrequency,fmap R x)])
+               (harbitrary r ft (sumTree fg) n)
+    in if null (rl ++ rr) then Nothing else return $ frequency $ rl ++ rr
+
+instance (Arbitrary f, Constructor c) => Arbitrary (C c f) where
+  harbitrary r ft m n = fmap (fmap C) (harbitrary r ft m n)
+                       
+instance Arbitrary I where
+  harbitrary r _ m n = return $ fmap I $ r (n `div` m)
+
+instance Arbitrary U where
+  harbitrary _ _ _ _ = return $ return U
+
+instance (Q.Arbitrary a) => Arbitrary (K a) where
+  harbitrary _ _ _ _ = return $ fmap K $ Q.arbitrary
+
+instance (Arbitrary f, Arbitrary g) => Arbitrary (f :*: g) where
+  harbitrary r ft m n = do rl <- harbitrary r ft m n
+                           rr <- harbitrary r ft m n
+                           return $ do
+                             x <- rl
+                             y <- rr
+                             return (x :*: y)
+
+-- | Generic arbitrary function, sized and with custom constructor frequencies.
+
+-- This function does not require any particular
+-- nesting order of the sums of the generic representation, but it does require
+-- every constructor to be properly tagged with C. Representations generated
+-- with the supplied Template Haskell code are compliant.
+arbitraryWith :: (Regular a, Arbitrary (PF a))
+           => FrequencyTable -> Int -> Gen a
+arbitraryWith ft = fmap to . fromJust . harbitrary (arbitraryWith ft) ft 1
+
+-- | Generic arbitrary function with default sizes and constructor frequencies.
+arbitrary :: (Regular a, Arbitrary (PF a)) => Gen a
+arbitrary = sized (arbitraryWith [])
+
+
+-- | Generic CoArbitrary class
+class CoArbitrary f where 
+  hcoarbitrary :: (b -> Gen a -> Gen a) -> Int -> f b -> Gen a -> Gen a
+
+instance (CoArbitrary f, CoArbitrary g, ConNames g)
+            => CoArbitrary (f :+: g) where
+  hcoarbitrary r n (L x) = hcoarbitrary r n x
+  hcoarbitrary r n (R x) = hcoarbitrary r (n + length (hconNames x)) x
+
+instance (CoArbitrary f, Constructor c) => CoArbitrary (C c f) where
+  hcoarbitrary r n (C x) = variant n . hcoarbitrary r n x
+
+instance CoArbitrary I where
+  hcoarbitrary r _ (I x) = r x
+
+instance CoArbitrary U where
+  hcoarbitrary _ _ _ = id
+
+#if MIN_VERSION_QuickCheck(2,1,0)
+instance (Q.CoArbitrary a) => CoArbitrary (K a) where
+#else
+instance (Q.Arbitrary a) => CoArbitrary (K a) where
+#endif
+  hcoarbitrary _ _ (K a) = Q.coarbitrary a
+
+instance (CoArbitrary f, CoArbitrary g) => CoArbitrary (f :*: g) where
+  hcoarbitrary r n (x1 :*: x2) = hcoarbitrary r n x1 . hcoarbitrary r n x2
+
+-- | Generic coarbitrary function.
+corbitrary :: (Regular b, CoArbitrary (PF b))
+           => b -> Gen a -> Gen a
+corbitrary = hcoarbitrary corbitrary 0 . from

src/Generics/Regular/Functions/Binary.hs view

@@ -1,88 +1,88 @@-{-# LANGUAGE FlexibleContexts         #-}-{-# LANGUAGE TypeOperators            #-}---------------------------------------------------------------------------------- |--- Module      :  Generics.Regular.Functions.Binary--- Copyright   :  (c) 2009 Universiteit Utrecht--- License     :  BSD3------ Maintainer  :  generics@haskell.org--- Stability   :  experimental--- Portability :  non-portable------ Generic Data.Binary instances.------ These generic functions can be used to create a "Data.Binary" instance. For--- example, for a user-defined type @MyType@, the following code is necessary:------ > import Data.Binary--- > import Generics.Regular.Base--- > import Generics.Regular.Binary--- >--- > data MyType = ...--- >--- > $(deriveAll ''MyType "PFMyType")--- > type instance PF MyType = PFMyType--- >--- > instance Binary MyType where--- >   put = gput--- >   get = gget-----------------------------------------------------------------------------------module Generics.Regular.Functions.Binary (-    -    -- * Binary put and get-    Binary, gput, gget-    -  ) where--import Control.Applicative-import Generics.Regular.Base-import qualified Data.Binary as B---- * Generic Data.Binary instances.--class Binary f where-  hput :: (r -> B.Put)   -> f r -> B.Put-  hget :: (     B.Get r) ->        B.Get (f r)--instance Binary I where-  hput f (I x) = f x-  hget f       = I <$> f--instance B.Binary a => Binary (K a) where-  hput _ (K x) = B.put x-  hget _       = K <$> B.get--instance Binary U where-  hput _ _ = B.put ()-  hget _   = return U--instance (Binary f, Binary g) => Binary (f :+: g) where-  hput t (L x) = B.put True  >> hput t x-  hput t (R y) = B.put False >> hput t y-  hget t       = B.get >>= \v -> if v then L <$> hget t else R <$> hget t--instance (Binary f, Binary g) => Binary (f :*: g) where-  hput t (x :*: y) = hput t x >> hput t y-  hget t           = (:*:) <$> hget t <*> hget t--instance Binary f => Binary (C c f) where-  hput t (C x) = hput t x-  hget t       = C <$> hget t--instance Binary f => Binary (S s f) where-  hput t (S x) = hput t x-  hget t       = S <$> hget t---- | Generic binary @put@ to be used with "Data.Binary.Put".--gput :: (Regular a, Binary (PF a)) => a -> B.Put-gput p = hput (\q -> gput q) (from p)---- | Generic binary @get@ to be used with "Data.Binary.Get".--gget :: (Regular a, Binary (PF a)) => B.Get a-gget = to <$> hget gget+{-# LANGUAGE FlexibleContexts         #-}
+{-# LANGUAGE TypeOperators            #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Regular.Functions.Binary
+-- Copyright   :  (c) 2009 Universiteit Utrecht
+-- License     :  BSD3
+--
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Generic Data.Binary instances.
+--
+-- These generic functions can be used to create a "Data.Binary" instance. For
+-- example, for a user-defined type @MyType@, the following code is necessary:
+--
+-- > import Data.Binary
+-- > import Generics.Regular.Base
+-- > import Generics.Regular.Binary
+-- >
+-- > data MyType = ...
+-- >
+-- > $(deriveAll ''MyType "PFMyType")
+-- > type instance PF MyType = PFMyType
+-- >
+-- > instance Binary MyType where
+-- >   put = gput
+-- >   get = gget
+--
+-----------------------------------------------------------------------------
+
+module Generics.Regular.Functions.Binary (
+    
+    -- * Binary put and get
+    Binary, gput, gget
+    
+  ) where
+
+import Control.Applicative
+import Generics.Regular.Base
+import qualified Data.Binary as B
+
+-- * Generic Data.Binary instances.
+
+class Binary f where
+  hput :: (r -> B.Put)   -> f r -> B.Put
+  hget :: (     B.Get r) ->        B.Get (f r)
+
+instance Binary I where
+  hput f (I x) = f x
+  hget f       = I <$> f
+
+instance B.Binary a => Binary (K a) where
+  hput _ (K x) = B.put x
+  hget _       = K <$> B.get
+
+instance Binary U where
+  hput _ _ = B.put ()
+  hget _   = return U
+
+instance (Binary f, Binary g) => Binary (f :+: g) where
+  hput t (L x) = B.put True  >> hput t x
+  hput t (R y) = B.put False >> hput t y
+  hget t       = B.get >>= \v -> if v then L <$> hget t else R <$> hget t
+
+instance (Binary f, Binary g) => Binary (f :*: g) where
+  hput t (x :*: y) = hput t x >> hput t y
+  hget t           = (:*:) <$> hget t <*> hget t
+
+instance Binary f => Binary (C c f) where
+  hput t (C x) = hput t x
+  hget t       = C <$> hget t
+
+instance Binary f => Binary (S s f) where
+  hput t (S x) = hput t x
+  hget t       = S <$> hget t
+
+-- | Generic binary @put@ to be used with "Data.Binary.Put".
+
+gput :: (Regular a, Binary (PF a)) => a -> B.Put
+gput p = hput (\q -> gput q) (from p)
+
+-- | Generic binary @get@ to be used with "Data.Binary.Get".
+
+gget :: (Regular a, Binary (PF a)) => B.Get a
+gget = to <$> hget gget

src/Generics/Regular/Functions/Fixpoints.hs view

@@ -1,68 +1,68 @@-{-# LANGUAGE FlexibleContexts         #-}-{-# LANGUAGE TypeOperators            #-}-{-# LANGUAGE ScopedTypeVariables      #-}---------------------------------------------------------------------------------- |--- Module      :  Generics.Regular.Functions.Fixpoints--- Copyright   :  (c) 2009 Universiteit Utrecht--- License     :  BSD3------ Maintainer  :  generics@haskell.org--- Stability   :  experimental--- Portability :  non-portable------ Summary: Auxiliary module for "Generics.Regular.Functions.Fixpoints".--------------------------------------------------------------------------------module Generics.Regular.Functions.Fixpoints (--    Fixpoints(..), fixpoints,-    Tree(..), foldTree, sumTree-    -  ) where--import Generics.Regular.Base----- | Tree structure to store fixed points as found in the data type.-data Tree a = Leaf a | Node (Tree a) (Tree a)- deriving Show--foldTree :: (a -> b) -> (b -> b -> b) -> Tree a -> b-foldTree l _ (Leaf x)    = l x-foldTree l n (Node x y)  = (foldTree l n x) `n` (foldTree l n y)--sumTree :: Tree Int -> Int-sumTree = foldTree id (+)---- | The class to compute fixed points.-class Fixpoints f where -    hFixpoints :: f a -> Tree Int--instance (Fixpoints f, Fixpoints g) => Fixpoints (f :+: g) where-    hFixpoints (_ :: (f :+: g) a) = -      Node (hFixpoints (undefined :: f a))-           (hFixpoints (undefined :: g a))-    -instance (Fixpoints f, Constructor c) => Fixpoints (C c f) where-    hFixpoints (_ :: (C c f) a) = hFixpoints (undefined :: f a)--instance (Fixpoints f, Fixpoints g) => Fixpoints (f :*: g) where-    hFixpoints (_ :: (f :*: g) a) = -      let Leaf m = hFixpoints (undefined :: f a)-          Leaf n = hFixpoints (undefined :: g a)-      in Leaf (m + n)--instance Fixpoints I where-    hFixpoints _ = Leaf 1--instance Fixpoints U where-    hFixpoints _ = Leaf 0--instance Fixpoints (K a) where-    hFixpoints _ = Leaf 0---- | Return a tree structure of the fixed points of a datatype-fixpoints :: (Regular a, Fixpoints (PF a)) => a -> Tree Int-fixpoints x = hFixpoints (undefined `asTypeOf` (from x))+{-# LANGUAGE FlexibleContexts         #-}
+{-# LANGUAGE TypeOperators            #-}
+{-# LANGUAGE ScopedTypeVariables      #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Regular.Functions.Fixpoints
+-- Copyright   :  (c) 2009 Universiteit Utrecht
+-- License     :  BSD3
+--
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Summary: Auxiliary module for "Generics.Regular.Functions.Fixpoints".
+-----------------------------------------------------------------------------
+
+module Generics.Regular.Functions.Fixpoints (
+
+    Fixpoints(..), fixpoints,
+    Tree(..), foldTree, sumTree
+    
+  ) where
+
+import Generics.Regular.Base
+
+
+-- | Tree structure to store fixed points as found in the data type.
+data Tree a = Leaf a | Node (Tree a) (Tree a)
+ deriving Show
+
+foldTree :: (a -> b) -> (b -> b -> b) -> Tree a -> b
+foldTree l _ (Leaf x)    = l x
+foldTree l n (Node x y)  = (foldTree l n x) `n` (foldTree l n y)
+
+sumTree :: Tree Int -> Int
+sumTree = foldTree id (+)
+
+-- | The class to compute fixed points.
+class Fixpoints f where 
+    hFixpoints :: f a -> Tree Int
+
+instance (Fixpoints f, Fixpoints g) => Fixpoints (f :+: g) where
+    hFixpoints (_ :: (f :+: g) a) = 
+      Node (hFixpoints (undefined :: f a))
+           (hFixpoints (undefined :: g a))
+    
+instance (Fixpoints f, Constructor c) => Fixpoints (C c f) where
+    hFixpoints (_ :: (C c f) a) = hFixpoints (undefined :: f a)
+
+instance (Fixpoints f, Fixpoints g) => Fixpoints (f :*: g) where
+    hFixpoints (_ :: (f :*: g) a) = 
+      let Leaf m = hFixpoints (undefined :: f a)
+          Leaf n = hFixpoints (undefined :: g a)
+      in Leaf (m + n)
+
+instance Fixpoints I where
+    hFixpoints _ = Leaf 1
+
+instance Fixpoints U where
+    hFixpoints _ = Leaf 0
+
+instance Fixpoints (K a) where
+    hFixpoints _ = Leaf 0
+
+-- | Return a tree structure of the fixed points of a datatype
+fixpoints :: (Regular a, Fixpoints (PF a)) => a -> Tree Int
+fixpoints x = hFixpoints (undefined `asTypeOf` (from x))

src/Generics/Regular/Functions/Seq.hs view

@@ -1,57 +1,57 @@-{-# LANGUAGE TypeOperators            #-}-{-# LANGUAGE FlexibleContexts         #-}-{-# LANGUAGE FlexibleInstances        #-}---------------------------------------------------------------------------------- |--- Module      :  Generics.Regular.Functions.Seq--- Copyright   :  (c) 2009 Universiteit Utrecht--- License     :  BSD3------ Maintainer  :  generics@haskell.org--- Stability   :  experimental--- Portability :  non-portable------ Summary: Deep generic seq. Used to fully evaluate a term.--------------------------------------------------------------------------------module Generics.Regular.Functions.Seq (-  -    Seq(..), gdseq-  -  ) where--import Control.DeepSeq-import Generics.Regular.Base---- | The class for generic deep seq.-class Seq f where-  gseq :: (a -> b -> b) -> f a -> b -> b--instance Seq I where-  gseq f (I x) = f x---- | For constants we rely on the |DeepSeq| class.-instance (NFData a) => Seq (K a) where-  gseq _ (K x) = deepseq x-  -instance Seq U where-  gseq _ U = id--instance (Seq f, Seq g) => Seq (f :+: g) where-  gseq f (L x) = gseq f x-  gseq f (R y) = gseq f y--instance (Seq f, Seq g) => Seq (f :*: g) where-  gseq f (x :*: y) = gseq f x . gseq f y--instance Seq f => Seq (C c f) where-  gseq f (C x) = gseq f x--instance Seq f => Seq (S s f) where-  gseq f (S x) = gseq f x----- | Deep, generic version of seq.-gdseq :: (Regular a, Seq (PF a)) => a -> b -> b-gdseq p = gseq gdseq (from p)+{-# LANGUAGE TypeOperators            #-}
+{-# LANGUAGE FlexibleContexts         #-}
+{-# LANGUAGE FlexibleInstances        #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Regular.Functions.Seq
+-- Copyright   :  (c) 2009 Universiteit Utrecht
+-- License     :  BSD3
+--
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Summary: Deep generic seq. Used to fully evaluate a term.
+-----------------------------------------------------------------------------
+
+module Generics.Regular.Functions.Seq (
+  
+    Seq(..), gdseq
+  
+  ) where
+
+import Control.DeepSeq
+import Generics.Regular.Base
+
+-- | The class for generic deep seq.
+class Seq f where
+  gseq :: (a -> b -> b) -> f a -> b -> b
+
+instance Seq I where
+  gseq f (I x) = f x
+
+-- | For constants we rely on the |DeepSeq| class.
+instance (NFData a) => Seq (K a) where
+  gseq _ (K x) = deepseq x
+  
+instance Seq U where
+  gseq _ U = id
+
+instance (Seq f, Seq g) => Seq (f :+: g) where
+  gseq f (L x) = gseq f x
+  gseq f (R y) = gseq f y
+
+instance (Seq f, Seq g) => Seq (f :*: g) where
+  gseq f (x :*: y) = gseq f x . gseq f y
+
+instance Seq f => Seq (C c f) where
+  gseq f (C x) = gseq f x
+
+instance Seq f => Seq (S s f) where
+  gseq f (S x) = gseq f x
+
+
+-- | Deep, generic version of seq.
+gdseq :: (Regular a, Seq (PF a)) => a -> b -> b
+gdseq p = gseq gdseq (from p)