packages feed

axiomatic-classes (empty) → 0.1.0.0

raw patch · 8 files changed

+620/−0 lines, 8 filesdep +QuickCheckdep +basedep +containerssetup-changed

Dependencies added: QuickCheck, base, containers, control-invariants, lens, monad-loops, mtl, portable-template-haskell-lens, quickcheck-report, semigroups, template-haskell, th-printf, transformers

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2016 Simon Hudon++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Test/QuickCheck/AxiomaticClass.hs view
@@ -0,0 +1,81 @@+{-# language CPP #-}++module Test.QuickCheck.AxiomaticClass where++import Control.Lens+import Control.Monad++import Data.List+import qualified Data.Map as M+import Data.Maybe++import Prelude hiding (Monoid(..))++import Language.Haskell.TH+import Language.Haskell.TH.Lens+import Language.Haskell.TH.Lens.Portable+import Language.Haskell.TH.Syntax++import Test.QuickCheck+import Test.QuickCheck.Report++import Text.Printf.TH++    -- Copied from Test.QuickCheck.All++substVars' :: (Name -> Maybe Type) -> Pred -> Pred+substVars' f = types %~ substVars f++substVars :: (Name -> Maybe Type) -> Type -> Type+substVars f t@(VarT n)          = fromMaybe t (f n)+substVars f (ForallT bs ctx ty) = ForallT bs (map (substVars' f) ctx) (substVars f ty)+substVars f (SigT t k)          = SigT (substVars f t) k+substVars f (AppT l r)          = AppT (substVars f l) (substVars f r)+substVars _ t                   = t++withInt :: Type -> Type+withInt = substVars $ const $ Just $ ConT ''Integer++quickCheckClasses :: [Name] -> ExpQ+quickCheckClasses cls = [e| $(quickCheckClassesWith cls) quickCheckResult |]++quickCheckClassesWith :: [Name] -> ExpQ+quickCheckClassesWith cls = do+    props <- concat <$> mapM quickCheckClassTests cls+    [e| (\check -> runQuickCheckAll' $(listE props) check) |]++quickCheckClassTests :: Name -> Q [ExpQ]+quickCheckClassTests cl = do+    ClassI (ClassD _ _ args _ ms) is <- reify cl+    loc <- location+    let axioms = filter (maybe False (isPrefixOf "axiom_") . nameOf) ms+        nameOf (SigD n _) = Just $ nameBase n+        nameOf _ = Nothing+        _ = args+        _ = insts++        insts = map clInst is+        match' :: Type -> Type -> Maybe (M.Map Name Type)+        match' (ConT x) t   = M.empty <$ (t^?_ConT.only x) +        match' (VarT x) t   = Just $ M.singleton x t+        match' (AppT x y) t = (t^?_AppT) >>= \(x',y') -> M.union <$> match' x x' <*> match' y y'+        match' ArrowT t     = M.empty <$ (t^?_ArrowT)+        match' t t' = error $ [s|\n%s\n%s\n|] (pprint t) (pprint t')+        match :: Type -> Type -> Type+        match t t' = fromMaybe t' $ t'^?_ForallT.to (\x -> withInt $ substType (M.unions $ mapMaybe (flip match' t) $ x^._2) (x^._3))+        clInst = fromMaybe undefined . preview (_InstanceD'._2)+        decName (SigD n _) = n+        decName _ = undefined+        subst :: Type -> Dec -> ExpQ+        subst m (SigD n t) = sigE (varE n) $ return $ match m t+        subst _ _ = undefined+        propName :: String -> ExpQ+        propName n = [| PropName $(stringE n) $(lift $ loc_filename loc) $(lift $ fst $ loc_start loc) |]+        quickCheckInvoke :: Type -> Dec -> ExpQ+        quickCheckInvoke t d = [e| (+            $(propName $ [s|Axiom of %s : %s|] (pprint t) (nameBase $ decName d))+            , property $(subst t d)) |]+        props = quickCheckInvoke <$> insts <*> axioms+    when (null insts)  $ fail $ [s|class %s does not have instances|] (show cl)+    when (null axioms) $ fail $ [s|class %s does not have axioms|] (show cl)+    return props
+ Test/QuickCheck/RandomTree.hs view
@@ -0,0 +1,283 @@+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE ScopedTypeVariables    #-}+module Test.QuickCheck.RandomTree where++import Control.Monad+import Control.Monad.Fix+import Control.Monad.Trans.Class+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+import Control.Precondition++import Data.List++import Text.Printf++import Test.QuickCheck hiding (sized)+import qualified Test.QuickCheck as QC+import Test.QuickCheck.Report as QC++data Tree a = Tree a [Tree a]+    deriving Eq++type Rec a = RecT Gen a++newtype RecT m a = RecT { runRecT :: ReaderT Int (MaybeT m) a }++instance Functor m => Functor (RecT m) where+    fmap f (RecT m) = RecT $ fmap f m++instance (Functor m, Monad m) => Applicative (RecT m) where+    (<*>)  = ap+    pure = return++instance Monad m => Monad (RecT m) where+    RecT m >>= f = RecT $ m >>= runRecT . f+    return = RecT . return+    fail = RecT . fail++instance MonadTrans RecT where+    lift m = RecT $ lift $ lift m++class Monad m => MonadGen m where +    liftGen :: Gen a -> m a+    sized :: (Int -> m a) -> m a++instance MonadGen Gen where+    liftGen m = m+    sized = QC.sized++instance MonadGen m => MonadGen (ReaderT a m) where+    liftGen m = lift $ liftGen m+    sized f   = ReaderT $ \r -> sized $ \n -> runReaderT (f n) r++instance MonadGen m => MonadGen (MaybeT m) where+    liftGen m = lift $ liftGen m+    sized f   = MaybeT $ sized $ \n -> runMaybeT (f n)++instance MonadGen m => MonadGen (RecT m) where+    liftGen m = lift $ liftGen m+    sized f   = RecT $ sized $ \n -> runRecT (f n)++elements :: MonadGen m => [a] -> m a+elements = liftGen . QC.elements++-- recurse :: forall a b. TupleOf b a => Rec a -> Rec b+-- recurse cmd = do+--     n <- RecT ask+--     let m = tLength (error "nuts" :: b)+--     unless (m <= n) (fail "insufficient budget")+--     bs <- lift $ putInBins (n - m) m+--     flip evalStateT bs $ forAllM $ do+--         x <- gets head+--         modify tail+--         lift $ RecT $ local (const x) (runRecT cmd)++recForM :: MonadGen m => [a] -> (a -> RecT m b) -> RecT m [b]+recForM xs f = do+    let k = length xs+    n  <- RecT ask +    unless (k <= n) (fail "insufficient budget")+    -- k  <- lift $ choose (p, n `min` q)+    bs <- liftGen $ putInBins (n - k) k+    let cmd b x = RecT $ local (const b) (runRecT (f x))+    zipWithM cmd bs xs+    -- forM bs $ \b -> do+    --     RecT $ local (const b) (runRecT cmd)++recListFrom :: Int -> Rec a -> Rec [a]+recListFrom m cmd = do+    n <- RecT ask+    recListFromTo m n cmd++recListFromTo :: Int -> Int -> Rec a -> Rec [a]+recListFromTo p q cmd = do+    n  <- RecT ask +    unless (p <= n) (fail "insufficient budget")+    k  <- lift $ choose (p, n `min` q)+    bs <- lift $ putInBins (n - k) k+    forM bs $ \b -> do+        RecT $ local (const b) (runRecT cmd)++try :: Monad m => RecT m a -> RecT m (Maybe a)+try cmd = RecT $ ReaderT $ \n -> MaybeT $ do+    liftM Just $ runMaybeT $ runReaderT (runRecT cmd) n++consume :: Monad m => RecT m a -> RecT m a+consume cmd = do+    n <- RecT ask+    when (n == 0) (fail "")+    RecT $ local (-1+) (runRecT cmd)++choice :: MonadGen m => [RecT m a] -> RecT m a+choice [] = fail ""+choice xs = do+        i <- liftGen $ choose (0,length xs-1)+        x <- try $ xs ! i+        maybe (choice $ remove i xs) return x+    where+        remove i xs = take i xs ++ drop (i+1) xs++runRec :: MonadGen m => RecT m a -> m (Maybe a)+runRec cmd = sized $ \n -> do+    x <- runMaybeT $ runReaderT (runRecT cmd) n -- (n^ (2 :: Int))+    return x++data MyTree = MyLeaf | TwoSubtrees MyTree MyTree | SomeSubtress [MyTree]+    deriving Show++-- tree :: Gen MyTree+-- tree = fromJust `liftM` runRec f+--     where+--         f = choice +--             [ return MyLeaf+--             , do+--                 t0 :+: t1 :+: () <- recurse f+--                 return $ TwoSubtrees t0 t1+--             , do +--                 ts <- recListFromTo 3 7 f+--                 return $ SomeSubtress ts+--             ] ++-- class Tuple a => TupleOf a b where+--     forAllM :: Monad m => m b -> m a++-- instance TupleOf () a where+--     forAllM _ = return ()++-- instance TupleOf as a => TupleOf (a :+: as) a where+--     forAllM cmd = do+--         x  <- cmd+--         xs <- forAllM cmd+--         return (x :+: xs)++instance Show a => Show (Tree a) where+    show (Tree x []) = show x+    show (Tree x ys) = printf "(%s %s)" first rest+        where+            first = show x+            rest = intercalate margin $ concatMap (lines . show) ys+            margin = '\n' : replicate (length first + 2) ' '++putInBins :: Int       -- number of objects+          -> Int       -- number of bins+          -> Gen [Int] -- return the number of objects in each bin+putInBins n bins = do+    xs <- replicateM n $ choose (0,bins-1)+    return $ map ((+(-1)).length) $ group $ sort $ xs ++ [0..bins-1]++prop_bin_length :: NonNegative Int -> Positive Int -> Property+prop_bin_length (NonNegative n) (Positive bins) = +        forAll (putInBins n bins) $ \xs -> length xs == bins++prop_bin_sum :: NonNegative Int -> Positive Int -> Property+prop_bin_sum (NonNegative n) (Positive bins) = +        forAll (putInBins n bins) $ \xs -> sum xs == n++prop_rand_tree_size :: Property+prop_rand_tree_size = forAll gen $ \(t,sz) -> size t <= sz ^ (2 :: Int)+    -- where++prop_subtree_size :: NonNegative Int +                  -> Positive Int +                  -> Property+prop_subtree_size (NonNegative n) (Positive sz) = +    n < sz ==> +    forAll (subtree_size n sz) $ +        \ts -> sum ts + 1 <= sz++gen :: Gen (Tree Int, Int)+gen = sized $ \sz -> do+    t <- arbitrary +    return (t,sz+1)++size :: Tree a -> Int+size (Tree _ xs) = 1 + sum (map size xs)++subtree_size :: Int -> Int -> Gen [Int]+subtree_size n sz = do+    bins <- if n == 0 +        then return []+        else putInBins (sz - n - 1) n+    return $ map (1+) bins++make_node :: Int -> Gen (Int,Int)+make_node sz = do+    frequency $+        [ (1,return (0,0)) ] +++        [ (5,return (1,5)) | (5 < sz) ]++make_struct :: Int -> [RecStruct] -> RecStruct+make_struct 0 [] = Leaf+make_struct 1 [a,b,c,d,e] = Node a b c d e+make_struct _ _ = error "make_struct: invalid tree shape"++tree_of :: Num a => RecStruct -> Tree a+tree_of Leaf = Tree 0 []+tree_of (Node a b c d e) = Tree 1 $ map tree_of [a,b,c,d,e]++prop_tree_shape :: Property+prop_tree_shape = forAll (tree_from make_node) $ +        \t -> all p $ subtrees t+    where+        p t =  (root t == 0 && degree t == 0) +            || (root t == 1 && degree t == 5)++subtrees :: Tree t -> [Tree t]+subtrees t@(Tree _ ts) = concatMap subtrees ts ++ [t]++degree :: Tree t -> Int+degree (Tree _ ts) = length ts++root :: Tree t -> t+root (Tree x _) = x++type NodeGen a b = (b -> Int -> Gen (a, [b]))++data RecStruct = Leaf | Node RecStruct RecStruct RecStruct RecStruct RecStruct++recursive_struct' :: NodeGen a b -> (a -> [c] -> c) -> b -> Gen c+recursive_struct' node tree x =+    tree_from' node x+    >>= fix (\rec (Tree y ts) -> do+            ys <- mapM rec ts+            return (tree y ys)+        )++recursive_struct :: (Int -> Gen (a, Int)) -> (a -> [c] -> c) -> Gen c+recursive_struct node tree = recursive_struct' (const $ (>>= f) . node) tree ()+    where+        f (x,n) = return (x,replicate n ())++tree_from' :: NodeGen a b -> b -> Gen (Tree a)+tree_from' node x = sized $ \sz -> +    tree_from_aux node x $ sz ^ (2 :: Int) + 1++tree_from :: (Int -> Gen (a, Int)) -> Gen (Tree a)+tree_from node = tree_from' (const $ (>>= f) . node) ()+    where+        f (x,n) = return (x,replicate n ())++tree_from_aux :: NodeGen a b -> b -> Int -> Gen (Tree a)+tree_from_aux node x sz = do+    unless (1 <= sz) $ error "tree_from: 1 <= sz"+    (val,n') <- node x sz+    let n = (sz-1) `take` n'+    bins  <- subtree_size (length n) sz+    ts    <- zipWithM (tree_from_aux node) n bins+    return $ Tree val ts++instance Arbitrary a => Arbitrary (Tree a) where+    arbitrary = sized $ \sz -> aux $ sz ^ (2 :: Int) + 1+        where+            aux sz = do+                n    <- choose (0,sz-1)+                bins <- subtree_size n sz+                ts   <- mapM aux bins+                x    <- arbitrary+                return $ Tree x ts++return []+run_tests :: (PropName -> Property -> IO (a, Result))+          -> IO ([a], Bool)+run_tests = $forAllProperties'
+ Test/QuickCheck/Regression.hs view
@@ -0,0 +1,9 @@+module Test.QuickCheck.Regression where++import Test.QuickCheck++regression :: (Show a, Testable b) => (a -> b) -> [a] -> Property+regression f xs = conjoin $ zipWith counterexample tags $ map f xs+    where+        tags = [ "counterexample " ++ show (i :: Int) ++ "\n" ++ show x | (i,x) <- zip [0..] xs ]+
+ Test/QuickCheck/Shrink.hs view
@@ -0,0 +1,13 @@+module Test.QuickCheck.Shrink where++import Control.Lens+import Control.Monad.Loops++import Test.QuickCheck+import Test.QuickCheck.Lens++doShrink :: Arbitrary a => (a -> Property) -> a -> IO a+doShrink prop x = do+        let args = stdArgs { chatty = False }+        y <- firstM (fmap (isn't _Success) . quickCheckWithResult args . prop) (shrink x)+        maybe (return x) (doShrink prop) y
+ Test/QuickCheck/ZoomEq.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE TypeOperators,StandaloneDeriving #-}+module Test.QuickCheck.ZoomEq where++import Control.Invariant +import Control.Lens hiding (from,to)++import Data.List.NonEmpty as NE (toList,NonEmpty)+import qualified Data.Map as M+import Data.Functor.Classes+import Data.Functor.Compose+import Data.Proxy+import Data.Word++import GHC.Generics++import Test.QuickCheck hiding ((===),counterexample)++infix 4 .==++newtype ShallowZoom a = ShallowZoom { unShallowZoom :: a } +    deriving (Eq, Show)++class (Eq a,Show a) => ZoomEq a where+    (.==) :: a -> a -> Invariant+    default (.==) :: (GZoomEq (Rep a),Generic a,Eq a) +                   => a -> a -> Invariant+    (.==) = genericZoomEq++genericZoomEq :: (GZoomEq (Rep a),Generic a,Eq a,Show a) +              => a -> a -> Invariant+genericZoomEq x y | x == y    = return ()+                  | otherwise = xs+    where+        xs = gZoomEq (from x) (from y)++instance (Eq a,Show a) => ZoomEq (ShallowZoom a) where+    (.==) = (===)++instance ZoomEq (Proxy a) where+deriving instance ZoomEq a => ZoomEq (Identity a) +instance ZoomEq Char where+    (.==) = (===)+instance ZoomEq Float where+    (.==) = (===)+instance ZoomEq Double where+    (.==) = (===)+instance ZoomEq Int where+    (.==) = (===)+instance ZoomEq Word16 where+    (.==) = (===)+instance ZoomEq Word32 where+    (.==) = (===)+instance ZoomEq Word64 where+    (.==) = (===)+instance (ZoomEq a,ZoomEq b) => ZoomEq (Either a b) where+deriving instance (ZoomEq (f (g a)),Eq a,Eq1 f,Eq1 g,Show a,Functor f,Show1 f,Show1 g) +        => ZoomEq (Compose f g a) +instance ZoomEq a => ZoomEq (Checked a) where+    x .== y = (x^.content') .== (y^.content')+instance ZoomEq a => ZoomEq (Maybe a) where+instance ZoomEq () where+    () .== () = return ()+instance (ZoomEq a,ZoomEq b) => ZoomEq (a,b) where+instance (ZoomEq a,ZoomEq b,ZoomEq c) => ZoomEq (a,b,c) where+instance (ZoomEq a,ZoomEq b,ZoomEq c,ZoomEq d) => ZoomEq (a,b,c,d) where+instance (ZoomEq a,ZoomEq b,ZoomEq c,ZoomEq d,ZoomEq e) => ZoomEq (a,b,c,d,e) where++instance ZoomEq a => ZoomEq (NonEmpty a) where+    xs .== ys = NE.toList xs .== NE.toList ys++instance (Ord k,Show k,ZoomEq a) => ZoomEq (M.Map k a) where+    xs .== ys = pXS >> pYS >> sequence_ (M.elems $ M.intersectionWithKey prop xs ys)+        where+            xs' = xs `M.difference` ys+            ys' = ys `M.difference` xs+            pXS = ("left keys:  " ++ show (M.keys xs')) ## M.null xs'+            pYS = ("right keys: " ++ show (M.keys ys')) ## M.null ys'+            prop k x y = ("key: " ++ show k) ## (x .== y)++instance ZoomEq a => ZoomEq [a] where+    xs .== ys = sequence_ $+                    zipWith3 (\i x y -> show i ## x .== y) [0..] xs ys+                ++ ["length" ## (length xs === length ys)]++class GZoomEq a where+    gZoomEq :: a p -> a p -> Invariant++instance GZoomEq a => GZoomEq (D1 z a) where+    gZoomEq (M1 x) (M1 y) = gZoomEq x y++instance (GZoomEq a,Constructor c) => GZoomEq (C1 c a) where+    gZoomEq c@(M1 x) (M1 y) = conName c ## gZoomEq x y++instance (ZoomEq a,Show a) => GZoomEq (K1 k a) where+    gZoomEq (K1 x) (K1 y) = x .== y++conjProp :: (Property -> Property) +         -> [Property] -> [Property]+conjProp _ [] = []+conjProp f xs = [conjoin $ map f xs]++instance (GZoomEq a,Selector s) => GZoomEq (S1 s a) where+    gZoomEq s@(M1 x) (M1 y) = +            (selName s ++ " = ") ## gZoomEq x y++instance (GZoomEq a,GZoomEq b) => GZoomEq (a :*: b) where+    gZoomEq (x0 :*: x1) (y0 :*: y1) = gZoomEq x0 y0 >> gZoomEq x1 y1++instance (GZoomEq a,GZoomEq b) => GZoomEq (a :+: b) where+    gZoomEq (L1 x) (L1 y) = gZoomEq x y+    gZoomEq (R1 x) (R1 y) = gZoomEq x y+    gZoomEq _ _ = return ()++instance GZoomEq U1 where+    gZoomEq _ _ = return ()
+ axiomatic-classes.cabal view
@@ -0,0 +1,97 @@+-- Initial axiomatic-classes.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++-- The name of the package.+name:                axiomatic-classes++-- The package version.  See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented.+-- http://www.haskell.org/haskellwiki/Package_versioning_policy+-- PVP summary:      +-+------- breaking API changes+--                   | | +----- non-breaking API additions+--                   | | | +--- code changes with no API change+version:             0.1.0.0++-- A short (one-line) description of the package.+synopsis:            Specify axioms for type classes and quickCheck all available instances++-- A longer description of the package.+description:         Provides a way to specify axioms for type classes+                     and to quickCheck all available instances against+                     them++-- The license under which the package is released.+license:             MIT++-- The file containing the license text.+license-file:        LICENSE++-- The package author(s).+author:              Simon Hudon++-- An email address to which users can send suggestions, bug reports, and +-- patches.+maintainer:          simon@cse.yorku.ca++-- A copyright notice.+-- copyright:           ++category:            Testing++build-type:          Simple++-- Extra files to be distributed with the package, such as examples or a +-- README.+-- extra-source-files:  ++-- Constraint on the version of Cabal needed to build this package.+cabal-version:       >=1.10++source-repository head+  type: git+  location: https://github.com/literate-unitb/axiomatic-classes.git++library+  -- Modules exported by the library.+  exposed-modules:     +      Test.QuickCheck.AxiomaticClass+      Test.QuickCheck.RandomTree+      Test.QuickCheck.Regression+      Test.QuickCheck.Shrink+      Test.QuickCheck.ZoomEq+  +  -- Modules included in this library but not exported.+  -- other-modules:       +  +  -- LANGUAGE extensions used by modules in this package.+  default-extensions:    TypeOperators, ScopedTypeVariables, TemplateHaskell, MultiParamTypeClasses, FunctionalDependencies, QuasiQuotes, DefaultSignatures, FlexibleContexts, TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving+  +  -- Other library packages from which modules are imported.+  build-depends:       +      base >=4.8 && <5+    , lens >=4.12 && <4.15+    , containers >=0.5 && <0.6+    , template-haskell >=2.10 && <2.12+    , QuickCheck >=2.8.1 && < 2.10+    , transformers >=0.4 && <0.6+    , mtl+    , th-printf+    , control-invariants+    , portable-template-haskell-lens+    , quickcheck-report+    , semigroups+    , monad-loops++  ghc-options: -W -fwarn-missing-signatures +         -fwarn-incomplete-uni-patterns+         -fwarn-missing-methods+         -fno-ignore-asserts+         -fwarn-tabs+         -j8+  +  -- Directories containing source files.+  hs-source-dirs:      .+  +  -- Base language which the package is written in.+  default-language:    Haskell2010+