show 0.3.4 → 0.4
raw patch · 5 files changed
+89/−158 lines, 5 filesdep −sybdep ~QuickCheckdep ~base
Dependencies removed: syb
Dependency ranges changed: QuickCheck, base
Files
- ShowFun.hs +2/−0
- ShowIO.hs +0/−6
- ShowQ.hs +27/−84
- SimpleReflect.hs +56/−54
- show.cabal +4/−14
ShowFun.hs view
@@ -7,3 +7,5 @@ instance (Typeable a, Typeable b) => Show (a -> b) where show e = '<' : (show . typeOf) e ++ ">" +instance Typeable a => Show (IO a) where+ show e = '<' : (show . typeOf) e ++ ">"
− ShowIO.hs
@@ -1,6 +0,0 @@-module ShowIO where--import Data.Typeable--instance Typeable a => Show (IO a) where- show e = '<' : (show . typeOf) e ++ ">"
ShowQ.hs view
@@ -1,96 +1,35 @@ {-# LANGUAGE NoMonomorphismRestriction #-} -- Helper code for runplugs------ Note: must be kept in separate module to hide unsafePerformIO from--- runplugs-generated eval code!! you're warned. module ShowQ where --- import Language.Haskell.TH-import System.IO.Unsafe-import Data.Ratio--import qualified Test.SmallCheck (smallCheck, Testable)-import Test.QuickCheck-import Data.Char-import Data.List-import Data.Word-import Data.Int-import System.Random--type T = [Int]-type I = Int--instance Arbitrary Char where- arbitrary = choose (minBound, maxBound)- coarbitrary c = variant (ord c `rem` 4)--instance Arbitrary Word8 where- arbitrary = choose (minBound, maxBound)- coarbitrary c = variant (fromIntegral ((fromIntegral c) `rem` 4))--instance Arbitrary Ordering where- arbitrary = elements [LT,EQ,GT]- coarbitrary LT = variant 1- coarbitrary EQ = variant 2- coarbitrary GT = variant 0--instance Arbitrary Int64 where- arbitrary = sized $ \n -> choose (-fromIntegral n,fromIntegral n)- coarbitrary n = variant (fromIntegral (if n >= 0 then 2*n else 2*(-n) + 1))--instance (Integral a, Arbitrary a) => Arbitrary (Ratio a) where- arbitrary = do a <- arbitrary- b <- arbitrary- return $ if b == 0- then if a == 0- then (1 % 1)- else (b % a)- else (a % b)-- coarbitrary m = variant (fromIntegral $ if n >= 0 then 2*n else 2*(-n) + 1)- where n = numerator m--instance Random Word8 where- randomR = integralRandomR- random = randomR (minBound,maxBound)--instance Random Int64 where- randomR = integralRandomR- random = randomR (minBound,maxBound)--integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)-integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,- fromIntegral b :: Integer) g of- (x,g) -> (fromIntegral x, g)+import Data.List (group, intercalate, sort)+import System.IO.Unsafe (unsafePerformIO)+import Test.QuickCheck (numTests, quickCheckWithResult, stdArgs, Result(..), Testable)+import qualified Test.SmallCheck as SC (smallCheck, Testable) -mysmallcheck :: (Test.SmallCheck.Testable a) => a -> ()+mysmallcheck :: (SC.Testable prop) => prop -> () mysmallcheck = unsafePerformIO . mysmallcheck'-mysmallcheck' :: (Test.SmallCheck.Testable a) => a -> IO ()-mysmallcheck' a = Test.SmallCheck.smallCheck 6 a+mysmallcheck' :: (SC.Testable prop) => prop -> IO ()+mysmallcheck' = SC.smallCheck 6 -myquickcheck :: Testable a => a -> String+myquickcheck :: Testable prop => prop -> String myquickcheck = unsafePerformIO . myquickcheck' -myquickcheck' :: Testable a => a -> IO String-myquickcheck' a = do- rnd <- newStdGen- tests (evaluate a) rnd 0 0 []+myquickcheck' :: Testable prop => prop -> IO String+myquickcheck' a = tests a 0 [] -tests :: Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO String-tests gen rnd0 ntest nfail stamps- | ntest == 500 = done "OK, passed" ntest stamps- | nfail == 1000 = done "Arguments exhausted after" ntest stamps- | otherwise = case ok result of- Nothing -> tests gen rnd1 ntest (nfail+1) stamps- Just True -> tests gen rnd1 (ntest+1) nfail (stamp result:stamps)- Just False -> return $ "Falsifiable, after "- ++ show ntest- ++ " tests:\n"- ++ unlines (arguments result)- where- result = generate (((+ 3) . (`div` 2)) ntest) rnd2 gen- (rnd1,rnd2) = split rnd0+tests :: (Testable prop) => prop -> Int -> [[String]] -> IO String+tests prop ntest stamps =+ do result <- quickCheckWithResult stdArgs prop+ case result of+ NoExpectedFailure _ _ _ -> done "Arguments exhausted after" (numTests result) stamps+ GaveUp _ _ _ -> done "Arguments exhausted after" (numTests result) stamps+ Success _ _ _ -> done "OK, passed" (numTests result) stamps+ Failure _ _ _ _ _ _ _ -> return $ "Falsifiable, after "+ ++ show ntest+ ++ " tests:\n"+ ++ reason result done :: String -> Int -> [[String]] -> IO String done mesg ntest stamps = return $ mesg ++ " " ++ show ntest ++ " tests" ++ table@@ -107,10 +46,14 @@ display [] = "." display [x] = " (" ++ x ++ ")."- display xs = "." ++ unlines (map (++ ".") xs)+ display xs = '.' : unlines (map (++ ".") xs) + pairLength :: [a] -> (Int, a)+ pairLength [] = (0, error "pairLength should never get an empty list") pairLength xss@(xs:_) = (length xss, xs)+ entry (n, xs) = percentage n ntest- ++ concat (intersperse ", " xs)+ ++ intercalate ", " xs percentage n m = show ((100 * n) `div` m) ++ "%"+
SimpleReflect.hs view
@@ -18,16 +18,15 @@ , a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z ) where --import Data.List import Control.Applicative {- -- Lennart Augustsson's extensions, temporarily disabled. import Control.Monad.State hiding(lift) -} -import Data.Typeable-import Data.Generics hiding (Fixity)+import Data.Maybe (fromMaybe)+import Data.Ord (comparing)+import Data.Generics (Typeable, Data) ------------------------------------------------------------------------------@@ -42,7 +41,7 @@ } deriving (Typeable, Data) instance Show Expr where- showsPrec p r = showExpr r p+ showsPrec pp rr = showExpr rr pp -- Default expression emptyExpr :: Expr@@ -58,40 +57,45 @@ -- | A variable var :: String -> Expr-var s = emptyExpr { showExpr = \_ -> showString s }+var ss = emptyExpr { showExpr = \_ -> showString ss } lift :: Show a => a -> Expr-lift x = emptyExpr { showExpr = \p -> showsPrec p x }+lift xx = emptyExpr { showExpr = (`showsPrec` xx) } data Fixity = L | R deriving Eq -- | A operator as expression op :: Fixity -> Int -> String -> Expr -> Expr -> Expr-op fix prec op a b = emptyExpr { showExpr = showFun }- where showFun p = showParen (p > prec)- $ showExpr a (if fix == L then prec else prec + 1)- . showString op- . showExpr b (if fix == R then prec else prec + 1)+op fix prec opp aa bb = emptyExpr { showExpr = showFun }+ where showFun pp = showParen (pp > prec)+ $ showExpr aa (if fix == L then prec else prec + 1)+ . showString opp+ . showExpr bb (if fix == R then prec else prec + 1) ------------------------------------------------------------------------------ -- Adding numeric results --------------------------------------------------------------------------------iOp r f a = (r a ) { intExpr = f <$> intExpr a }-iOp2 r f a b = (r a b) { intExpr = f <$> intExpr a <*> intExpr b }-dOp r f a = (r a ) { doubleExpr = f <$> doubleExpr a }-dOp2 r f a b = (r a b) { doubleExpr = f <$> doubleExpr a <*> doubleExpr b }+iOp :: (Expr -> Expr) -> (Integer -> Integer) -> Expr -> Expr+iOp rr ff aa = (rr a ) { intExpr = ff <$> intExpr aa }+iOp2 :: (Expr -> Expr -> Expr) -> (Integer -> Integer -> Integer) -> Expr -> Expr -> Expr+iOp2 rr ff aa bb = (rr aa bb) { intExpr = ff <$> intExpr aa <*> intExpr bb }+dOp :: (Expr -> Expr) -> (Double -> Double) -> Expr -> Expr+dOp rr ff aa = (rr aa ) { doubleExpr = ff <$> doubleExpr aa }+dOp2 :: (Expr -> Expr -> Expr) -> (Double -> Double -> Double) -> Expr -> Expr -> Expr+dOp2 rr ff aa bb = (rr aa bb) { doubleExpr = ff <$> doubleExpr aa <*> doubleExpr bb } -withReduce r a = let rr = r a in- rr { reduced = withReduce r <$> reduced a- <|> fromInteger <$> intExpr rr- <|> fromDouble <$> doubleExpr rr+withReduce :: (Expr -> Expr) -> Expr -> Expr+withReduce rr aa = let rrr = rr aa in+ rrr { reduced = withReduce rr <$> reduced aa+ <|> fromInteger <$> intExpr rrr+ <|> fromDouble <$> doubleExpr rrr }-withReduce2 r a b = let rr = r a b in- rr { reduced = (\a' -> withReduce2 r a' b) <$> reduced a- <|> (\b' -> withReduce2 r a b') <$> reduced b- <|> fromInteger <$> intExpr rr- <|> fromDouble <$> doubleExpr rr+withReduce2 :: (Expr -> Expr -> Expr) -> Expr -> Expr -> Expr+withReduce2 rr aa bb = let rrr = rr aa bb in+ rrr { reduced = (\aa' -> withReduce2 rr aa' b) <$> reduced aa+ <|> withReduce2 rr aa <$> reduced bb+ <|> fromInteger <$> intExpr rrr+ <|> fromDouble <$> doubleExpr rrr } ------------------------------------------------------------------------------@@ -105,7 +109,7 @@ fromExpr = id instance (Show a, FromExpr b) => FromExpr (a -> b) where- fromExpr f a = fromExpr $ op L 10 " " f (lift a)+ fromExpr ff aa = fromExpr $ op L 10 " " ff (lift aa) fun :: FromExpr a => String -> a fun = fromExpr . var@@ -116,7 +120,7 @@ a,b,c,d,e,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z :: Expr [a,b,c,d,e,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z]- = [var [x] | x <- ['a'..'e']++['i'..'z']]+ = [var [xx] | xx <- ['a'..'e']++['i'..'z']] f,g,h :: FromExpr a => a f = fun "f"@@ -134,24 +138,21 @@ -- | Reduce (evaluate) an expression once -- for example 1 + 2 + 3 + 4 ==> 3 + 3 + 4 reduce :: Expr -> Expr-reduce e = maybe e id (reduced e)--reduction :: Expr -> [Expr]-reduction e = e : unfoldr (\e -> do e' <- reduced e; return (e',e')) e+reduce ee = fromMaybe ee (reduced ee) ------------------------------------------------------------------------------ -- Numeric classes ------------------------------------------------------------------------------ instance Eq Expr where- Expr{ intExpr = Just a } == Expr{ intExpr = Just b } = a == b- Expr{ doubleExpr = Just a } == Expr{ doubleExpr = Just b } = a == b- a == b = show a == show b+ Expr{ intExpr = Just aa } == Expr{ intExpr = Just bb } = aa == bb+ Expr{ doubleExpr = Just aa } == Expr{ doubleExpr = Just bb } = aa == bb+ aa == bb = show aa == show bb instance Ord Expr where- compare Expr{ intExpr = Just a } Expr{ intExpr = Just b } = compare a b- compare Expr{ doubleExpr = Just a } Expr{ doubleExpr = Just b } = compare a b- compare a b = compare (show a) (show b)+ compare Expr{ intExpr = Just aa } Expr{ intExpr = Just bb } = compare aa bb+ compare Expr{ doubleExpr = Just aa } Expr{ doubleExpr = Just bb } = compare aa bb+ compare aa bb = comparing show aa bb min = fun "min" `iOp2` min `dOp2` min max = fun "max" `iOp2` max `dOp2` max @@ -162,33 +163,34 @@ negate = withReduce $ fun "negate" `iOp` negate `dOp` negate abs = withReduce $ fun "abs" `iOp` abs `dOp` abs signum = withReduce $ fun "signum" `iOp` signum `dOp` signum- fromInteger i = (lift i)- { intExpr = Just i- , doubleExpr = Just $ fromInteger i }+ fromInteger ii = (lift ii)+ { intExpr = Just ii+ , doubleExpr = Just $ fromInteger ii } instance Real Expr where- toRational expr = case (doubleExpr expr, intExpr expr) of- (Just d,_) -> toRational d- (_,Just i) -> toRational i+ toRational xpr = case (doubleExpr xpr, intExpr xpr) of+ (Just dd,_) -> toRational dd+ (_,Just ii) -> toRational ii _ -> error "not a number" instance Integral Expr where- quotRem a b = (quot a b, rem a b)- divMod a b = (div a b, mod a b)+ quotRem aa bb = (quot aa bb, rem aa bb)+ divMod aa bb = (div aa bb, mod aa bb) quot = withReduce2 $ op L 7 " `quot` " `iOp2` quot rem = withReduce2 $ op L 7 " `rem` " `iOp2` rem div = withReduce2 $ op L 7 " `div` " `iOp2` div mod = withReduce2 $ op L 7 " `mod` " `iOp2` mod- toInteger expr = case intExpr expr of- Just i -> i+ toInteger xpr = case intExpr xpr of+ Just ii -> ii _ -> error "not a number" instance Fractional Expr where (/) = withReduce2 $ op L 7 " / " `dOp2` (/) recip = withReduce $ fun "recip" `dOp` recip- fromRational r = fromDouble (fromRational r)+ fromRational rr = fromDouble (fromRational rr) -fromDouble d = (lift d) { doubleExpr = Just d }+fromDouble :: Double -> Expr+fromDouble dd = (lift dd) { doubleExpr = Just dd } instance Floating Expr where pi = (var "pi") { doubleExpr = Just pi }@@ -212,10 +214,10 @@ pred = withReduce $ fun "pred" `iOp` pred `dOp` pred toEnum = fun "toEnum" fromEnum = fromEnum . toInteger- enumFrom a = map fromInteger $ enumFrom (toInteger a)- enumFromThen a b = map fromInteger $ enumFromThen (toInteger a) (toInteger b)- enumFromTo a c = map fromInteger $ enumFromTo (toInteger a) (toInteger c)- enumFromThenTo a b c = map fromInteger $ enumFromThenTo (toInteger a) (toInteger b) (toInteger c)+ enumFrom aa = map fromInteger $ enumFrom (toInteger aa)+ enumFromThen aa bb = map fromInteger $ enumFromThen (toInteger aa) (toInteger bb)+ enumFromTo aa cc = map fromInteger $ enumFromTo (toInteger aa) (toInteger cc)+ enumFromThenTo aa bb cc = map fromInteger $ enumFromThenTo (toInteger aa) (toInteger bb) (toInteger cc) instance Bounded Expr where minBound = var "minBound"
show.cabal view
@@ -1,5 +1,5 @@ name: show-version: 0.3.4+version: 0.4 license: GPL license-file: LICENSE@@ -11,7 +11,7 @@ synopsis: 'Show' instances for Lambdabot description: This package provides ShowQ, ShowFun, and SimpleReflect. .- ShowFun gives a Typeable-dependent instance for showing functions as their type. ShowIO does the same for IO actions.+ ShowFun gives us Typeable instances for neutering IO expressions. . ShowQ adds SmallCheck & QuickCheck support. .@@ -22,20 +22,10 @@ Cabal-Version: >= 1.2 tested-with: GHC==6.8.2 -Flag Base4orNewer- Description: Adjusts the build dependencies depending on which version of Base is available.- -- Cabal checks if the configuration is possible, first- -- with this flag set to True and if not it tries with False- library- exposed-modules: ShowQ, ShowFun, ShowIO, SimpleReflect-- build-depends: random, QuickCheck<2, smallcheck>=0.4+ exposed-modules: ShowQ, ShowFun, SimpleReflect - if flag(Base4orNewer)- build-depends: base >= 4 && < 5, syb- else- build-depends: base >= 3 && < 4+ build-depends: base<4, random, QuickCheck>=2, smallcheck>=0.4 ghc-options: -Wall ghc-prof-options: -prof -auto-all