packages feed

regular-extras (empty) → 0.1

raw patch · 8 files changed

+454/−0 lines, 8 filesdep +QuickCheckdep +basedep +binarybuild-type:Customsetup-changed

Dependencies added: QuickCheck, base, binary, regular

Files

+ ChangeLog view
@@ -0,0 +1,1 @@+version 0.1: initial release
+ LICENSE view
@@ -0,0 +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.+
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ examples/Test.hs view
@@ -0,0 +1,90 @@+{-# 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 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
+ regular-extras.cabal view
@@ -0,0 +1,37 @@+name:                   regular-extras+version:                0.1+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) 2009 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+extra-source-files:     examples/Test.hs+                        ChangeLog+++library+  hs-source-dirs:       src+  exposed-modules:      Generics.Regular.Functions.Arbitrary,+                        Generics.Regular.Functions.Binary++  other-modules:        Generics.Regular.Functions.Fixpoints+  +  build-depends:        base >= 4.0 && < 5, regular >= 0.1,+                        QuickCheck == 1.2.0.0, binary >= 0.2+  ghc-options:          -Wall
+ src/Generics/Regular/Functions/Arbitrary.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE FlexibleContexts         #-}+{-# LANGUAGE FlexibleInstances        #-}+{-# LANGUAGE OverlappingInstances     #-}+{-# LANGUAGE ScopedTypeVariables      #-}+{-# LANGUAGE TypeOperators            #-}++{-# 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 (Arbitrary, arbitrary, coarbitrary)+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++instance (Q.Arbitrary a) => CoArbitrary (K a) where+  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
@@ -0,0 +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
+ src/Generics/Regular/Functions/Fixpoints.hs view
@@ -0,0 +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 :: f b)+      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))