├── Setup.lhs ├── .gitignore ├── Test ├── Feat.hs └── Feat │ ├── Class.hs │ ├── Modifiers.hs │ ├── Finite.hs │ ├── Driver.hs │ ├── Access.hs │ └── Enumerate.hs ├── LICENSE ├── examples ├── lambda-terms │ └── lambdas.hs ├── haskell-src-exts │ └── hse.hs └── template-haskell │ └── th.hs └── testing-feat.cabal /Setup.lhs: -------------------------------------------------------------------------------- 1 | > import Distribution.Simple 2 | > main :: IO () 3 | > main = defaultMain 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | deps 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | .virtualenv 9 | .hsenv 10 | .cabal-sandbox/ 11 | cabal.sandbox.config 12 | cabal.config 13 | -------------------------------------------------------------------------------- /Test/Feat.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} 2 | 3 | -- | This module contains a (hopefully) manageable subset of the functionality 4 | -- of Feat. The rest resides only in the Test.Feat.* modules. 5 | module Test.Feat( 6 | 7 | -- * Testing driver 8 | test, 9 | testOptions, 10 | Options(..), 11 | defOptions, 12 | 13 | 14 | -- * The type class 15 | Enumerate(), 16 | Enumerable(..), datatype, c0, c1, c2, c3, c4, c5, c6, c7, 17 | 18 | -- ** Automatic derivation 19 | deriveEnumerable, 20 | 21 | 22 | -- * Accessing data 23 | optimal, 24 | index, 25 | select, 26 | values, 27 | uniform, 28 | 29 | 30 | ) where 31 | 32 | import Test.Feat.Access 33 | -- import Test.Feat.Class 34 | import Test.Feat.Enumerate 35 | import Test.Feat.Driver 36 | import Control.Enumerable 37 | 38 | 39 | -- import Test.Feat.Modifiers 40 | -------------------------------------------------------------------------------- /Test/Feat/Class.hs: -------------------------------------------------------------------------------- 1 | 2 | module Test.Feat.Class {-# DEPRECATED "Use Control.Enumerable instead" #-} 3 | ( Enumerable(..) 4 | , nullary 5 | , unary 6 | , funcurry 7 | , shared 8 | , consts 9 | , deriveEnumerable 10 | ) where 11 | 12 | import Control.Enumerable 13 | 14 | -- compatability 15 | {-# DEPRECATED nullary "use c0 instead" #-} 16 | -- nullary :: x -> Memoizable f x 17 | nullary x = c0 x 18 | 19 | {-# DEPRECATED unary "use c1 instead" #-} 20 | -- unary :: (Enumerable a, MemoSized f) => (a -> x) -> f x 21 | unary x = c1 x 22 | 23 | {-# DEPRECATED shared "use access instead" #-} 24 | shared :: (Sized f, Enumerable a, Typeable f) => Shareable f a 25 | shared = access 26 | 27 | 28 | funcurry = uncurry 29 | 30 | {-# DEPRECATED consts "use datatype instead" #-} 31 | --consts :: (Typeable a, MemoSized f) => [f a] -> Closed (f a) 32 | consts xs = datatype xs 33 | -------------------------------------------------------------------------------- /Test/Feat/Modifiers.hs: -------------------------------------------------------------------------------- 1 | -- | Modifiers for types, i.e. newtype wrappers where the values satisfy some 2 | -- constraint (non-empty, positive etc.). Suggestions on useful types are 3 | -- appreciated. 4 | -- 5 | -- To apply the modifiers types you can use the record label. For instance: 6 | -- 7 | -- @ 8 | -- data C a = C [a] [a] deriving 'Typeable' 9 | -- instance 'Enumerable' a => 'Enumerable' (C a) where 10 | -- 'enumerate' = 'c2' $ 11 | -- \\xs ys -> C ('nonEmpty' xs) ('nonEmpty' ys) 12 | -- @ 13 | -- 14 | -- Alternatively you can put everything in pattern postition: 15 | -- 16 | -- @ 17 | -- instance 'Enumerable' a => 'Enumerable' (C a) where 18 | -- 'enumerate' = 'unary' $ 'funcurry' $ 19 | -- \\('Free' ('NonEmpty' xs,'NonEmpty' ys)) -> C xs ys) 20 | -- @ 21 | -- 22 | -- The first approach has the advantage of being usable with a 23 | -- point free style: @ \\xs -> C ('nonEmpty' xs) . 'nonEmpty' @. 24 | module Test.Feat.Modifiers (module Data.Modifiers) where 25 | 26 | import Data.Modifiers 27 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c)2011, Jonas Duregård 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Jonas Duregård nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Test/Feat/Finite.hs: -------------------------------------------------------------------------------- 1 | -- | A datatype of finite sequences 2 | module Test.Feat.Finite (Finite (..), Index, fromFinite, finFin) where 3 | 4 | import Control.Applicative 5 | import Data.Semigroup 6 | import Data.Monoid 7 | 8 | type Index = Integer 9 | data Finite a = Finite {fCard :: Index, fIndex :: Index -> a} 10 | 11 | finEmpty = Finite 0 (\i -> error "index: Empty") 12 | 13 | finUnion :: Finite a -> Finite a -> Finite a 14 | finUnion f1 f2 15 | | fCard f1 == 0 = f2 16 | | fCard f2 == 0 = f1 17 | | otherwise = Finite car sel where 18 | car = fCard f1 + fCard f2 19 | sel i = if i < fCard f1 20 | then fIndex f1 i 21 | else fIndex f2 (i-fCard f1) 22 | 23 | instance Functor Finite where 24 | fmap f fin = fin{fIndex = f . fIndex fin} 25 | 26 | instance Applicative Finite where 27 | pure = finPure 28 | a <*> b = fmap (uncurry ($)) (finCart a b) 29 | 30 | instance Alternative Finite where 31 | empty = finEmpty 32 | (<|>) = finUnion 33 | 34 | instance Semigroup (Finite a) where 35 | (<>) = finUnion 36 | 37 | instance Monoid (Finite a) where 38 | mempty = finEmpty 39 | mappend = finUnion 40 | mconcat xs = Finite 41 | (sum $ map fCard xs) 42 | (sumSel $ filter ((>0) . fCard) xs) 43 | 44 | sumSel :: [Finite a] -> (Index -> a) 45 | sumSel (f:rest) = \i -> if i < fCard f 46 | then fIndex f i 47 | else sumSel rest (i-fCard f) 48 | sumSel _ = error "Index out of bounds" 49 | 50 | finCart :: Finite a -> Finite b -> Finite (a,b) 51 | finCart f1 f2 = Finite car sel where 52 | car = fCard f1 * fCard f2 53 | sel i = let (q, r) = (i `quotRem` fCard f2) 54 | in (fIndex f1 q, fIndex f2 r) 55 | 56 | finPure :: a -> Finite a 57 | finPure a = Finite 1 one where 58 | one 0 = a 59 | one _ = error "Index out of bounds" 60 | 61 | 62 | fromFinite :: Finite a -> (Index,[a]) 63 | fromFinite (Finite c ix) = (c,map ix [0..c-1]) 64 | 65 | 66 | instance Show a => Show (Finite a) where 67 | show = show . fromFinite 68 | 69 | finFin :: Integer -> Finite Integer 70 | finFin k | k <= 0 = finEmpty 71 | finFin k = Finite k (\i -> i) 72 | 73 | -------------------------------------------------------------------------------- /examples/lambda-terms/lambdas.hs: -------------------------------------------------------------------------------- 1 | -- This module contains an enumeration of well scoped lambda terms 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | 4 | import Test.Feat.Enumerate 5 | import Control.Enumerable 6 | import Test.Feat.Access 7 | import Test.Feat 8 | 9 | -- Shows off a bit 10 | main = do 11 | putStr "There are this many closed lambda terms with 100 lambdas/applications: " 12 | let n = count 100 13 | print n 14 | putStr $ "Here is one of them: " 15 | putStrLn $ pretty (selectTerm 100 (n `div` 2)) 16 | putStrLn "Here are all the terms of size 3:" 17 | mapM_ (putStrLn . pretty) (snd $ vs !! 3) 18 | 19 | 20 | data Term scope = Lam (Term (FinS scope)) 21 | | App (Term scope) (Term scope) 22 | | Var scope 23 | deriving (Show, Typeable) 24 | instance Enumerable a => Enumerable (Term a) where 25 | enumerate = share $ aconcat 26 | [ c1 Var -- Variables are size 0, add pay to make size 1 27 | , pay (c1 Lam) -- "Irregular constructor" 28 | , pay (c2 App)] 29 | 30 | -- Finite numeric types 31 | data FinZ deriving Typeable 32 | instance Show FinZ where 33 | show _ = undefined 34 | instance Enumerable FinZ where 35 | enumerate = datatype [] 36 | data FinS n = Z | S n deriving (Typeable, Show) 37 | instance Enumerable n => Enumerable (FinS n) where 38 | enumerate = share $ aconcat [c0 Z, c1 S] 39 | 40 | -- All closed lambda expressions 41 | closed = global :: Enumerate (Term FinZ) 42 | vs = valuesWith closed 43 | 44 | -- Count the number of terms of a given size 45 | count n = fst $ vs !! n 46 | 47 | -- Select any term of a given size 48 | selectTerm = selectWith closed 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | -- The rest is just pretty-printing stuff 58 | pretty :: Fin a => Term a -> String 59 | pretty t = prettyPar 0 0 t where 60 | -- p: 0-never 1-lambda 2-always 61 | prettyPar :: Fin a => Int -> Int -> Term a -> String 62 | prettyPar _ _ (Var s) = "x"++show (toInt s) 63 | prettyPar n p (Lam t) = par 1 p $ "\\x"++show n++"->"++prettyPar (n+1) 0 t 64 | prettyPar n p (App t1 t2) = par 2 p $ 65 | prettyPar n 1 t1 ++ " " ++ prettyPar n 2 t2 66 | par p p' s = if p <= p' then "(" ++ s ++ ")" else s 67 | 68 | class Fin a where 69 | toInt :: a -> Int 70 | 71 | instance Fin FinZ where 72 | toInt a = a `seq` error "toInt FinZ" 73 | 74 | instance Fin n => Fin (FinS n) where 75 | toInt Z = 0 76 | toInt (S n) = toInt n + 1 77 | -------------------------------------------------------------------------------- /testing-feat.cabal: -------------------------------------------------------------------------------- 1 | Name: testing-feat 2 | Version: 1.1.0.0 3 | Synopsis: Functional Enumeration of Algebraic Types 4 | Description: Feat (Functional Enumeration of Algebraic Types) provides 5 | enumerations as functions from natural numbers to values 6 | (similar to @toEnum@ but for any algebraic data type). This 7 | can be used for SmallCheck-style systematic testing, 8 | QuickCheck style random testing, and hybrids of the two. 9 | . 10 | The enumerators are defined in a very boilerplate manner 11 | and there is a Template Haskell script for deriving the 12 | class instance for most types. 13 | "Test.Feat" contain a subset of the other modules that 14 | should be sufficient for most test usage. There 15 | are some small and large example in the tar 16 | ball. 17 | . 18 | The generators are provided by the size-based package. This means other libraries that implement the Sized class can use the same generator definitions. One such is the 19 | , that uses laziness to search for values and test properties. This is typically a lot faster than Feat for properties that have preconditions (logical implication), but can not be used for random selection of values. 20 | 21 | License: BSD3 22 | License-file: LICENSE 23 | Author: Jonas Duregård 24 | Maintainer: jonas.duregard@gmail.com 25 | Homepage: https://github.com/JonasDuregard/testing-feat 26 | Copyright: Jonas Duregård 27 | Category: Testing 28 | Build-type: Simple 29 | Extra-source-files: 30 | examples/template-haskell/th.hs 31 | examples/haskell-src-exts/hse.hs 32 | examples/lambda-terms/lambdas.hs 33 | Cabal-version: >=1.6 34 | source-repository head 35 | type: git 36 | location: https://github.com/JonasDuregard/testing-feat 37 | Library 38 | 39 | Hs-source-dirs: . 40 | Exposed-modules: 41 | Test.Feat, 42 | Test.Feat.Finite, 43 | Test.Feat.Enumerate, 44 | Test.Feat.Access 45 | Test.Feat.Driver 46 | 47 | -- Compatibility 48 | Test.Feat.Modifiers 49 | Test.Feat.Class 50 | 51 | Build-depends: 52 | base >= 4.5 && < 5, 53 | QuickCheck > 2 && < 3, 54 | size-based < 0.2, 55 | testing-type-modifiers < 0.2 56 | if impl(ghc < 8.0) 57 | Build-depends: semigroups < 0.19 58 | -------------------------------------------------------------------------------- /Test/Feat/Driver.hs: -------------------------------------------------------------------------------- 1 | -- | A simple testing driver for testing properties using FEAT. 2 | -- Contains three drivers with different levels of flexibility of configuration. 3 | -- 4 | -- Ironically, this code is mostly untested at the moment. 5 | module Test.Feat.Driver( 6 | -- * Simple test driver 7 | test 8 | -- * Test driver with show/readable options 9 | , testOptions 10 | , Options(..) 11 | , defOptions 12 | -- * Extremely flexible test driver 13 | , testFlex 14 | , Result(..) 15 | , FlexibleOptions(..) 16 | , FlexOptions(..) 17 | , defFlex 18 | , toFlex 19 | , toFlexWith 20 | ) where 21 | 22 | import Control.Enumerable 23 | import Test.Feat.Access 24 | import Test.Feat.Finite 25 | import Test.Feat.Enumerate 26 | 27 | import System.Timeout 28 | import Data.IORef 29 | 30 | -- | Basic options for executing a test. Unlike 'FlexibleOptions' this type has Show/Read instances. 31 | data Options = Options 32 | { oTimeoutSec :: Maybe Int 33 | , oSizeFromTo :: Maybe (Int,Int) -- ^ (first size, last size) 34 | , oMaxCounter :: Maybe Int -- ^ Maximum number of counterexamples 35 | , oSilent :: Bool 36 | , oSkipping :: Maybe (Index, Integer) -- ^ (start-index, steps to skip) 37 | , oBounded :: Maybe Integer -- ^ Maximum number of tests per size 38 | } deriving (Show,Read) 39 | 40 | -- | Much more flexible options for configuring every part of the test execution. 41 | -- @a@ is the parameter type of the property. 42 | type FlexibleOptions a = IO (FlexOptions a) 43 | 44 | -- | FlexOptions 45 | data FlexOptions a = FlexOptions 46 | { fIO :: IO Bool -> IO (Result,[a]) -- ^ The whole execution of the test is sent through this function. 47 | , fReport :: a -> IO Bool -- ^ Applied to each found counterexample, return False to stop testing 48 | , fOutput :: String -> IO () -- ^ Print text 49 | , fProcess :: Enumerate a -> Enumerate a -- ^ Applied to the enumeration before running 50 | , fEnum :: Enumerate a -- ^ The base enumeration to use, before applying @fProcess@. 51 | } 52 | 53 | data Result = Exhausted -- ^ Reached max size 54 | | Quota -- ^ Reached max number of counterexamples 55 | | TimedOut 56 | | Other 57 | deriving Show 58 | 59 | -- | 60 seconds timeout, maximum size of 100, bound of 100000 tests per size 60 | defOptions :: Options 61 | defOptions = Options 62 | { oTimeoutSec = Just 60 63 | , oSizeFromTo = Just (0,100) 64 | , oSilent = False 65 | , oSkipping = Nothing 66 | , oBounded = Just 100000 67 | , oMaxCounter = Just 1 68 | } 69 | 70 | defFlex :: Enumerable a => FlexibleOptions a 71 | defFlex = defFlexWith optimal 72 | 73 | -- | For testing without using the 'Enumerable' class. 74 | defFlexWith :: Enumerate a -> FlexibleOptions a 75 | defFlexWith e = toFlexWith e defOptions 76 | 77 | toFlex :: Enumerable a => Options -> FlexibleOptions a 78 | toFlex = toFlexWith optimal 79 | 80 | toFlexWith :: Enumerate a -> Options -> FlexibleOptions a 81 | toFlexWith e o = do 82 | res <- newIORef [] 83 | count <- newIORef 0 84 | let doReport x = do 85 | modifyIORef res (x:) 86 | modifyIORef count (+1) 87 | maybe (return True) (checkCount) (oMaxCounter o) 88 | checkCount mx = do 89 | n <- readIORef count 90 | return (n < mx) 91 | doIO io = do 92 | mb <- maybe (fmap Just io) (\t -> timeout (t*1000000) io) (oTimeoutSec o) 93 | res <- readIORef res 94 | return $ maybe (TimedOut,res) (\b -> if b then (Exhausted,res) else (Quota,res)) mb 95 | skip = maybe id (\(i,n) e -> skipping e i n) (oSkipping o) 96 | bound = maybe id (\n e -> bounded e n) (oBounded o) 97 | sizes = maybe id (\bs e -> sizeRange e bs) (oSizeFromTo o) 98 | return $ FlexOptions 99 | { fIO = doIO 100 | , fOutput = if oSilent o then const (return ()) else putStr 101 | , fReport = doReport 102 | , fProcess = bound . skip . sizes 103 | , fEnum = e 104 | } 105 | 106 | -- | Test with default options ('defOptions'). Returns a list of counterexamples 107 | test :: Enumerable a => (a -> Bool) -> IO [a] 108 | test = testOptions defOptions 109 | 110 | -- | Test with basic options. Returns a list of counterexamples. 111 | testOptions :: Enumerable a => Options -> (a -> Bool) -> IO [a] 112 | testOptions o p = fmap snd $ testFlex fo p 113 | where 114 | fo = toFlex o 115 | 116 | -- | The most flexible test driver, can be configured to behave in almost any way. 117 | testFlex :: FlexibleOptions a -> (a -> Bool) -> IO (Result, [a]) 118 | testFlex ioOp p = do 119 | op <- ioOp 120 | let e = fProcess op (fEnum op) 121 | lazyResult = [(n,filter (not . p) xs) | (n,xs) <- valuesWith e] 122 | runSize k (n,cs) = do 123 | fOutput op $ "*** Searching in " ++ show n ++ " values of size " ++ show k ++ "\n" 124 | doWhile (map (\x -> fOutput op "Counterexample found!\n" >> fReport op x) cs) 125 | rxs@(r,_) <- fIO op ((doWhile $ zipWith runSize [0..] lazyResult)) 126 | case r of 127 | Exhausted -> fOutput op "Search space exhausted\n" 128 | TimedOut -> fOutput op "Timed out\n" 129 | _ -> return () 130 | return rxs 131 | 132 | 133 | doWhile :: [IO Bool] -> IO Bool 134 | doWhile [] = return True 135 | doWhile (iob:iobs) = iob >>= \b -> if b then doWhile iobs else return False 136 | 137 | -------------------------------------------------------------------------------- /Test/Feat/Access.hs: -------------------------------------------------------------------------------- 1 | -- | Functions for accessing the values of enumerations including 2 | -- compatibility with the property based testing framework QuickCheck 3 | module Test.Feat.Access( 4 | -- * Accessing functions 5 | optimal, 6 | index, 7 | select, 8 | values, 9 | 10 | -- * QuickCheck Compatibility 11 | uniform, 12 | 13 | -- * Combinators 14 | skipping, 15 | bounded, 16 | sizeRange, 17 | 18 | -- * Non-class versions of the access functions 19 | indexWith, 20 | selectWith, 21 | valuesWith, 22 | uniformWith 23 | )where 24 | 25 | import Test.Feat.Enumerate 26 | import Control.Enumerable 27 | --import Data.Modifiers 28 | 29 | -- base 30 | import Data.List 31 | import Data.Ratio((%)) 32 | 33 | 34 | -- quickcheck 35 | import Test.QuickCheck(choose,Gen) 36 | 37 | -- | Memoised enumeration. Note that all cardinalities are kept in memory until your program terminates. 38 | optimal :: Enumerable a => Enumerate a 39 | optimal = global 40 | 41 | -- | Index into an enumeration. Mainly used for party tricks (give it a really large number), since usually you want to distinguish values by size. 42 | index :: Enumerable a => Integer -> a 43 | index = indexWith optimal 44 | 45 | -- | A more fine grained version of index that takes a size and an 46 | -- index into the values of that size. @select p i@ is only defined 47 | -- for @i@ within bounds (meaning @i < fst (values !! p)@). 48 | select :: Enumerable a => Int -> Index -> a 49 | select = selectWith optimal 50 | 51 | {- 52 | -- Not too happy with this phantom argument 53 | countThese :: Enumerable a => a -> Int -> Integer 54 | countThese x k = help x (drop k $ parts optimal) where 55 | help :: a -> [Finite a] -> Integer 56 | help _ [] = 0 57 | help _ (f:_) = fCard f 58 | -} 59 | 60 | -- | All values of the enumeration by increasing cost (which is the number 61 | -- of constructors for most types). Also contains the length of each list. 62 | values :: Enumerable a => [(Integer,[a])] 63 | values = valuesWith optimal 64 | 65 | 66 | -- | Compatibility with QuickCheck. Distribution is uniform generator over 67 | -- values bounded by the given size. Typical use: @sized uniform@. 68 | uniform :: Enumerable a => Int -> Gen a 69 | uniform = uniformWith optimal 70 | 71 | -- | Non class version of 'index'. 72 | indexWith :: Enumerate a -> Integer -> a 73 | indexWith e i0 = go (parts e) i0 where 74 | go (Finite crd ix : ps) i = if i < crd then ix i else go ps (i-crd) 75 | go [] _ = error $ "index out of bounds: "++show i0 76 | 77 | 78 | -- | Non class version of 'select' 79 | selectWith :: Enumerate a -> Int -> Index -> a 80 | selectWith e p i = fIndex (parts e !! p) i 81 | 82 | 83 | -- | Non class version of 'values'. 84 | valuesWith :: Enumerate a -> [(Integer,[a])] 85 | valuesWith = map fromFinite . parts 86 | 87 | -- | Non class version of 'uniform'. 88 | uniformWith :: Enumerate a -> Int -> Gen a 89 | uniformWith = uni . parts where 90 | uni :: [Finite a] -> Int -> Gen a 91 | uni [] _ = error "uniform: empty enumeration" 92 | uni ps maxp = let (incl, rest) = splitAt maxp ps 93 | fin = mconcat incl 94 | in case fCard fin of 95 | 0 -> uni rest 1 96 | _ -> do i <- choose (0,fCard fin-1) 97 | return (fIndex fin i) 98 | 99 | 100 | -- | Enumerates every nth value of the enumeration from a given starting index. 101 | -- As a special case @striped 0 1@ gives all values (starts at index 0 and takes steps of 1). 102 | -- 103 | -- Useful for running enumerations in parallel since e.g. @striped 0 2@ is 104 | -- disjoint from @striped 1 2@ and the union of the two cover all values. 105 | skipping :: Enumerate a -> Index -> Integer -> Enumerate a 106 | skipping _ o0 step | step <= 0 || o0 < 0 = error "skippingWith: invalid argument" 107 | skipping e o0 step = fromParts $ go o0 (parts e) where 108 | go o [] = [] 109 | go o _ | o < 0 = error "negative" 110 | go o (p:ps) = p' : go o' ps where -- error (show (space,take,o')) : 111 | space = fCard p - o 112 | (take,o') | space <= 0 = (0,o-fCard p) 113 | | space < step = (1,step-space) 114 | | otherwise = (space `quotRem` step) 115 | p' = Finite{fCard = take 116 | , fIndex = \i -> fIndex p (i*step + o)} 117 | 118 | -- | A version of values with a limited number of values in each inner list. 119 | -- If the list corresponds to a Part which is larger than the bound it evenly 120 | -- distributes the values across the enumeration of the Part. 121 | bounded :: Enumerate a -> Integer -> Enumerate a 122 | bounded e n = fromParts $ map (samplePart n) $ parts e where 123 | -- The first value is at index 0 and the last value is at index ~= crd - step 124 | -- This is "fair" if we consider using samplePart on the next part as well. 125 | -- An alternative would be to make the last index used |crd-1|. 126 | samplePart :: Index -> Finite a -> Finite a 127 | samplePart m f@(Finite crd ix) = 128 | let step = crd % m 129 | in if crd <= m 130 | then f 131 | else Finite{fCard = m, fIndex = \i -> fIndex f (floor (toRational i * step))} 132 | 133 | -- | Remove all sizes exept those in the given inclusive (low,high) range 134 | sizeRange :: Enumerate a -> (Int, Int) -> Enumerate a 135 | sizeRange e (lo, hi) = fromParts $ take (1+hi-lo) $ drop lo $ parts e 136 | 137 | 138 | -------------------------------------------------------------------------------- /Test/Feat/Enumerate.hs: -------------------------------------------------------------------------------- 1 | {-#LANGUAGE DeriveDataTypeable, TemplateHaskell #-} 2 | 3 | -- | Basic combinators for building enumerations 4 | -- most users will want to use the type class 5 | -- based combinators in "Test.Feat.Class" instead. 6 | 7 | module Test.Feat.Enumerate ( 8 | 9 | 10 | Index, 11 | Enumerate(..), 12 | parts, 13 | fromParts, 14 | 15 | -- ** Reversed lists 16 | RevList(..), 17 | toRev, 18 | 19 | -- ** Finite ordered sets 20 | Finite(..), 21 | fromFinite, 22 | 23 | 24 | -- ** Combinators for building enumerations 25 | module Data.Monoid, 26 | union, 27 | module Control.Applicative, 28 | cartesian, 29 | singleton, 30 | pay, 31 | ) where 32 | 33 | -- testing-feat 34 | -- import Control.Monad.TagShare(Sharing, runSharing, share) 35 | -- import Test.Feat.Internals.Tag(Tag(Source)) 36 | -- base 37 | import Control.Sized 38 | import Control.Applicative 39 | import Data.Semigroup 40 | import Data.Monoid hiding ((<>)) 41 | import Data.Typeable 42 | import Data.List(transpose) 43 | import Test.Feat.Finite 44 | 45 | type Part = Int 46 | 47 | -- | A functional enumeration of type @t@ is a partition of 48 | -- @t@ into finite numbered sets called Parts. Each parts contains values 49 | -- of a certain cost (typically the size of the value). 50 | data Enumerate a = Enumerate 51 | { revParts :: RevList (Finite a) 52 | } deriving Typeable 53 | 54 | parts :: Enumerate a -> [Finite a] 55 | parts = fromRev . revParts 56 | 57 | fromParts :: [Finite a] -> Enumerate a 58 | fromParts ps = Enumerate (toRev ps) 59 | 60 | -- | Only use fmap with bijective functions (e.g. data constructors) 61 | instance Functor Enumerate where 62 | fmap f e = Enumerate (fmap (fmap f) $ revParts e) 63 | 64 | -- | Pure is 'singleton' and '<*>' corresponds to cartesian product (as with lists) 65 | instance Applicative Enumerate where 66 | pure = singleton 67 | f <*> a = fmap (uncurry ($)) (cartesian f a) 68 | 69 | instance Alternative Enumerate where 70 | empty = Enumerate mempty 71 | (<|>) = union 72 | 73 | instance Sized Enumerate where 74 | pay e = Enumerate (revCons mempty $ revParts e) 75 | aconcat = mconcat 76 | pair = cartesian 77 | fin k = fromParts [finFin k] 78 | 79 | instance Semigroup (Enumerate a) where 80 | (<>) = union 81 | 82 | -- | The @'mappend'@ is (disjoint) @'union'@ 83 | instance Monoid (Enumerate a) where 84 | mempty = empty 85 | mappend = union 86 | mconcat = econcat 87 | 88 | -- | Optimal 'mconcat' on enumerations. 89 | econcat :: [Enumerate a] -> Enumerate a 90 | econcat [] = mempty 91 | econcat [a] = a 92 | econcat [a,b] = union a b 93 | econcat xs = Enumerate 94 | (toRev . map mconcat . transpose $ map parts xs) 95 | 96 | 97 | -- Product of two enumerations 98 | cartesian (Enumerate xs1) (Enumerate xs2) = Enumerate (xs1 `prod` xs2) 99 | 100 | prod :: RevList (Finite a) -> RevList (Finite b) -> RevList (Finite (a,b)) 101 | prod (RevList [] _) _ = mempty 102 | prod (RevList xs0@(_:xst) _) (RevList _ rys0) = toRev$ prod' rys0 where 103 | 104 | -- We need to thread carefully here, making sure that guarded recursion is safe 105 | prod' [] = [] 106 | prod' (ry:rys) = go ry rys where 107 | go ry rys = conv xs0 ry : case rys of 108 | (ry':rys') -> go ry' rys' 109 | [] -> prod'' ry xst 110 | 111 | -- rys0 is exhausted, slide a window over xs0 until it is exhausted 112 | prod'' :: [Finite b] -> [Finite a] -> [Finite (a,b)] 113 | prod'' ry = go where 114 | go [] = [] 115 | go xs@(_:xs') = conv xs ry : go xs' 116 | 117 | conv :: [Finite a] -> [Finite b] -> Finite (a,b) 118 | conv xs ys = Finite 119 | (sum $ zipWith (*) (map fCard xs) (map fCard ys )) 120 | (prodSel xs ys) 121 | 122 | prodSel :: [Finite a] -> [Finite b] -> (Index -> (a,b)) 123 | prodSel (f1:f1s) (f2:f2s) = \i -> 124 | let mul = fCard f1 * fCard f2 125 | in if i < mul 126 | then let (q, r) = (i `quotRem` fCard f2) 127 | in (fIndex f1 q, fIndex f2 r) 128 | else prodSel f1s f2s (i-mul) 129 | prodSel _ _ = \i -> error "index out of bounds" 130 | 131 | 132 | union :: Enumerate a -> Enumerate a -> Enumerate a 133 | union (Enumerate xs1) (Enumerate xs2) = Enumerate (xs1 `mappend` xs2) 134 | 135 | 136 | -- | The definition of @pure@ for the applicative instance. 137 | singleton :: a -> Enumerate a 138 | singleton a = Enumerate (revPure $ pure a) 139 | 140 | 141 | 142 | ------------------------------------------------------------------ 143 | -- Reverse lists 144 | 145 | -- | A data structure that contains a list and the reversals of all initial 146 | -- segments of the list. Intuitively 147 | -- 148 | -- @reversals xs !! n = reverse (take (n+1) (fromRev xs))@ 149 | -- 150 | -- Any operation on a @RevList@ typically discards the reversals and constructs 151 | -- new reversals on demand. 152 | data RevList a = RevList {fromRev :: [a], reversals :: [[a]]} deriving Show 153 | 154 | instance Functor RevList where 155 | fmap f = toRev . fmap f . fromRev 156 | 157 | instance Semigroup a => Semigroup (RevList a) where 158 | (<>) xs ys = toRev $ zipMon (fromRev xs) (fromRev ys) where 159 | zipMon :: Semigroup a => [a] -> [a] -> [a] 160 | zipMon (x:xs) (y:ys) = x <> y : zipMon xs ys 161 | zipMon xs ys = xs ++ ys 162 | 163 | -- Maybe this should be append instead? 164 | -- | Padded zip 165 | instance (Monoid a, Semigroup a) => Monoid (RevList a) where 166 | mempty = toRev[] 167 | mappend = (<>) 168 | 169 | -- | Constructs a "Reverse list" variant of a given list. In a sensible 170 | -- Haskell implementation evaluating any inital segment of 171 | -- @'reversals' (toRev xs)@ uses linear memory in the size of the segment. 172 | toRev:: [a] -> RevList a 173 | toRev xs = RevList xs $ go [] xs where 174 | go _ [] = [] 175 | go rev (x:xs) = let rev' = x:rev in rev' : go rev' xs 176 | 177 | -- | Adds an element to the head of a @RevList@. Constant memory iff the 178 | -- the reversals of the resulting list are not evaluated (which is frequently 179 | -- the case in @Feat@). 180 | revCons a = toRev. (a:) . fromRev 181 | 182 | revPure a = RevList [a] [[a]] 183 | -------------------------------------------------------------------------------- /examples/haskell-src-exts/hse.hs: -------------------------------------------------------------------------------- 1 | {-# Language TemplateHaskell #-} 2 | import Test.Feat 3 | -- import Test.Feat.Class 4 | import Test.Feat.Modifiers 5 | import Test.Feat.Driver 6 | 7 | import Control.Enumerable 8 | 9 | import Language.Haskell.Exts 10 | import Language.Haskell.Exts.Syntax 11 | 12 | import Control.Exception as Ex 13 | 14 | -- Welcome to the automatic HSE tester! 15 | -- Things to try while youre here: 16 | -- switch between Exp/Module/Decl etc. as TestParse 17 | -- to discover bugs in the various entry-points of the grammar. 18 | 19 | -- TODOs: add some newtypes and modifiers to deal with syntax type invariants 20 | -- (such as only enumerating non-empty do-expressions with a statement as last expression). 21 | -- 22 | -- Catalogue and report all the bugs found. 23 | -- 24 | -- Fix the round-trip 25 | 26 | 27 | main = do 28 | main_parse -- Test the parsable property 29 | main_round -- Test the round-trip property 30 | 31 | -- Everything produced by the pretty printer is parseable. 32 | type TestParse = Exp SrcSpanInfo -- Type to be tested 33 | main_parse = do 34 | res <- test prop_parse 35 | mapM (putStr . rep_parse) res 36 | 37 | 38 | rep_parse :: TestParse -> String 39 | rep_parse e = case myParse $ prettyPrint e of 40 | ParseOk e' -> const "" (e' `asTypeOf` e) 41 | ParseFailed _ err -> unlines 42 | [(show $ fmap (const ()) e) 43 | ,(prettyPrint e) 44 | ,err] 45 | 46 | prop_parse :: TestParse -> Bool 47 | prop_parse e = case myParse $ prettyPrint e of 48 | ParseOk e' -> const True (e' `asTypeOf` e) 49 | ParseFailed _ err -> False 50 | 51 | 52 | -- Everything which is produced by the pretty printer parses back to itself 53 | type TestRoundtrip = Exp SrcSpanInfo 54 | main_round = do 55 | res <- testOptions defOptions{oBounded = (Just 10000)} prop_trip 56 | mapM (putStr . rep_trip) res 57 | 58 | -- Tests a "roundtrip and a half" 59 | -- parse (print e) == parse (print (parse (print e))) 60 | -- Ignores parsing errors 61 | prop_trip :: TestRoundtrip -> Bool 62 | prop_trip e = case roundAndAhalf e of 63 | ParseOk (e', e'') -> eq e' e'' 64 | ParseFailed _ err -> True 65 | 66 | eq :: TestRoundtrip -> TestRoundtrip -> Bool 67 | eq a b = fmap (const ()) a == fmap (const ()) b 68 | 69 | 70 | rep_trip :: TestRoundtrip -> String 71 | rep_trip e = case roundAndAhalf e of 72 | ParseOk (e', e'') -> unlines [ 73 | "Original:", 74 | show (fmap (const ()) e), 75 | prettyPrint e, 76 | "", 77 | "One print/parse round:", 78 | show (fmap (const ()) e'), 79 | prettyPrint e', 80 | "", 81 | "Two print/parse round:", 82 | show (fmap (const ()) e''), 83 | prettyPrint e'' 84 | ] 85 | ParseFailed _ err -> unlines 86 | [(show $ fmap (const ()) e) 87 | ,(prettyPrint e) 88 | ,err] 89 | 90 | 91 | roundAndAhalf :: TestRoundtrip -> ParseResult (TestRoundtrip, TestRoundtrip) 92 | roundAndAhalf e = do 93 | e' <- myParse $ prettyPrint e 94 | e'' <- myParse $ prettyPrint e' 95 | return (e', e'') 96 | 97 | {- 98 | 99 | -- Everything which is produced by the pretty printer and is parseable is 100 | -- semantically euivalent to the original. 101 | 102 | 103 | 104 | -- The pretty printer doesnt fail, for testing the enumerators. 105 | type TestPrint = Module 106 | 107 | 108 | prop_print :: Pretty a => a -> Bool 109 | prop_print e = length (prettyPrint e) >= 0 110 | 111 | rep_print :: (Show a, Pretty a) => a -> IO () 112 | rep_print e = Ex.catch 113 | (prop_print e `seq` return ()) 114 | (\err -> do 115 | putStrLn (show e) 116 | if show (err::SomeException) == "user interrupt" then undefined else return () 117 | putStrLn $ show (err::SomeException) 118 | putStrLn "") 119 | -} 120 | 121 | -- Parse with all extensions 122 | myParse :: Parseable a => String -> ParseResult a 123 | myParse = parseWithMode defaultParseMode{ 124 | extensions = [ e |e@(EnableExtension _) <- knownExtensions] 125 | } 126 | 127 | sureParse :: Parseable a => String -> a 128 | sureParse s = case myParse s of 129 | ParseOk a -> a 130 | ParseFailed _ err -> error err 131 | 132 | parse_print :: (Parseable a, Pretty a) => String -> (a,String) 133 | parse_print s = let a = sureParse s in (a,prettyPrint a) 134 | 135 | 136 | instance Enumerable SrcSpanInfo where 137 | enumerate = datatype [c0 $ SrcSpanInfo (SrcSpan "M.hs" 0 0 0 0) []] 138 | 139 | -- Uncomment the dExcluding line to enable known bugs 140 | (let 141 | 142 | buggy1 = 143 | dExcluding 'UnboxedSingleCon . 144 | dAll 145 | buggy2 = 146 | dExcluding 'PQuasiQuote . 147 | dAll 148 | buggy3 = 149 | dExcept 'Tuple [| c3 (\a b c -> Tuple a b (nonEmpty c))|] . 150 | dExcept 'TupleSection [| c3 (\a b c -> TupleSection a b (nonEmpty c))|] . 151 | dExcept 'LCase [| c2 (\a -> LCase a . nonEmpty) |] . 152 | dExcept 'Do [| c3 $ \a ss e -> Do a (ss ++ [Qualifier a e]) |] . 153 | dExcept 'Var [| c2 (\a b -> Var a (nonSpecial b)) |] . 154 | dExcept 'Con [| c2 (\a b -> Con a (nonSpecial b)) |] . 155 | 156 | dExcept 'Lambda [| c3 (\a b c -> Lambda a (nonEmpty b) c) |] . 157 | 158 | dExcept 'RecUpdate [| c3 (\a b c -> RecUpdate a b (nonEmpty c)) |] . 159 | 160 | dExcept 'ListComp [| c3 (\a b c -> ListComp a b (nonEmpty c)) |] . 161 | 162 | dExcluding 'TypeApp . 163 | dExcluding 'GenPragma . -- Seems genuinly buggy 164 | dExcluding 'TypQuote . 165 | dExcluding 'VarQuote . 166 | dExcluding 'BracketExp . 167 | dExcluding 'MDo . 168 | dExcluding 'IPVar . -- What is this? 169 | dExcluding 'QuasiQuote . 170 | dExcluding 'XPcdata . 171 | dExcluding 'XExpTag . 172 | dExcluding 'XChildTag . 173 | dExcluding 'OverloadedLabel . 174 | dExcept 'XPcdata [| c2 $ \a -> XPcdata a . nonEmpty |] . 175 | dExcept 'MultiIf [| c2 $ \a -> MultiIf a . nonEmpty |] . 176 | dAll 177 | 178 | 179 | fixdecs = 180 | dExcluding 'DeprPragmaDecl . 181 | dExcluding 'WarnPragmaDecl . 182 | dExcluding 'SpliceDecl . 183 | dExcept 'TypeSig [| c3 (\a b c -> TypeSig a (nonEmpty b) c) |] . 184 | dExcept 'InfixDecl [| c4 $ \a b c -> InfixDecl a b c . nonEmpty |] . 185 | dExcept 'CompletePragma [| c3 $ \a b c -> CompletePragma a (nonEmpty b) c|] . 186 | dAll 187 | 188 | fixlit = 189 | dExcluding 'PrimWord . 190 | dExcluding 'PrimInt . -- Buggy? 191 | --dExcept 'PrimWord [| c2 (\a x -> PrimWord a (toInteger (x :: Word)) (show x)) |] . 192 | dExcept 'Int [| c2 (\a x -> Int a (toInteger (x :: Word)) (show x)) |] . 193 | dAll 194 | 195 | fixType = 196 | dExcept 'TyUnboxedSum [| c2 (\a b -> TyUnboxedSum a (nonEmpty b))|] . 197 | 198 | dExcluding 'TyQuasiQuote . 199 | dAll 200 | 201 | in fmap concat $ mapM deriveEnumerable' [ 202 | dExcluding 'XmlHybrid $ dExcluding 'XmlPage $ dAll ''Module, 203 | -- dAll ''SrcLoc, 204 | dExcluding 'AnnModulePragma $ dExcluding 'LanguagePragma 205 | -- dExcept 'LanguagePragma [|c2 $ \x -> LanguagePragma x . nonEmpty|] 206 | $ dAll ''ModulePragma, 207 | dAll ''ImportDecl, 208 | fixdecs ''Decl, 209 | dAll ''Tool, 210 | dAll ''QName, 211 | dAll ''ImportSpec, 212 | dAll ''Annotation, 213 | fixType ''Type, 214 | dAll ''Activation, 215 | dAll ''Rule, 216 | dAll ''CallConv, 217 | dAll ''Safety, 218 | buggy2 ''Pat, 219 | dAll ''Rhs, 220 | dAll ''Binds, 221 | dAll ''Match, 222 | buggy3 ''Exp, 223 | dAll ''Assoc, 224 | dAll ''Op, 225 | dAll ''Asst, 226 | dAll ''InstDecl, 227 | dAll ''TyVarBind, 228 | dAll ''FunDep, 229 | dAll ''ClassDecl, 230 | dAll ''DataOrNew, 231 | dAll ''Kind, 232 | dAll ''GadtDecl, 233 | dAll ''QualConDecl, 234 | buggy1 ''SpecialCon, 235 | dAll ''Boxed, 236 | dAll ''RuleVar, 237 | dAll ''XName, 238 | dAll ''PXAttr, 239 | dAll ''RPat, 240 | dAll ''PatField, 241 | dAll ''GuardedRhs, 242 | dAll ''IPBind, 243 | dAll ''XAttr, 244 | dExcluding 'IdSplice $ dAll ''Splice, 245 | dAll ''Bracket, 246 | dAll ''QualStmt, 247 | dAll ''FieldUpdate, 248 | dAll ''QOp, 249 | dAll ''Stmt, 250 | dAll ''Alt, 251 | fixlit ''Literal, 252 | dAll ''IPName, 253 | dAll ''ConDecl, 254 | dAll ''RPatOp, 255 | -- dAll ''GuardedAlts, 256 | dAll ''BangType, 257 | -- dAll ''GuardedAlt, 258 | dAll ''TypeEqn, 259 | dAll ''Sign, 260 | dAll ''Role, 261 | dAll ''Promoted, 262 | dAll ''PatternSynDirection, 263 | dAll ''Overlap, 264 | dAll ''Namespace, 265 | dAll ''BooleanFormula, 266 | dAll ''ImportSpecList, 267 | dAll ''DeclHead, 268 | dAll ''ResultSig, 269 | dAll ''InjectivityInfo, 270 | dAll ''Context, 271 | dAll ''Deriving, 272 | dAll ''InstRule, 273 | dAll ''Unpackedness, 274 | dAll ''FieldDecl, 275 | dAll ''InstHead, 276 | dAll ''DerivStrategy, 277 | dAll ''MaybePromotedName 278 | ]) 279 | 280 | 281 | 282 | instance Enumerable a => Enumerable (ModuleHead a) where 283 | enumerate = datatype [c1 $ \a -> ModuleHead a (ModuleName a "M") Nothing Nothing] 284 | 285 | instance Enumerable a => Enumerable (ExportSpec a) where 286 | enumerate = datatype [ c2 $ \a -> EVar a . nonSpecial 287 | , c3 $ \a x -> EAbs a x . nonSpecial 288 | -- , c1 $ EThingAll . nonSpecial 289 | -- , c2 $ EThingWith . nonSpecial 290 | , c2 $ EModuleContents 291 | ] 292 | 293 | -- newtype Upper = Upper {upper :: QName} 294 | -- instance Enumerable Upper where 295 | -- enumerate = datatype [c2 Qual 296 | 297 | newtype NonSpecialName a = NonSpecialName {nonSpecial :: QName a} 298 | instance Enumerable a => Enumerable (NonSpecialName a) where 299 | enumerate = datatype [fmap NonSpecialName $ c3 Qual 300 | ,fmap NonSpecialName $ c2 UnQual 301 | ] 302 | 303 | 304 | instance Enumerable a => Enumerable (ModuleName a) where 305 | enumerate = datatype 306 | [ c1 $ \a -> ModuleName a "M" 307 | , c1 $ \a -> ModuleName a "C.M" 308 | ] 309 | 310 | -- Will probably need to be broken into constructor/variable/symbol names 311 | instance Enumerable a => Enumerable (Name a) where 312 | enumerate = datatype 313 | [ c1 $ \a -> Ident a "C" 314 | , c1 $ \a -> Ident a "v" 315 | -- , c0 $ Symbol "*" 316 | ] 317 | 318 | instance Enumerable a => Enumerable (CName a) where 319 | enumerate = datatype 320 | [ c1 $ \a -> VarName a (Ident a "v") 321 | , c1 $ \a -> ConName a (Ident a "C") 322 | ] 323 | 324 | instance Enumerable SrcLoc where 325 | enumerate = datatype 326 | [ c0 (SrcLoc "File.hs" 0 0)] -------------------------------------------------------------------------------- /examples/template-haskell/th.hs: -------------------------------------------------------------------------------- 1 | -- This is tested with haskell-src-exts-1.19.1 2 | {-#LANGUAGE MagicHash, TemplateHaskell, DeriveDataTypeable, StandaloneDeriving, GeneralizedNewtypeDeriving #-} 3 | -- BangPatterns, ScopedTypeVariables, ViewPatterns, KindSignatures 4 | 5 | 6 | import Language.Haskell.TH.Syntax 7 | ( Exp(..), Pat(..), Stmt(..), Type(..), Dec(..), 8 | Range(..), Lit(..), Kind(..), 9 | Body(..), Guard(..), Con(..), Match(..), 10 | Name(..), mkName, NameFlavour(..), NameSpace(..), 11 | Clause(..), Pragma(..), FamFlavour(..), 12 | Pred(..), TyVarBndr(..), 13 | Foreign, Callconv(..), FunDep(..), 14 | Safety(..), Strict(..), OccName(..), ModName(..)) 15 | -- testing-feat 16 | import Test.Feat 17 | import Test.Feat.Modifiers 18 | import Control.Enumerable 19 | -- template-haskell 20 | -- import Language.Haskell.TH.Syntax.Internals(OccName(OccName), ModName(ModName), PkgName) 21 | import Language.Haskell.TH.Ppr(pprint,Ppr) 22 | -- haskell-src-meta 23 | -- import Language.Haskell.Meta(toExp) 24 | -- haskell-src-exts 25 | import qualified Language.Haskell.Exts as E 26 | -- quickcheck 27 | import Test.QuickCheck hiding (NonEmpty, (><)) 28 | --base 29 | import Data.Typeable(Typeable) 30 | import Data.Ord 31 | import Data.List 32 | -- smallcheck 33 | 34 | -- import Test.SmallCheck.Series hiding (Nat) 35 | -- import Test.SmallCheck 36 | 37 | 38 | main = testOptions defOptions{oMaxCounter=Just 10} prop_parses 39 | 40 | type Ex = (E.Exp E.SrcSpanInfo) 41 | 42 | 43 | -- Haskell parser 44 | myParse :: String -> E.ParseResult Ex 45 | myParse = E.parseWithMode E.defaultParseMode{E.extensions = 46 | (map E.EnableExtension [E.ExplicitForAll, E.ConstraintKinds]) 47 | {- [ E.BangPatterns 48 | , E.ScopedTypeVariables 49 | , E.ViewPatterns 50 | , E.KindSignatures 51 | , E.ExplicitForAll 52 | , E.TypeFamilies 53 | ]-} 54 | } 55 | 56 | -- | Newtype to make error reporting look nicer 57 | newtype PPR a = PPR a 58 | 59 | instance (Show a, Ppr a) => Show (PPR a) where 60 | show (PPR a) = show a ++ "\n" ++ pprint a ++ "\n" ++errormsg a where 61 | errormsg x = case myParse (pprint x) of 62 | E.ParseFailed _ s -> s 63 | E.ParseOk _ -> "OK" 64 | instance Enumerable a => Enumerable (PPR a) where 65 | enumerate = share (c1 PPR) 66 | 67 | -- | Every pretty-printer result should be par 68 | prop_parses (PPR e) = case myParse $ pprint (e :: Exp) of 69 | E.ParseOk _ -> True 70 | E.ParseFailed _ s -> False 71 | 72 | {- 73 | 74 | -- Currently both of these spit out a lot of errors unless we disable a few of the 75 | -- buggier constructors (which we have done below). 76 | test_parsesAll = ioAll 15 report_parses 77 | -- | Test (at most) 10000 values of each size up to size 100. 78 | test_parsesBounded = ioBounded 10000 100 report_parses 79 | 80 | test_parsesBounded' = ioFeat (boundedWith enumerate 1000) report_parses 81 | 82 | report_parses e = case prop_parsesM e of 83 | Nothing -> return () 84 | Just s -> do 85 | putStrLn "Failure:" 86 | putStrLn (pprint e) 87 | print e 88 | putStrLn s 89 | putStrLn "" 90 | 91 | prop_parsesM e = case myParse $ pprint (e :: Exp) :: E.ParseResult E.Exp of 92 | E.ParseOk _ -> Nothing 93 | E.ParseFailed _ s -> Just s 94 | 95 | 96 | test_cycleAll = ioAll 15 report_cycle 97 | test_cycleBounded = ioBounded 10000 100 report_cycle 98 | report_cycle e = case prop_cycle e of 99 | Nothing -> return () 100 | Just (ee,ex) -> do 101 | putStrLn "Failure:" 102 | putStrLn (pprint ex) 103 | print ex 104 | putStrLn (E.prettyPrint ee) 105 | putStrLn "" 106 | 107 | -- Round-trip property: TH -> String -> HSE -> TH 108 | -- Uses haskell-src-meta for HSE -> TH 109 | prop_cycle :: Exp -> Maybe (E.Exp,Exp) 110 | prop_cycle e = case myParse $ pprint (e :: Exp) :: E.ParseResult E.Exp of 111 | E.ParseOk hse -> if e == toExp hse then Nothing else Just $ (hse, toExp hse) 112 | E.ParseFailed _ s -> Nothing -- Parse failures do not count as errors! 113 | 114 | 115 | 116 | 117 | 118 | 119 | -} 120 | 121 | 122 | 123 | -- These statements are always expressions 124 | newtype ExpStmt = ExpStmt Exp deriving Typeable 125 | 126 | -- Declarations allowed in where clauses 127 | newtype WhereDec = WhereDec{unWhere :: Dec} deriving Typeable 128 | 129 | -- Lowecase names 130 | newtype LcaseN = LcaseN {lcased :: Name} deriving Typeable 131 | -- Uppercase names 132 | newtype UpcaseName = UpcaseName {ucased :: Name} deriving Typeable 133 | newtype BindN = BindN Name deriving Typeable 134 | 135 | 136 | newtype CPair a b = CPair {cPair :: (a,b)} deriving Typeable 137 | 138 | instance (Enumerable a,Enumerable b) => Enumerable (CPair a b) where 139 | enumerate = datatype [c1 CPair] 140 | 141 | instance Enumerable Exp where 142 | enumerate = datatype 143 | [c1 $ VarE . lcased 144 | ,c1 $ ConE . ucased 145 | ,c1 LitE 146 | ,c2 AppE 147 | ,c1 $ \(ExpStmt a,o) -> InfixE (Just a) (either ConE VarE o) Nothing 148 | ,c1 $ \(ExpStmt a,o) -> InfixE Nothing (either ConE VarE o) (Just a) 149 | ,c1 $ \(a,o,b) -> InfixE (Just a) (either ConE VarE o) (Just b) 150 | -- ,c3 $ \a o b -> UInfixE a (VarE o) b 151 | -- ,c3 $ \a o b -> UInfixE a (ConE o) b 152 | -- ,c1 ParensE 153 | ,c2 $ LamE . nonEmpty 154 | ,c1 $ \(x1,x2,xs) -> TupE (x1:x2:xs) 155 | -- ,c1 UnboxedTupE 156 | ,c3 CondE 157 | ,c1 $ \(d,ds,e) -> LetE (map unWhere $ d:ds) e -- DISABLED BUGGY EMPTY LETS 158 | ,c1 $ \(e,NonEmpty m) -> CaseE e m 159 | ,c1 $ \(ExpStmt e,ss) -> DoE (ss ++ [NoBindS e]) 160 | ,c1 $ (\((p,e),(CPair (xs,e'))) -> CompE ([BindS p e] ++ xs ++ [NoBindS e'])) 161 | -- ,c1 ArithSeqE -- BUGGY! 162 | ,c1 ListE 163 | -- ,c2 SigE -- BUGGY! 164 | ,c1 $ \(e,x) -> RecConE e $ map unCase (nonEmpty x) 165 | ,c1 $ \(e,fe) -> RecUpdE e $ map unCase (nonEmpty fe) 166 | ] 167 | 168 | unCase (LcaseN n,e) = (n,e) 169 | 170 | instance Enumerable ExpStmt where 171 | enumerate = datatype 172 | [ c1 $ ExpStmt . VarE 173 | , c1 $ ExpStmt . ConE 174 | -- , c1 $ ExpStmt . LitE 175 | , c1 $ \(e1,e2) -> ExpStmt (AppE e1 e2) 176 | -- , c1 $ ExpStmt . LitE 177 | -- , c1 parS 178 | -- Removed paralell comprehensions 179 | ] 180 | 181 | 182 | instance Enumerable Pat where 183 | enumerate = datatype 184 | [ c1 LitP 185 | , c1 $ \(BindN n) -> VarP n 186 | , c1 TupP 187 | , c1 $ \(UpcaseName n,ps) -> ConP n ps 188 | , c1 $ \(p1,UpcaseName n,p2) -> InfixP p1 n p2 189 | , c1 TildeP 190 | -- , c1 $ \(LcaseN n) -> BangP $ VarP n 191 | , c1 $ \(BindN n,p) -> AsP n p 192 | , c0 WildP 193 | , c1 $ \(UpcaseName e,x) -> RecP e (map (\(BindN n, p) -> (n,p)) (nonEmpty x)) 194 | , c1 ListP 195 | -- , c2 SigP -- BUGGY! 196 | -- , c2 ViewP -- BUGGY! 197 | ] 198 | 199 | 200 | -- deriveEnumerable ''Match -- Should remove decs 201 | instance Enumerable Match where 202 | enumerate = datatype 203 | [c3 $ \x y ds -> Match x y (map unWhere ds) 204 | ] 205 | 206 | instance Enumerable Stmt where 207 | enumerate = datatype 208 | [ c2 BindS 209 | , c1 $ \(d) -> LetS $ map unWhere $ nonEmpty d 210 | , c1 $ NoBindS 211 | -- , c1 parS 212 | -- Removed paralell comprehensions 213 | ] 214 | 215 | 216 | 217 | instance Enumerable Name where 218 | enumerate = datatype [ c2 Name ] 219 | 220 | 221 | 222 | instance Enumerable Type where 223 | enumerate = datatype cType where 224 | cType = 225 | [c3 $ (\(x) -> ForallT (map (PlainTV . lcased) $ nonEmpty x)) 226 | ,c1 $ \(BindN a) -> VarT a 227 | ,c1 $ \(UpcaseName a) -> ConT a 228 | ,c1 $ \n -> TupleT (abs n) 229 | ,c0 ArrowT 230 | ,c0 ListT 231 | ,c2 AppT 232 | -- ,c2 SigT -- BUGGY! 233 | ] 234 | 235 | 236 | 237 | -- deriveEnumerable ''Dec 238 | 239 | instance Enumerable WhereDec where 240 | enumerate = datatype 241 | [ c1 $ \(n,c) -> WhereDec $ FunD n (nonEmpty c) 242 | , c1 $ \(n,p,wds) -> WhereDec $ ValD n p (map unWhere wds) 243 | , c1 $ \(BindN a,b) -> WhereDec $ SigD a b 244 | -- , c1 $ WhereDec . PragmaD -- Removed pragmas 245 | -- , c1 parS -- Removed paralell comprehensions 246 | ] 247 | 248 | 249 | 250 | 251 | instance Enumerable Lit where 252 | enumerate = datatype 253 | [ c1 StringL 254 | , c1 CharL -- TODO: Fair char generation 255 | , c1 $ IntegerL . nat 256 | -- , c1 RationalL -- BUGGY! 257 | -- Removed primitive litterals 258 | ] 259 | 260 | instance Enumerable Clause where 261 | enumerate = datatype 262 | [c3 $ \ps bs ds -> Clause ps bs (map unWhere ds)] 263 | 264 | 265 | 266 | 267 | 268 | -- deriveEnumerable ''Pred 269 | --cPred = 270 | -- [ c2 ClassP 271 | -- , c2 EqualP 272 | -- ] 273 | --instance Enumerable Pred where 274 | -- enumerate = datatype cPred 275 | 276 | 277 | -- deriveEnumerable ''TyVarBndr 278 | instance Enumerable TyVarBndr where 279 | enumerate = datatype 280 | [ c1 PlainTV 281 | , c2 KindedTV 282 | ] 283 | 284 | 285 | --cKind = 286 | -- [c0 StarK 287 | -- ,c2 ArrowK 288 | -- ] 289 | --instance Enumerable Kind where 290 | -- enumerate = datatype cKind 291 | 292 | 293 | instance Enumerable Body where 294 | enumerate = datatype 295 | [ c1 NormalB 296 | , c1 $ \(x) -> GuardedB (nonEmpty x) 297 | -- Removed primitive litterals 298 | ] 299 | 300 | instance Enumerable Guard where 301 | enumerate = datatype 302 | [c1 $ NormalG 303 | ,c1 $ \(s) -> PatG (nonEmpty s) 304 | ] 305 | 306 | instance Enumerable Callconv where 307 | enumerate = datatype [c0 CCall, c0 StdCall] 308 | 309 | 310 | 311 | 312 | instance Enumerable Safety where 313 | enumerate = datatype 314 | [c0 Unsafe, c0 Safe, c0 Interruptible] 315 | 316 | 317 | --cStrict = [c0 IsStrict, c0 NotStrict, c0 Unpacked] 318 | --instance Enumerable Strict where 319 | -- enumerate = datatype cStrict 320 | 321 | --cInlineSpec = [c3 $ InlineSpec)] 322 | --instance Enumerable InlineSpec where 323 | -- enumerate = datatype cInlineSpec 324 | 325 | instance Enumerable OccName where 326 | enumerate = datatype 327 | [ c0 $ OccName "Con" 328 | , c0 $ OccName "var" 329 | ] 330 | 331 | instance Enumerable BindN where 332 | enumerate = datatype 333 | [c0 $ BindN $ Name (OccName "var") NameS] 334 | 335 | instance Enumerable LcaseN where 336 | enumerate = datatype 337 | [c1 $ \nf -> LcaseN $ Name (OccName "var") nf] 338 | 339 | instance Enumerable UpcaseName where 340 | enumerate = datatype 341 | [c1 $ \nf -> UpcaseName $ Name (OccName "Con") nf] 342 | 343 | instance Enumerable ModName where 344 | enumerate = datatype 345 | [c0 $ ModName "M", c0 $ ModName "C.M"] 346 | 347 | instance Enumerable Range where 348 | enumerate = datatype 349 | [ c1 FromR 350 | , c2 FromThenR 351 | , c2 FromToR 352 | , c3 FromThenToR 353 | ] 354 | 355 | 356 | instance Enumerable NameFlavour where 357 | enumerate = datatype 358 | [c1 NameQ 359 | -- , c3 NameG 360 | -- , \(I# x) -> NameU x 361 | -- , \(I# x) -> NameL x 362 | , c0 NameS 363 | ] 364 | 365 | 366 | -- main = test_parsesBounded 367 | -- or test_parsesAll, but that takes much longer to find bugs 368 | 369 | 370 | --------------------------------------------------------------------------------