bff (empty) → 0.1
raw patch · 19 files changed
+1889/−0 lines, 19 filesdep +Chartdep +basedep +benchpresssetup-changed
Dependencies added: Chart, base, benchpress, bimap, category-extras, cgi, containers, derive, directory, haskell98, hint, mtl, template-haskell, unix, utf8-string, xhtml
Files
- Data/Bff.hs +139/−0
- Data/Derive/Zippable.hs +122/−0
- Data/IntMapEq.hs +87/−0
- Data/IntMapOrd.hs +97/−0
- Data/Zippable.hs +25/−0
- Data/Zippable/Definition.hs +65/−0
- MyInterpret.hs +126/−0
- QuickCheck.hs +445/−0
- QuickCheckTH.hs +17/−0
- Setup.hs +5/−0
- SimpleTree.hs +31/−0
- Stats.hs +200/−0
- StatsDef.hs +5/−0
- StatsPrint.hs +27/−0
- StatsRender.hs +50/−0
- bff-cgi.hs +289/−0
- bff-shell.hs +24/−0
- bff.cabal +117/−0
- testcgi.py +18/−0
+ Data/Bff.hs view
@@ -0,0 +1,139 @@+{-# OPTIONS_GHC -XRank2Types #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Bff+-- +-- Maintainer : Janis Voigtlaender+-- Stability : experimental+--+-- This modules contains automatic bidirectionalizer, as described in the paper+-- \"Bidirectionalization for Free!\" (POPL'09) by Janis Voigtlaender.+--+-----------------------------------------------------------------------------++module Data.Bff (bff, bff_Eq, bff_Ord) where++import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap (fromAscList, union, lookup, empty, insert)+import Data.IntMapEq (IntMapEq)+import qualified Data.IntMapEq as IntMapEq (union, lookup, empty, lookupR, insert, checkInsert)+import Data.IntMapOrd (IntMapOrd)+import qualified Data.IntMapOrd as IntMapOrd (union, lookup, fromAscPairList, empty, checkInsert, lookupR)+import Data.Set (Set)+import qualified Data.Set as Set (toAscList, singleton)+import Maybe (fromJust)+import Control.Monad.State (State, runState)+import qualified Control.Monad.State as State (get, put)+import Control.Applicative +import Control.Functor.Combinators.Lift+import Data.Traversable+import Data.Foldable+import Data.Zippable++template :: Traversable k => k a -> (k Int, IntMap a)+template s = + case runState (go s) ([],0)+ of (s',(l,_)) -> (s',IntMap.fromAscList (reverse l))+ where go = unwrapMonad+ . traverse (WrapMonad . number)++number :: a -> State ([(Int,a)], Int) Int+number a = do (l,i) <- State.get+ State.put ((i,a):l, i+1)+ return i++assoc :: (Zippable k, Foldable k, Eq a)+ => k Int -> k a -> Either String (IntMap a)+assoc = makeAssoc checkInsert IntMap.empty++makeAssoc checkInsert empty s'' v =+ either Left f (tryZip s'' v)+ where f = Data.Foldable.foldr + (either Left . uncurry checkInsert) + (Right empty) ++checkInsert :: Eq a => Int -> a -> IntMap a+ -> Either String (IntMap a)+checkInsert i b m =+ case IntMap.lookup i m of+ Nothing -> Right (IntMap.insert i b m)+ Just c -> if b==c + then Right m + else Left "Update violates equality."++-- | Given a sufficiently polymorphic getter that returns a view without looking at the+-- values of the input data structure, this function returns a setter that inserts+-- an updated view back into the original data structure.+bff :: (Traversable k, Zippable k', Foldable k') + => (forall a. k a -> k' a) + -> (forall a. Eq a => k a -> k' a -> k a)+bff get = \s v ->+ let (s',g) = template s+ h = either error id (assoc (get s') v)+ h' = IntMap.union h g+ in seq h (fmap (fromJust . flip IntMap.lookup h') s')+++template_Eq :: (Traversable k, Eq a) + => k a -> (k Int, IntMapEq a)+template_Eq s = case runState (go s) (IntMapEq.empty,0) + of (s',(g,_)) -> (s',g)+ where go = unwrapMonad+ . traverse (WrapMonad . number_Eq)++number_Eq :: Eq a => a -> State (IntMapEq a, Int) Int+number_Eq a = + do (m,i) <- State.get+ case IntMapEq.lookupR a m of+ Just j -> return j+ Nothing -> do let m' = IntMapEq.insert i a m+ State.put (m',i+1)+ return i++assoc_Eq :: (Zippable k, Foldable k, Eq a)+ => k Int -> k a -> Either String (IntMapEq a)+assoc_Eq = makeAssoc IntMapEq.checkInsert + IntMapEq.empty++-- | Works like 'bff', but can also handle getter functions that compare the elements+-- of the source container using '==' or '/='.+bff_Eq :: (Traversable k, Zippable k', Foldable k') + => (forall a. Eq a => k a -> k' a) + -> (forall a. Eq a => k a -> k' a -> k a)+bff_Eq get = \s v -> + let (s',g) = template_Eq s+ h = either error id (assoc_Eq (get s') v)+ h' = either error id (IntMapEq.union h g)+ in seq h' (fmap (fromJust . flip IntMapEq.lookup h') s')+++template_Ord :: (Traversable k, Ord a) + => k a -> (k Int,IntMapOrd a)+template_Ord s = case traverse number_Ord s of+ Lift (Const as,f) -> let m = set2map as+ in (f m,m)++number_Ord :: Ord a => a -> Lift (,) (Const (Set a)) + ((->) (IntMapOrd a)) Int+number_Ord a = Lift (Const (Set.singleton a), + fromJust . IntMapOrd.lookupR a)++set2map :: Ord a => Set a -> IntMapOrd a+set2map as = + IntMapOrd.fromAscPairList (zip [0..] (Set.toAscList as))++assoc_Ord :: (Zippable k, Foldable k, Ord a)+ => k Int -> k a -> Either String (IntMapOrd a)+assoc_Ord = makeAssoc IntMapOrd.checkInsert + IntMapOrd.empty++-- | Works like 'bff', but can also handle getter functions that compare the elements+-- using the 'Ord' typeclass (and thus potentially also using '==' or '/=').+bff_Ord :: (Traversable k, Zippable k', Foldable k') + => (forall a. Ord a => k a -> k' a) + -> (forall a. Ord a => k a -> k' a -> k a)+bff_Ord get = \s v ->+ let (s',g) = template_Ord s+ h = either error id (assoc_Ord (get s') v)+ h' = either error id (IntMapOrd.union h g)+ in seq h' (fmap (fromJust . flip IntMapOrd.lookup h') s')
+ Data/Derive/Zippable.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE PatternGuards, TemplateHaskell #-}++module Data.Derive.Zippable (makeZippable) where++import Language.Haskell.TH.All+import Control.Monad+import Control.Monad.Either+-- import NormalizeData+import Data.Zippable.Definition++-- | A derivation that can be used with 'derive' from "Data.DeriveTH"+--+-- It supports algebraic types, including nested tuples and types. Not supported are+-- function application and nested type aliases.+makeZippable :: Derivation+makeZippable = derivation zip' "Zippable"++zip' dat | (dataArity dat) /= 1 = error "Cannot handle types with arity not one."+ | otherwise =+ let typeName | dataName dat == "[]" = ConT ''[] -- doesn’t work!+ | otherwise = lK (dataName dat) []+ head = InstanceD [] (AppT (ConT (mkName "Zippable")) typeName)+ func = funN "tryZipWith'" (+ map mkClause (dataCtors dat) +++ whenP (length (dataCtors dat) > 1)+ [Clause [WildP, WildP, WildP]+ (NormalB (app (VarE 'throwCError) [LitE (StringL+ "Shape mismatch."+ )]))+ []+ ]+ )+ in [ head [ func ] ]+++mkClause :: CtorDef -> Clause+mkClause con = sclause [vr "func", lK (ctorName con) pat1names, lK (ctorName con) pat2names]+ (collectZips (map zipVar [0..ctorArity con-1]) (lK (ctorName con)))++ where varnames number prefix = map (vr . (prefix++) . show) [1..number]+ pat1names, pat2names :: Valcon a => [a]+ pat1names = varnames (ctorArity con) "x"+ pat2names = varnames (ctorArity con) "y"++ collectZips actions join =+ DoE $ zipWith BindS zipnames actions +++ [ NoBindS $ lK "return" [join zipnames]]+ where zipnames :: Valcon a => [a]+ zipnames = varnames (length actions) "z"+ + zipVar n = app (zip (ctorTypes con !! n)) [pat1names !! n, pat2names !! n]++ tupMerge ts = let pat1names, pat2names, zipnames :: Valcon a => [a]+ n = length ts+ pat1names = varnames n "x"+ pat2names = varnames n "y"+ zipnames = varnames n "z"+ in LamE [x,y] $ CaseE (TupE [x,y]) [ Match+ (TupP [TupP pat1names, TupP pat2names])+ (NormalB+ (collectZips+ (map (\i -> app (zip (ts !! i)) [pat1names !! i, pat2names !! i]) [0..n-1])+ TupE + )+ )+ []+ ]++ zip ctype = case ctype of + VarT _ ->+ lK "func" []+ ConT _ ->+ (VarE 'checkEquality)+ -- If we have tuples, we basically have to repeat the currenct procedure+ -- Using a case expressen, we can safly re-use variables names, even+ -- with nested tuples.+ t@(AppT _ _) | (ht, ts) <- typeApp t, isTupleT ht ->+ tupMerge ts + AppT t (VarT _) | not (tyHasVar t) -> + lK "tryZipWith'" [vr "func"]+ t@(AppT _ _) | not (tyHasVar t) -> + (VarE 'checkEquality)+ t@(AppT _ ct) ->+ lK "tryZipWith'" [zip ct]+ ForallT _ _ _ ->+ error "Types with forall not supported by Zippable deriver."+ TupleT _ ->+ error "Types with tuples not expected here."+ ArrowT ->+ error "Arrow types not supported by Zippable deriver."+ ListT ->+ error "List types not supported by Zippable deriver."++ x,y :: Valcon a => a+ x = vr "x"+ y = vr "y"++tyHasVar t = case t of+ VarT _ -> True+ ConT _ -> False+ AppT t1 t2 -> tyHasVar t1 || tyHasVar t2+ ForallT _ _ _ -> error "Types with forall not supported by Zippable deriver."+ TupleT _ -> False+ ArrowT -> False+ ListT -> False++whenP :: MonadPlus m => Bool -> m a -> m a+whenP True x = x+whenP False _ = mzero++-- | Functions used in the derived code+checkEquality x y = if (x == y) then return x+ else throwCError "Value mismatch."+++-- | Extract a 'DataDef' value from a type using the TH 'reify'+-- framework.+deriveOne :: Name -> Q DataDef+deriveOne x = liftM extract (reify x)++extract (TyConI decl) = normData decl+extract _ = error $ "Data.Derive.TH.deriveInternal: not a type!"
+ Data/IntMapEq.hs view
@@ -0,0 +1,87 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.IntMapEq+-- +-- Maintainer : Janis Voigtlaender+-- Stability : experimental+--+-- A variant of the regular 'Data.IntMap', enforcing injectivity (up to '==').+--+-- As with 'Data.IntMap', many operations have a worst-case complexity of /O(min(n,W))/.+-- This means that the operation can become linear in the number of elements with a+-- maximum of W -- the number of bits in an Int (32 or 64).+-----------------------------------------------------------------------------+module Data.IntMapEq + ( IntMapEq,+ empty,+ insert,+ checkInsert,+ lookup,+ lookupR,+ member,+ memberR,+ union,+ toList ) where++import qualified Data.IntMap as IntMap+import Prelude hiding (lookup)+import qualified Prelude++newtype IntMapEq a = IntMapEq (IntMap.IntMap a)++instance Show a => Show (IntMapEq a) where+ show (IntMapEq m) = show m++-- | /O(1)/. The empty map. +empty :: IntMapEq a+empty = IntMapEq IntMap.empty++-- | /O(min(n,W))/. Insert a new key\/value pair in the map.+-- If the key is already present in the map, the associated value is+-- replaced with the supplied value. The injectivity invarant is /not/ enforced.+insert :: Int -> a -> IntMapEq a -> IntMapEq a+insert k a (IntMapEq m) = IntMapEq (IntMap.insert k a m)++-- | /O(n * min(n,W))/. Insert a new key\/value pair in the map, if it is either+-- a new key, or agrees with the present value. If not, an error is signalled using+-- a 'Left' return value.+checkInsert :: Eq a => Int -> a -> IntMapEq a -> Either String (IntMapEq a)+checkInsert i b m = case lookup i m of+ Nothing -> if memberR b m + then Left "Update violates differentness."+ else Right (insert i b m)+ Just c -> if b==c + then Right m + else Left "Update violates equality."++-- | /O(min(n,W))/. Is the key a member of the map?+member :: Int -> IntMapEq a -> Bool+member k (IntMapEq m) = IntMap.member k m++-- | /O(n * min(n,W))/. Is the value a member of the map?+memberR :: Eq a => a -> IntMapEq a -> Bool+memberR a (IntMapEq m) = elem a (IntMap.elems m)++-- | /O(min(n,W))/. Lookup the value at a key in the map.+lookup :: Int -> IntMapEq a -> Maybe a+lookup k (IntMapEq m) = IntMap.lookup k m++-- | /O(n * min(n,W))/. Lookup the key at a value in the map.+lookupR :: Eq a => a -> IntMapEq a -> Maybe Int+lookupR a (IntMapEq m) = Prelude.lookup a (map (\(k,a) -> (a,k)) (IntMap.toList m))++-- | /O(m * n * min(n,W))/. The union of two maps. It prefers the first map+-- when duplicate keys are encountered. If the injectivity invarant is violated,+-- an error is signaled with a 'Left' return value.+union :: Eq a => IntMapEq a -> IntMapEq a -> Either String (IntMapEq a)+union h (IntMapEq m) = IntMap.foldWithKey f (Right h) m+ where f j a (Right h) = if member j h + then Right h + else if memberR a h+ then Left "Update violates differentness."+ else Right (insert j a h)+ f j a l = l++-- | /O(n)/. Convert the map to a list of key\/value pairs.+toList :: IntMapEq a -> [(Int,a)]+toList (IntMapEq m) = IntMap.toList m
+ Data/IntMapOrd.hs view
@@ -0,0 +1,97 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.IntMapOrd+-- +-- Maintainer : Janis Voigtlaender+-- Stability : experimental+--+-- A variant of the regular 'Data.IntMap', enforcing that the map is monotonous+-- with regard to 'Ord'.+--+-----------------------------------------------------------------------------+module Data.IntMapOrd + ( IntMapOrd,+ empty,+ checkInsert,+ lookup,+ lookupR,+ member,+ memberR,+ union,+ fromAscPairList,+ toList ) where++import qualified Data.Map as Map+import qualified Data.Bimap as Bimap+import Prelude hiding (lookup)++newtype IntMapOrd a = IntMapOrd (Bimap.Bimap Int a) ++instance Show a => Show (IntMapOrd a) where+ show (IntMapOrd m) = show m++-- | /O(log n)/. Lookup the key for a value in the map.+lookupR :: Ord a => a -> IntMapOrd a -> Maybe Int+lookupR a (IntMapOrd m) = Bimap.lookupR a m++-- | /O(log n)/. Is the key a member of the map?+member :: Ord a => Int -> IntMapOrd a -> Bool+member k (IntMapOrd m) = Bimap.member k m++-- | /O(log n)/. Is the value a member of the map?+memberR :: Ord a => a -> IntMapOrd a -> Bool+memberR a (IntMapOrd m) = Bimap.memberR a m++-- | /O(n)/. Build a map from a list of pairs, where+-- both the fst and snd parts of the list are in strictly ascending order.+-- +-- This precondition is not checked; an invalid list will produce a malformed map. +fromAscPairList :: Ord a => [(Int,a)] -> IntMapOrd a+fromAscPairList l = IntMapOrd (Bimap.fromAscPairListUnchecked l)++-- | /O(1)/. The empty map. +empty :: IntMapOrd a+empty = IntMapOrd Bimap.empty++-- | /O(log n)/. Lookup the value at a key in the map.+lookup :: Ord a => Int -> IntMapOrd a -> Maybe a+lookup k (IntMapOrd m) = Bimap.lookup k m++insert :: Ord a => Int -> a -> IntMapOrd a -> Either String (IntMapOrd a)+insert k a (IntMapOrd m) = let (m1,m2) = Map.split k (Bimap.toMap m)+ in if (Map.null m1 || snd (Map.findMax m1) < a) + && (Map.null m2 || snd (Map.findMin m2) > a) + then Right (IntMapOrd (Bimap.insert k a m)) + else Left "Update violates relative order."++-- | /O(log n)/. Insert a new key\/value pair in the map. Errors are:+--+-- * Inserting an existing key with a different value.+--+-- * Inserting a key with a value that already exists for another key.+--+-- * Inserting a key\/value pair that breaks the monotonicity invariant.+checkInsert :: Ord a => Int -> a -> IntMapOrd a -> Either String (IntMapOrd a)+checkInsert i b m = case lookup i m of+ Nothing -> if memberR b m+ then Left "Update violates differentness."+ else insert i b m+ Just c -> if b==c + then Right m + else Left "Update violates equality."++-- | /O(n * log n)/. The union of two maps. It prefers the first map+-- when duplicate keys are encountered. If the monotonicity invariant is violated,+-- an error is signalled with a 'Left' return value.+union :: Ord a => IntMapOrd a -> IntMapOrd a -> Either String (IntMapOrd a)+union h (IntMapOrd m) = Bimap.fold f (Right h) m+ where f k a (Right h) = if member k h + then Right h + else if memberR a h+ then Left "Update violates differentness."+ else insert k a h+ f k a l = l++-- | /O(n)/. Convert the map to a list of key\/value pairs.+toList :: IntMapOrd a -> [(Int,a)]+toList (IntMapOrd a) = Bimap.toList a
+ Data/Zippable.hs view
@@ -0,0 +1,25 @@+{-# OPTIONS_GHC -XTemplateHaskell -XFlexibleInstances -XFlexibleContexts -fallow-undecidable-instances #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Zippable+-- Copyright : (c) 2008 Joachim Breitner+-- +-- Maintainer : Joachim Breitner+-- Stability : experimental+--+-- Class of data structures that can match equal shapes and combine the values.+-----------------------------------------------------------------------------++module Data.Zippable (+ module Data.Zippable.Definition,+ makeZippable+) where+++import Data.Zippable.Definition+import Data.DeriveTH+import Data.Derive.Zippable++$(derive makeZippable ''Maybe)+$(derive makeZippable ''[])+
+ Data/Zippable/Definition.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE ExistentialQuantification, PolymorphicComponents #-}+module Data.Zippable.Definition+ ( Zippable(..)+ , CError+ , throwCError+ , cErrorToEither+ ) where++import Data.Traversable++-- | Efficient error reporting monad, as described in the paper \"Asymptotic+-- Improvement of Computations over Free Monads\" by Janis Voigtländer.+--+-- Can be used in places where one would use ('Either' String).+newtype CError a = CError (forall b. (a -> Either String b) -> Either String b)++instance Monad CError where+ return a = CError (\h -> h a)+ (CError p) >>= k = CError (\h -> p (\a -> case k a of CError q -> q h))++-- | Throw an error inside a 'CError' computation. Compare with 'Left' in the+-- ('Either' String) monad.+throwCError :: String -> CError a+throwCError err = CError (const (Left err))++-- | Run a 'CError' computation, and convert any error to 'Left' values.+cErrorToEither :: CError a -> Either String a+cErrorToEither (CError p) = p Right++-- | Data structures that can be folded.+--+-- Minimal complete definition: any of 'tryZipWith'' (preferred for efficiency), 'tryZipWith', or 'tryZip'+--+-- For example, given a data type:+--+-- > data Tree a = Leaf a | Node (Tree a) (Tree a)+-- +-- a suitable instance would be+-- +-- > instance Zippable Tree where+-- > tryZipWith' func (Leaf a) (Leaf b) = Right (Leaf (func a b))+-- > tryZipWith' func (Node a1 a2) (Node b1 b2) = do z1 <- tryZipWith' func a1 b1+-- > z2 <- tryZipWith' func a2 b2+-- > return (Node z1 z2)+-- > tryZipWith' _ _ _ = throwCError "Shape mismatch."+class Traversable k => Zippable k where++ -- | Zip the elements of two structures with the given CError computation.+ --+ -- @'tryZipWith'' func x y = either 'throwCError' (Data.Traversable.mapM (uncurry func)) ('tryZip' x y)+ tryZipWith' ::(a -> b -> CError c) -> k a -> k b -> CError (k c)+ tryZipWith' func x y = either throwCError (Data.Traversable.mapM (uncurry func)) (tryZip x y)++ -- | Zip the elements of two structures with the given function.+ -- + -- @'tryZipWith' func x y = 'cErrorToEither' ('tryZipWith'' (\a b -> return (func a b)) x y)@+ tryZipWith :: (a -> b -> c) -> k a -> k b -> Either String (k c)+ tryZipWith func x y = cErrorToEither (tryZipWith' (\a b -> return (func a b)) x y)++ -- | Zip the elements of two structures as tuples.+ --+ -- @'tryZip' = 'tryZipWith' (,)@+ tryZip :: k a -> k b -> Either String (k (a,b))+ tryZip = tryZipWith (,)+
+ MyInterpret.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE DeriveDataTypeable #-}++module MyInterpret+ ( simpleInterpret+ , simpleTypeOf+ , catchInterpreterErrors+ )+ where ++-- import Mueval.Resources+import Language.Haskell.Interpreter.GHC+import Language.Haskell.Interpreter.GHC.Unsafe++import Prelude hiding (catch)+import Control.Concurrent+import Control.Exception+import Control.Monad+import Control.Monad.Error+import System.Posix.Signals+import Data.Typeable (Typeable)+import Data.List+import Data.Either+++-- Scoped modules+modules = [ "Data.Bff",+ "SimpleTree",+ "Prelude",+ "Data.List"+-- "ShowQ",+-- "ShowFun",+-- "SimpleReflect",+-- "Data.Function",+ ]++data MyException = MyException String deriving (Typeable)++timeoutIO action = bracket+ (do mainId <- myThreadId+ installHandler sigXCPU (CatchOnce $ throwDynTo mainId $ MyException "Time limit exceeded.") Nothing+ forkIO $ do+ threadDelay (5 * 1000 * 1000)+ -- Time's up. It's a good day to die.+ throwDynTo mainId (MyException "Time limit exceeded")++ {- why do we need that here?+ - yield -- give the other thread a chance+ putStrLn "Killing main thread..."+ killThread mainId -- Die now, srsly.+ error "Time expired"+ -}+ )++ (killThread)+ + (\_ -> do+ mainId <- myThreadId+ mvar <- newEmptyMVar+ forkIO $ (action >>= putMVar mvar) `catch`+ (throwTo mainId) + ret <- takeMVar mvar+ evaluate (length ret) -- make sure exceptions are handled here+ return ret+ )++-- myInterpreter :: String -> IO String+myInterpreter todo exp = timeoutIO $ do+ when (unsafe exp) $ throwDyn (MyException "Indicators for unsafe computations found in exp")++ session <- newSession+ withSession session $ do+ setUseLanguageExtensions False+ setOptimizations All++ reset+ -- no need for temporary files I hope+ setInstalledModsAreInScopeQualified True + + unsafeSetGhcOption "-fno-monomorphism-restriction"+ + -- liftIO $ Mueval.Resources.limitResources True+ setImports modules+ + todo exp+ +formatInterpreterError (UnknownError s) = "Unknown Interpreter Error " ++ s+formatInterpreterError (WontCompile es) = "Could not compile code:\n" ++ unlines (map errMsg es)+formatInterpreterError (NotAllowed s) = "Not allowed here " ++ s+formatInterpreterError (GhcException e) = "GHC Exception"+ +{- | Return true if the String contains anywhere in it any keywords associated+ with dangerous functions. Unfortunately, this blacklist leaks like a sieve+ and will return many false positives (eg. 'unsafed "id \"unsafed\""' will+ evaluate to True, even though the phrase \"unsafe\" appears only in a String). But it+ will at least catch naive and simplistic invocations of "unsafePerformIO",+ "inlinePerformIO", and "unsafeCoerce". -}+unsafe :: String -> Bool+unsafe = \z -> any (`isInfixOf` z) unsafeNames++unsafeNames :: [String]+unsafeNames = ["unsafe", "inlinePerform", "liftIO", "Coerce", "Foreign",+ "Typeable", "Array", "IOBase", "Handle", "ByteString",+ "Editline", "GLUT", "lock", "ObjectIO", "System.Time",+ "OpenGL", "Control.Concurrent", "System.Posix",+ "throw", "Dyn", "cache", "stdin", "stdout", "stderr"]++catchInterpreterErrors :: IO a -> IO (Either String a)+catchInterpreterErrors action = + flip catchDyn (return . Left . formatInterpreterError) $+ flip catchDyn (\(MyException s) -> return (Left s)) $+ handleJust errorCalls (return . Left) $ -- bff in Bff.hs uses these+ Right `fmap` action++simpleInterpret :: String -> String -> IO String +simpleInterpret defs what = + myInterpreter eval $+ "let \n" +++ unlines (map (replicate 12 ' '++) (lines defs)) ++ + replicate 8 ' ' ++ "in " ++ what++simpleTypeOf :: String -> String -> IO String +simpleTypeOf defs what = + myInterpreter typeOf $+ "let \n" +++ unlines (map (replicate 12 ' '++) (lines defs)) ++ + replicate 8 ' ' ++ "in " ++ what
+ QuickCheck.hs view
@@ -0,0 +1,445 @@+{-# LANGUAGE TemplateHaskell #-}+-----------------------------------------------------------------------------+-- |+-- Module : QuickCheck+-- Copyright : (c) 2008 Joachim Breitner+-- +-- Maintainer : Joachim Breitner <mail@joachim-brietner.de>+-- Stability : experimental+--+-- This modules describes the properties of the various IntMaps used+-- by Janis Voigtlaender for his \"Bidirectionalization For Free\" work.+--+-- It also has a main function and can be run to verify these properties.+--+-----------------------------------------------------------------------------++module QuickCheck (+ -- * IntMap tests+ prop_Empty+ , prop_Insert+ , prop_Member+ , prop_Union+ , prop_FromAscList+ + -- * IntMapEq tests+ , prop_Injectivity_Eq+ , prop_Empty_Eq+ , prop_Insert_Eq+ , prop_Member_Eq+ , prop_Union_Good_Eq+ , prop_Union_Bad_Eq+ , prop_LookupR_Eq+ , prop_MemberR_Eq+ , prop_CheckInsert_Good_Eq+ , prop_CheckInsert_Bad1_Eq+ , prop_CheckInsert_Bad2_Eq++ -- * IntMapOrd tests+ , prop_Orderdness_Ord+ , prop_CheckInsert_Good_Ord+ , prop_CheckInsert_Bad1_Ord+ , prop_CheckInsert_Bad2_Ord+ , prop_CheckInsert_Bad3_Ord+ , prop_Union_Good_Ord + , prop_Union_Bad_Ord+ , prop_LookupR_Ord+ , prop_MemberR_Ord+ + -- * The Main method+ , main+ ) where ++import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.IntMapEq (IntMapEq(..))+import qualified Data.IntMapEq as IntMapEq+import Data.IntMapOrd (IntMapOrd(..))+import qualified Data.IntMapOrd as IntMapOrd+import Test.QuickCheck+import Test.QuickCheck.Batch+import Test.QuickCheck.Poly+import Data.List+import Control.Monad.Fix+import QuickCheckTH++-- Tests for IntMap++instance Arbitrary a => Arbitrary (IntMap a) where+ arbitrary = IntMap.fromList `fmap` arbitrary+ coarbitrary = error "coabitrary not defined for IntMap a"++-- | Looking up on an empty IntMap returns 'Nothing'+prop_Empty :: Int -> Bool+prop_Empty i =+ IntMap.lookup i IntMap.empty == (Nothing :: Maybe ALPHA)++-- | Lookup up a just inserted key returns it's new value,+-- while lookup up after inserting with a different key does+-- not change the lookup+prop_Insert :: IntMap ALPHA -> Int -> ALPHA -> Int -> Bool+prop_Insert m i a j =+ IntMap.lookup j (IntMap.insert i a m) ==+ if i == j then Just a+ else IntMap.lookup j m++-- | A key is a member exactly when 'IntMap.lookup' returns not +-- 'Nothing'+prop_Member :: IntMap ALPHA -> Int -> Bool+prop_Member m i =+ IntMap.member i m ==+ case IntMap.lookup i m of+ Just _ -> True+ Nothing -> False++-- | When lookup up a key from a union of two IntMaps, the returned value+-- comes from the first IntMap, if it exists there, otherwise from the other +-- one, if it exists there.+prop_Union :: IntMap ALPHA -> IntMap ALPHA -> Int -> Bool+prop_Union m m' i =+ asMaybe (IntMap.lookup i (IntMap.union m m')) ==+ if IntMap.member i m then IntMap.lookup i m+ else IntMap.lookup i m'++-- | Lookup up a key from a IntMap built by fromAscList is equivalent+-- to using 'Data.List.lookup' on the original list.+prop_FromAscList :: AscList ALPHA -> Int -> Bool+prop_FromAscList (AscList asc) i =+ lookup i asc == IntMap.lookup i (IntMap.fromAscList asc)++-- Tests for IntMapEq++instance (Arbitrary a, Eq a) => Arbitrary (IntMapEq a) where+ -- Here we spread out the values of the Map compared to the size,+ -- so we get some conflicts, but not too much.+ arbitrary = sized $ \n -> resize (4*n) $ do+ ints <- uniqueVector n+ as <- uniqueVector n+ -- no fromList exposed in IntMapEq+ return $ foldr (uncurry IntMapEq.insert) IntMapEq.empty (zip ints as)+ coarbitrary = error "coabitrary not defined for IntMapEq a"++-- | This is more a test of the Arbitrary instance, than of the implementation+-- itself, but also exmplains the additional invariant in IntMapEq+prop_Injectivity_Eq :: IntMapEq ALPHA -> Int -> Int -> Property+prop_Injectivity_Eq m i j = + i /= j ==>+ IntMapEq.lookup i m == Nothing ||+ IntMapEq.lookup j m == Nothing ||+ IntMapEq.lookup i m /= IntMapEq.lookup j m ++-- | Looking up on an empty IntMapEq returns 'Nothing'+prop_Empty_Eq :: Int -> Bool+prop_Empty_Eq i =+ IntMapEq.lookup i IntMapEq.empty == (Nothing :: Maybe ALPHA)++-- | Lookup up a just inserted key returns it's new value,+-- while lookup up after inserting with a different key does+-- not change the lookup.+prop_Insert_Eq :: IntMapEq ALPHA -> Int -> ALPHA -> Int -> Property+prop_Insert_Eq m i a j =+ let l = IntMapEq.toList m+ in (i,a) `elem` l || all (\(j,a') -> j /= i && a /= a') l ==>+ IntMapEq.lookup j (IntMapEq.insert i a m) ==+ if i == j then Just a+ else IntMapEq.lookup j m++-- | A key is a member exactly when 'IntMap.lookup' returns not +-- 'Nothing'+prop_Member_Eq :: IntMapEq ALPHA -> Int -> Bool+prop_Member_Eq m i =+ IntMapEq.member i m ==+ case IntMapEq.lookup i m of+ Just _ -> True+ Nothing -> False+++-- It’s actually hard to get enough samples of good unions++-- | A unions of two IntMapEq, where the Union is actually defined, behaves +-- as described in 'prop_Union'+prop_Union_Good_Eq :: IntMapEq ALPHA -> IntMapEq ALPHA -> Int -> Property+prop_Union_Good_Eq m m' i =+ not (conflicting_Eq m m') ==>+ case IntMapEq.union m m' of+ Right u -> IntMapEq.lookup i u ==+ if IntMapEq.member i m then IntMapEq.lookup i m+ else IntMapEq.lookup i m'+ Left _ -> False++-- | A unions of two IntMapEq, where the Union is not defined, becaues there are+-- conflicting values, returns an 'Left' value.+prop_Union_Bad_Eq :: IntMapEq ALPHA -> IntMapEq ALPHA -> Property+prop_Union_Bad_Eq m m' =+ conflicting_Eq m m' ==>+ case IntMapEq.union m m' of+ Left "Update violates unequality." -> True+ Right _ -> False++-- | Tests whether two IntMapsEq would conflict upon an merge, that is, whether a+-- key-value pair exists, which is not overritten by a key in the first map, but+-- whose value appears in the firt map already.+conflicting_Eq :: (Eq a) => IntMapEq a -> IntMapEq a -> Bool+conflicting_Eq m m' =+ let l = IntMapEq.toList m+ l' = IntMapEq.toList m'+ in any (\(j,a') -> any (\(_,a) -> a == a') l && all (\(i,_) -> i/=j) l) l'++-- | Lookup up a just inserted value returns it's new key,+-- while lookup up after inserting with a different value does+-- not change the lookup.+prop_LookupR_Eq :: IntMapEq ALPHA -> ALPHA -> Int -> ALPHA -> Property+prop_LookupR_Eq m a i a' =+ -- otherwise insert is not defined+ let l = IntMapEq.toList m+ in (i,a') `elem` l || all (\(j,a'') -> j /= i && a' /= a'') l ==>+ case IntMapEq.checkInsert i a' m of+ Right m' -> IntMapEq.lookupR a m' == + if a == a' then Just i+ else IntMapEq.lookupR a m+ Left _ -> False++-- | A value is a member exactly when 'IntMapEq.lookupR' returns not 'Nothing'+prop_MemberR_Eq :: IntMapEq ALPHA -> ALPHA -> Bool+prop_MemberR_Eq m a =+ IntMapEq.memberR a m ==+ case IntMapEq.lookupR a m of+ Just _ -> True+ Nothing -> False++-- | For a value where 'IntMapEq.checkInsert' is defined, this behavas +-- as in 'prop_Insert'.+prop_CheckInsert_Good_Eq :: IntMapEq ALPHA -> Int -> ALPHA -> Property+prop_CheckInsert_Good_Eq m i a =+ let l = IntMapEq.toList m+ in (i,a) `elem` l || all (\(j,a') -> j /= i && a /= a') l ==>+ case IntMapEq.checkInsert i a m of+ Right m' -> IntMapEq.lookup i m' == Just a+ Left _ -> False+ +-- | For values that violate the equality condition of updates, 'IntMapEq.checkInsert'+-- returns an error message.+prop_CheckInsert_Bad1_Eq :: IntMapEq ALPHA -> Int -> ALPHA -> Property+prop_CheckInsert_Bad1_Eq m i a =+ let l = IntMapEq.toList m+ in any (\(j,a') -> i == j && a /= a') l ==>+ case IntMapEq.checkInsert i a m of+ Right _ -> False+ Left "Update violates equality." -> True++-- | For values that violate the injectivity condition of the IntMapEq,+-- 'IntMapE.checkInsert' returns an error message.+prop_CheckInsert_Bad2_Eq :: IntMapEq ALPHA -> Int -> ALPHA -> Property+prop_CheckInsert_Bad2_Eq m i a =+ let l = IntMapEq.toList m+ in all (\(j,_) -> i /= j) l && any (\(_,a') -> a == a') l ==>+ case IntMapEq.checkInsert i a m of+ Right _ -> False+ Left "Update violates unequality." -> True++-- Tests for IntMapOrd++instance (Arbitrary a, Ord a) => Arbitrary (IntMapOrd a) where+ -- Here we spread out the values of the Map compared to the size,+ -- so we get some conflicts, but not too much.+ arbitrary = sized $ \n -> resize (2*n) $ do+ ints <- ascendingVector n+ as <- ascendingVector n+ -- no fromList exposed in IntMapOrd+ return $ IntMapOrd.fromAscPairList (zip ints as)+ coarbitrary = error "coabitrary not defined for IntMapOrd a"++-- | This is more a test of the Arbitrary instance, than of the implementation+-- itself, but also exmplains the additional invariant in IntMapOrd+prop_Orderdness_Ord :: IntMapOrd OrdALPHA -> Int -> Int -> Property+prop_Orderdness_Ord m i j = + i < j ==>+ IntMapOrd.lookup i m == Nothing ||+ IntMapOrd.lookup j m == Nothing ||+ IntMapOrd.lookup i m < IntMapOrd.lookup j m ++-- | For a value where 'IntMapOrd.checkInsert' is defined, this behavas +-- as in 'prop_Insert'.+prop_CheckInsert_Good_Ord :: IntMapOrd OrdALPHA -> Int -> OrdALPHA -> Property+prop_CheckInsert_Good_Ord m i a =+ let l = IntMapOrd.toList m+ (is, as) = unzip l+ in (i,a) `elem` l || all (\(j,a') -> j /= i && a /= a') l + && length ((filter (<i)) is) == length ((filter (<a)) as) ==>+ case IntMapOrd.checkInsert i a m of+ Right m' -> IntMapOrd.lookup i m' == Just a+ Left _ -> False++-- | For values that violate the equality condition of updates, 'IntMapOrd.checkInsert'+-- returns an error message.+prop_CheckInsert_Bad1_Ord :: IntMapOrd OrdALPHA -> Int -> OrdALPHA -> Property+prop_CheckInsert_Bad1_Ord m i a =+ let l = IntMapOrd.toList m+ in any (\(j,a') -> i == j && a /= a') l ==>+ case IntMapOrd.checkInsert i a m of+ Right _ -> False+ Left "Update violates equality." -> True++-- | For values that violate the injectivity condition of the IntMapOrd,+-- 'IntMapE.checkInsert' returns an error message.+prop_CheckInsert_Bad2_Ord :: IntMapOrd OrdALPHA -> Int -> OrdALPHA -> Property+prop_CheckInsert_Bad2_Ord m i a =+ let l = IntMapOrd.toList m+ in all (\(j,_) -> i /= j) l && any (\(_,a') -> a == a') l ==>+ case IntMapOrd.checkInsert i a m of+ Right _ -> False+ Left "Update violates unequality." -> True++-- | For values that violate the monotony condition of the IntMapOrd,+-- 'IntMapE.checkInsert' returns an error message.+prop_CheckInsert_Bad3_Ord :: IntMapOrd OrdALPHA -> Int -> OrdALPHA -> Property+prop_CheckInsert_Bad3_Ord m i a =+ let l = IntMapOrd.toList m+ (is, as) = unzip l+ in all (\(j,a') -> j /= i && a /= a') l + && length ((filter (<i)) is) /= length ((filter (<a)) as) ==>+ case IntMapOrd.checkInsert i a m of+ Right _ -> False+ Left "Update violates relative order." -> True++-- It’s actually hard to get enough samples of good unions+++-- | A unions of two IntMapOrd, where the Union is actually defined, behaves +-- as described in 'prop_Union'+prop_Union_Good_Ord :: IntMapOrd OrdALPHA -> IntMapOrd OrdALPHA -> Int -> Property+prop_Union_Good_Ord m m' i =+ not (conflicting_Ord m m') ==>+ case IntMapOrd.union m m' of+ Right u -> IntMapOrd.lookup i u ==+ if IntMapOrd.member i m then IntMapOrd.lookup i m+ else IntMapOrd.lookup i m'+ Left _ -> False++-- | A unions of two IntMapOrd, where the Union is not defined, becaues there are+-- conflicting values, returns an 'Left' value.+prop_Union_Bad_Ord :: IntMapOrd OrdALPHA -> IntMapOrd OrdALPHA -> Property+prop_Union_Bad_Ord m m' =+ conflicting_Ord m m' ==>+ case IntMapOrd.union m m' of+ Left _ -> True+ Right _ -> False++-- | Tests whether two IntMapsOrd would conflict upon an merge, that is, whether a+-- key-value pair exists, which is not overritten by a key in the first map, but+-- whose value appears in the firt map already, or when their keys and values do+-- not merge pairwise.+conflicting_Ord :: (Ord a) => IntMapOrd a -> IntMapOrd a -> Bool+conflicting_Ord m m' =+ let l = IntMapOrd.toList m+ l' = IntMapOrd.toList m'+ (is,as) = unzip l+ (is',as') = unzip $ filter (\(j,_) -> all (\(i,_) -> i /= j) l) l'+ in any (\(j,a') -> any (\(_,a) -> a == a') l && all (\(i,_) -> i/=j) l) l' ||+ badMerge (sort is) (sort as) (sort is') (sort as')+ where badMerge [] [] _ _ = False+ badMerge _ _ [] [] = False+ badMerge (a:as) (b:bs) (c:cs) (d:ds) | a == c = badMerge (a:as) (b:bs) cs ds+ | a < c = b > d || badMerge as bs (c:cs) (d:ds)+ | c < a = d > b || badMerge (a:as) (b:bs) cs ds++-- | Lookup up a just inserted value returns it's new key,+-- while lookup up after inserting with a different value does+-- not change the lookup.+prop_LookupR_Ord :: IntMapOrd OrdALPHA -> OrdALPHA -> Int -> OrdALPHA -> Property+prop_LookupR_Ord m a i a' =+ -- otherwise insert is not defined+ let l = IntMapOrd.toList m+ (is, as) = unzip l+ in (i,a') `elem` l || all (\(j,a'') -> j /= i && a' /= a'') l + && length ((filter (<i)) is) == length ((filter (<a')) as) ==>+ case IntMapOrd.checkInsert i a' m of+ Right m' -> IntMapOrd.lookupR a m' == + if a == a' then Just i+ else IntMapOrd.lookupR a m+ Left _ -> False++-- | A value is a member exactly when 'IntMapOrd.lookupR' returns not 'Nothing'+prop_MemberR_Ord :: IntMapOrd OrdALPHA -> OrdALPHA -> Bool+prop_MemberR_Ord m a =+ IntMapOrd.memberR a m ==+ case IntMapOrd.lookupR a m of+ Just _ -> True+ Nothing -> False+++-- Helpers++-- | some type signatures are genaral in the return monad. To easily fix then to +-- maybe, this helper is used.+asMaybe :: Maybe a -> Maybe a+asMaybe = id++-- | similar to Test.Quickcheck.vector, but with unique elements+uniqueVector :: (Arbitrary a, Eq a) => Int -> Gen [a]+uniqueVector 0 = return []+uniqueVector n = do tail <- uniqueVector (n-1)+ head <- searchFor (`notElem` tail) arbitrary+ return (head:tail)++-- | similar to Test.Quickcheck.vector, but with strictly ascending elements+ascendingVector :: (Arbitrary a, Ord a) => Int -> Gen [a]+ascendingVector 0 = return []+ascendingVector n = do head <- resize 0 arbitrary+ tail <- go head (n-1)+ go head n+ where go _ 0 = return []+ go l m = do head <- searchFor (> l) (resize (3*(n-m+1)) arbitrary)+ tail <- go head (m-1)+ return (head:tail)++-- | finds a value satisfiying the predicate. WARNING: May not terminate if there is no+-- such value, or the value is very unlikely to find.+searchFor :: (Monad m) => (a -> Bool) -> m a -> m a+searchFor pred gen = do x <- gen+ if pred x then return x+ else searchFor pred gen++newtype AscList a = AscList [(Int, a)] deriving (Show)++instance Arbitrary a => Arbitrary (AscList a) where+ arbitrary = do ascList <- sized $ \n -> resize (2*n) $ do + ints <- ascendingVector n+ as <- vector n+ return (zip ints as)+ return (AscList ascList)+ coarbitrary = error "coabitrary not defined for AscList a"+++main :: IO ()+main = do $( runTestGroup "IntMap"+ [ 'prop_Empty+ , 'prop_Insert+ , 'prop_Member+ , 'prop_Union+ , 'prop_FromAscList+ ] )+ $( runTestGroup "IntMapEq"+ [ 'prop_Injectivity_Eq+ , 'prop_Empty_Eq+ , 'prop_Insert_Eq+ , 'prop_Member_Eq+ , 'prop_Union_Good_Eq+ , 'prop_Union_Bad_Eq+ , 'prop_LookupR_Eq+ , 'prop_MemberR_Eq+ , 'prop_CheckInsert_Good_Eq+ , 'prop_CheckInsert_Bad1_Eq+ , 'prop_CheckInsert_Bad2_Eq+ ] )+ $( runTestGroup "IntMapOrd"+ [ 'prop_Orderdness_Ord+ , 'prop_CheckInsert_Good_Ord+ , 'prop_CheckInsert_Bad1_Ord+ , 'prop_CheckInsert_Bad2_Ord+ , 'prop_CheckInsert_Bad3_Ord+ , 'prop_Union_Good_Ord + , 'prop_Union_Bad_Ord+ , 'prop_LookupR_Ord+ , 'prop_MemberR_Ord+ ] )
+ QuickCheckTH.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE TemplateHaskell #-}++module QuickCheckTH+ ( runTestGroup+ ) where++import Language.Haskell.TH+import Test.QuickCheck++runTestGroup :: String -> [Name] -> ExpQ+runTestGroup group tests = doE $+ ( noBindS $ appE (varE 'putStrLn) (litE (stringL ("Test Group \"" ++ group ++ "\"")))+ ) : concatMap (\test ->+ [ noBindS $ appE (varE 'putStr) (litE (stringL (" * " ++ nameBase test ++ " ")))+ , noBindS $ appE (varE 'quickCheck) (varE test)+ ]+ ) tests
+ Setup.hs view
@@ -0,0 +1,5 @@+#!/usr/bin/runhaskell++import Distribution.Simple++main = defaultMainWithHooks simpleUserHooks
+ SimpleTree.hs view
@@ -0,0 +1,31 @@+{-# OPTIONS_GHC -XTemplateHaskell #-}+-----------------------------------------------------------------------------+-- |+-- Module : SimpleTree+-- +-- Maintainer : Janis Voigtlaender+-- Stability : experimental+--+-- A very simple binary Tree data structure.+-----------------------------------------------------------------------------+module SimpleTree where++import Data.Traversable+import Data.Foldable+import Data.Zippable+import Data.DeriveTH+import Data.Derive.Traversable+import Data.Derive.Zippable+import Control.Applicative++data Tree a = Leaf a | Node (Tree a) (Tree a) deriving (Show, Eq, Ord, Read)++$( derive makeTraversable ''Tree )++instance Foldable Tree where+ foldMap = foldMapDefault++instance Functor Tree where+ fmap = fmapDefault++$( derive makeZippable ''Tree )
+ Stats.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE ExistentialQuantification, PolymorphicComponents,+ TemplateHaskell+ #-}++import Test.BenchPress+import Control.Exception (evaluate)+import Data.Bff+import Control.Applicative+import Control.Monad.Writer+import Control.Monad.State+import Control.Monad.Fix+import Data.Traversable hiding (mapM, sequence)+import qualified Data.Traversable as T+import qualified Data.Foldable as F +import Data.Zippable+import Data.DeriveTH+import Data.Derive.Zippable+import Data.Derive.Traversable+import Data.Derive.Functor+import Data.List+import Prelude+import Data.Ord+import Data.Maybe+import Text.Printf+import System.IO+import List+import StatsDef++-------------------+-- Configuration --+-------------------++sizes = (\n -> [1,(n`div`200)..n])+repetitions = 10+tests_to_run =+ [ runTest test1+ , runTest test2+ , runTest test3+ , runTest test4+ ]++----------------------+-- Test definitions --+----------------------++data Test c c' a = Test+ { testName :: String+ , maxN :: Int+ , genTestCase :: Int -> c a+ , getTest :: c a -> c' a + , putTestMan :: c a -> c' a -> c a+ , putTestAuto :: c a -> c' a -> c a+ , modifyTest :: c' a -> c' a+ , scale :: Double -> Int -> Double+ }++--+-- Test 1+--++test1 = Test+ { testName = "halve, normalized"+ , maxN = 100000+ , genTestCase = \n -> [1..n]+ , getTest = halve + , putTestMan = put1+ , putTestAuto = bff halve+ , modifyTest = id+ , scale = \m s -> m / fromIntegral s+ }++halve :: [a] -> [a]+halve as = take (length as `div` 2) as++put1 :: [a] -> [a] -> [a]+put1 as as' | length as' == n+ = as' ++ drop n as+ where n = length as `div` 2 ++--+-- Test 2+--++test2 = Test+ { testName = "flatten, left-leaning trees, normalized"+ , maxN = 5000+ , genTestCase = fix (\loop n -> if n == 1+ then Leaf ()+ else Node (loop (n-1)) (Leaf ()))+ , getTest = flatten+ , putTestMan = put2+ , putTestAuto = bff flatten+ , modifyTest = id+ , scale = \m s -> m / fromIntegral s+ }++flatten :: Tree a -> [a]+flatten (Leaf a) = [a]+flatten (Node t1 t2) = flatten t1 ++ flatten t2++put2 :: Tree a -> [a] -> Tree a+put2 s v = case go s v of (t,[]) -> t+ where go (Leaf a) (b:bs) = (Leaf b,bs)+ go (Node s1 s2) bs = (Node t1 t2,ds)+ where (t1,cs) = go s1 bs+ (t2,ds) = go s2 cs++--+-- Test 3+--++test3 = Test+ { testName = "flatten, right-leaning trees, normalized"+ , maxN = 100000+ , genTestCase = fix (\loop n -> if n == 1+ then Leaf ()+ else Node (Leaf ()) (loop (n-1)))+ , getTest = flatten+ , putTestMan = put2+ , putTestAuto = bff flatten+ , modifyTest = id+ , scale = \m s -> m / fromIntegral s+ }++--+-- Test 4+--++test4 = Test+ { testName = "rmdups, all elements different, normalized"+ , maxN = 10000+ , genTestCase = \n -> [1..n]+ , getTest = rmdups+ , putTestMan = put3+ , putTestAuto = bff_Eq rmdups+ , modifyTest = id+ , scale = \m s -> m / fromIntegral s+ }++rmdups :: Eq a => [a] -> [a]+rmdups = List.nub++put3 :: Eq a => [a] -> [a] -> [a]+put3 s v | v == List.nub v && length v == length s'+ = map (fromJust . flip lookup (zip s' v)) s+ where s' = List.nub s++----------------------------------+-- Stats calculation and output --+----------------------------------++stats test putter size = (mean . fst) `fmap` benchmark repetitions+ (do let source = genTestCase test size+ view = getTest test source+ view' = modifyTest test view+ deepEvaluate (source, view')+ )+ (\_ -> return ())+ (\(source, view') -> deepEvaluate (putter test source view')+ )++deepEvaluate :: Show a => a -> IO a+deepEvaluate x = evaluate (length (show x)) >> return x++collectStats :: (Show (c a), Show (c' a)) => Test c c' a -> IO StatRunData+collectStats test = mapM (\size -> do+ putStr "."+ manual <- stats test putTestMan size+ putStr "."+ automatic <- stats test putTestAuto size+ putStr " "+ return (size, scale test manual size, scale test automatic size)+ ) (sizes (maxN test))++runTest :: (Show (c v), Show (c' v), F.Foldable c', Zippable c', Traversable c, Eq v) =>+ Test c c' v -> IO (String, StatRunData)+runTest test = do+ putStrLn $ "" + putStr $ "Test \"" ++ testName test ++ "\" "+ statData <- collectStats test+ putStrLn $ ""+ return (testName test, statData)++main = do hSetBuffering stdout NoBuffering+ putStrLn $ "Bff benchmarking program"+ putStrLn $ "(c) 2008 Joachim Breitner"+ putStrLn $ "Repeating every test " ++ show repetitions ++ " times."+ rawData <- sequence tests_to_run+ putStrLn $ "Writing data to stats.data"+ writeFile "stats.data" (show rawData)++-- Data Definition+data Tree a = Leaf a | Node (Tree a) (Tree a) deriving Show+-- Lined in, otherwise name clashes with Prelude.foldr occurs+$(derive makeFunctor ''Tree)+instance F.Foldable Tree where+ foldr f b (Leaf a1) = (f a1 . id) b+ foldr f b (Node a1 a2) = (flip (F.foldr f) a1 . (flip (F.foldr f) a2 . id)) b +$(derive makeTraversable ''Tree)+$(derive makeZippable ''Tree)
+ StatsDef.hs view
@@ -0,0 +1,5 @@+module StatsDef where++type DataPoint = (Int, Double, Double)+type StatRunData = [DataPoint]+type StatRuns = [(String, StatRunData)]
+ StatsPrint.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE ExistentialQuantification, PolymorphicComponents,+ TemplateHaskell+ #-}++import Data.List+import Text.Printf+import StatsDef++putTable statData = putStr (tabelize stringData)+ where stringData = ["size","manual (put)", "automatic (bff get)"] :+ map (\(s,m,a) -> [show s, printf "%.3f" m, printf "%.3f" a]) statData++tabelize :: [[String]] -> String+tabelize table = unlines (map padLine table)+ where colWidths = map (maximum . map length) (transpose table)+ pad w s = replicate (w - length s) ' ' ++ s+ padLine ss = intercalate "|" (zipWith pad colWidths ss)++printTest :: String -> StatRunData -> IO ()+printTest name statData = do+ putStr $ "Measurements \"" ++ name ++ "\" "+ putStrLn $ ""+ putTable statData+ putStrLn $ ""++main = do cont <- readFile "stats.data"+ mapM_ (uncurry printTest) (read cont)
+ StatsRender.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE ExistentialQuantification, PolymorphicComponents,+ TemplateHaskell+ #-}++import Graphics.Rendering.Chart+import System.IO+import Data.List+import StatsDef+++putGraph name statData filename = renderableToPDFFile r 600 400 filename+ where r = toRenderable $+ defaultLayout1+ { layout1_title = "Measurements \"" ++ name ++"\""+ , layout1_plots = [+ ("manual (put)", HA_Bottom, VA_Left,+ toPlot $ defaultPlotLines + { plot_lines_values = [manualData]+ , plot_lines_style = dashedLine 1 [4,4] (Color 0 0 0)+ }+ ),+ ("automatic (bff get)", HA_Bottom, VA_Left,+ toPlot $ defaultPlotLines + { plot_lines_values = [automaticData]+ , plot_lines_style = solidLine 1 (Color 0 0 0)+ }+ )+ ]+ , layout1_vertical_axes = + linkedAxes' (autoScaledAxis (defaultAxis {axis_title =+ "Average time per run in ms"+ }))+ , layout1_horizontal_axes = + linkedAxes' (autoScaledAxis (defaultAxis {axis_title =+ "Size of original source"+ }))+ }+ (manualData, automaticData) = unzip $ map f statData+ f (s, m, a) = (Point (fromIntegral s) m, Point (fromIntegral s) a)++printTest :: String -> StatRunData -> IO ()+printTest name statData = do+ putStr $ "Measurements \"" ++ name ++ "\" "+ let graphFileName = name ++ ".pdf"+ putStrLn $ "Writing graph to " ++ graphFileName+ putGraph name statData graphFileName++main = do cont <- readFile "stats.data"+ mapM_ (uncurry printTest) (read cont)+
+ bff-cgi.hs view
@@ -0,0 +1,289 @@+import MyInterpret+import System.Directory+import Network.CGI+import Text.XHtml+import Data.Maybe+import Data.List+import Data.ByteString.Lazy.UTF8 (fromString)++page code pageContent =+ header << (+ thetitle << "Bidirectionalization for Free! -- Demo" ++++ style ! [ thetype "text/css" ] << cdata cssStyle+ ) ++++ body << (+ thediv ! [theclass "top"] << (+ thespan ! [theclass "title"] << "Haskell" ++++ thespan ! [theclass "subtitle"] << "Bidirectionalization for Free!"+ ) ++++ maindiv << (+ p << ("This tool allows you to experiment with the "++++ "method described in the paper “" ++++ hotlink "http://wwwtcs.inf.tu-dresden.de/~voigt/popl09-2.pdf"+ << "Bidirectionalization for Free!" ++++ "” (POPL'09) by " ++++ hotlink "http://wwwtcs.inf.tu-dresden.de/~voigt/"+ << "Janis Voigtländer" ++++ "."+ )+ + ) ++++ form ! [method "POST", action "#"] << (+ maindiv << (+ p << (+ "Enter the Haskell function definitions or load an example. "++++ "You need to define " +++ tt << "source" +++ " and " ++++ tt << "get" +++ ". The code is evaluated inside a " ++++ tt << "let" +++ " block, so you can define functions by "++++ "pattern matching, but you cannot define new data types. "+++ "The type classes required by the bidirectionalization functions are defined for " +++ tt << "Maybe" ++++ ", " +++ tt << "[]" +++ ", and this simple tree type:" ++++ pre << "data Tree a = Leaf a | Node (Tree a) (Tree a)" + ) +++++ p << (+ concatHtml (map (\(name,thisCode) -> + radio "load" name+ ! (if thisCode == code then [checked] else [])+ +++ name +++ " "+ ) examples) ++++ mkSubmit True Load ++++ br ++++ textarea ! [name "code", cols "80", rows "10"] << code+ ) + + ) ++++ pageContent+ ) ++++ maindiv << (+ p << (+ "The source code of this application and the underlying library can be found " ++++ hotlink "http://hackage.haskell.org/cgi-bin/hackage-scripts/package/bff-0.1" << "here"++++ ".") ++++ p << ("© 2008 Joachim Breitner <" ++++ hotlink "mailto:mail@joachim-breitner.de" << "mail@joachim-breitner.de" ++++ ">")+ ) + )+ ++cdata s = primHtml ("<![CDATA[\n"++ s ++ "\n]]>")++maindiv = thediv ! [theclass "main"]+ +examples =+ [ ("halve", unlines+ [ "source = [1,2,3,4,5,6,7,8,9,10]"+ , ""+ , "get as = take (length as `div` 2) as"+ ])+ , ("flatten", unlines+ [ "source = Node (Leaf 'a') (Leaf 'b')" + , ""+ , "get (Leaf a) = [a]"+ , "get (Node t1 t2) = get t1 ++ get t2"+ ])+ , ("rmdups", unlines+ [ "source = \"abcbabcbaccba\""+ , ""+ , "get = List.nub"+ ])+ , ("top3", unlines+ [ "source = \"transformation\""+ , ""+ , "get = take 3 . List.sort . List.nub"+ ])+ , ("tail", unlines+ [ "source = \"abcd\""+ , ""+ , "get = tail"+ ])+ , ("sieve", unlines+ [ "source = \"abcdefg\""+ , ""+ , "get (a:b:cs) = b:get cs"+ , "get _ = []"+ ])+ , ("doubleList", unlines+ [ "source = \"a\""+ , ""+ , "get = (\\s -> s ++ s)"+ ])+ , ("tail/rmdups", unlines+ [ "source = \"abcbabcbaccba\""+ , ""+ , "rmdups = List.nub"+ , ""+ , "get = tail . rmdups"+ ])+ ]++defaultCode = fromJust (lookup "halve" examples)+ +outputErrors :: String -> Html+outputErrors s = + p << (+ strong << "An error occurred:" +++ br ++++ pre << s+ )+ +mkSubmit active what = submit (submitId what) (submitLabel what)+ ! if active then [] else [disabled]++data Run = Get | Check | Load | Bff String ++submitId Get = "get source"+submitId Check = "check"+submitId Load = "load"+submitId (Bff suffix) = "submitBff" ++ suffix++submitCode Get = Just ("get source")+submitCode Check = Nothing+submitCode Load = Nothing+submitCode (Bff suffix) = Just ("bff"++suffix++" get source view")++submitLabel Check = "Re-check types"+submitLabel Load = "Load example"+submitLabel x = fromJust (submitCode x)++main = do setCurrentDirectory "/tmp"+ runCGI (handleErrors cgiMain)++-- This function will not work in all casses, but in most.+delDefinition name code = unlines squashed+ where filtered = filter (not . defines name) (lines code)+ squash [] = []+ squash ("":_) = [""]+ squash ("\r":_) = [""]+ squash ls = ls+ squashed = concat $ map squash $ group $ filtered++addDefiniton name def code = unlines (squashed ++ pad ++ new_line)+ where squashed = lines (delDefinition name code)+ pad | last squashed == "" || last squashed == "\r" = []+ | otherwise = [""]+ new_line = [name ++ " = " ++ def]+ +defines "" (' ':_) = True+defines "" ('=':_) = True+defines "" "" = False+defines "" _ = False+defines _ "" = False+defines (i:is) (x:xs) | i == x = defines is xs+ | i /= x = False+ ++cgiMain = do+ setHeader "Content-type" "text/xml; charset=UTF-8"+ + -- the next piece of code is not to be take seious+ todo <- (fromMaybe Check . listToMaybe . catMaybes) `fmap`+ mapM (\what -> (const what `fmap`) `fmap` getInput (submitId what))+ [Get, Bff "", Bff "_Eq", Bff "_Ord", Check, Load] + + code <- fromMaybe defaultCode `fmap` getInput "code"++ (newCode, errors) <- case submitCode todo of+ Just expr -> do+ ret <- liftIO $ catchInterpreterErrors $ simpleInterpret code expr+ return $ case (ret,todo) of + (Left err, Bff _) ->+ ( delDefinition "result" code+ , Just err)+ (Left err, Get) ->+ ( delDefinition "result" $+ delDefinition "view" code+ , Just err)+ (Right dat, Bff suffix) ->+ ( addDefiniton "result" dat code+ , Nothing)+ (Right dat, Get) ->+ ( addDefiniton "view" dat $+ delDefinition "result" code+ , Nothing)+ Nothing -> case todo of+ Load -> do loadWhat <- getInput "load"+ return ( fromMaybe code $ loadWhat >>= flip lookup examples+ , Nothing)+ Check -> return (code, Nothing)++ let hasView = any (defines "view") (lines newCode)+ + mbType <- liftIO $ catchInterpreterErrors (simpleTypeOf newCode "get")+ mbTypeSrc <- liftIO $ catchInterpreterErrors (simpleTypeOf newCode "source")+ canBff <- liftIO $ either (const False) (const True) `fmap`+ catchInterpreterErrors (simpleTypeOf newCode "bff get source")+ canBffEq <- liftIO $ either (const False) (const True) `fmap`+ catchInterpreterErrors (simpleTypeOf newCode "bff_Eq get source")+ canBffOrd <- liftIO $ either (const False) (const True) `fmap`+ catchInterpreterErrors (simpleTypeOf newCode "bff_Ord get source")++ outputFPS $ fromString $ showHtml $ page newCode $+ p << typeInfo mbType mbTypeSrc canBff canBffEq canBffOrd ++++ maindiv << (+ p << (+ "You can use " +++ tt << "get source" +++ " to calculate "++++ "a view which you can then modify. If you have defined "++++ tt << "view" +++ ", then you can use the bidirectionalizer "++++ "to calculate the updated source. The result will be shown "++++ "in the code edit frame above." ) ++++ p << ( "Evaluate " ++++ mkSubmit True Get +++ " " ++++ mkSubmit (hasView && canBff) (Bff "") +++" " ++++ mkSubmit (hasView && canBffEq) (Bff "_Eq") +++" " ++++ mkSubmit (hasView && canBffOrd) (Bff "_Ord")+ ) ++++ maybe noHtml outputErrors errors+ )+ +typeInfo (Left err) _ _ _ _ = maindiv << p << (+ "Your definitions do not typecheck:" +++ br ++++ pre << err +++ br ++++ mkSubmit True Check)++typeInfo _ (Left err) _ _ _ = maindiv << p << (+ "Your definitions do not typecheck:" +++ br ++++ pre << err +++ br ++++ mkSubmit True Check)++typeInfo (Right getType) (Right sourceType) canBff canBffEq canBffOrd = maindiv << (+ p << (+ "Your definitions have the following types: " ++++ pre << ("get :: " ++ getType ++ "\n"+++ "source :: " ++ sourceType) ++++ "Therefore, an updater can be derived by " ++++ case (canBff, canBffEq, canBffOrd) of+ (True, _, _) -> + tt << "bff" +++ ", " ++++ tt << "bff_Eq" +++ ", and " ++++ tt << "bff_Ord" +++ "."+ (False, True, _) -> + tt << "bff_Eq" +++ " and " ++++ tt << "bff_Ord" +++ "."+ (False, False, True) -> + tt << "bff_Ord" +++ " only."+ (False, False, False) -> + "none of the " +++ tt << "bff" +++ " functions."+ ) ++++ p << mkSubmit True Check+ )++cssStyle = unlines + [ "body { padding:0px; margin: 0px; }"+ , "div.top { margin:0px; padding:10px; margin-bottom:20px;"+ , " background-color:#efefef;"+ , " border-bottom:1px solid black; }"+ , "span.title { font-size:xx-large; font-weight:bold; }"+ , "span.subtitle { padding-left:30px; font-size:large; }"+ , "div.main { border:1px dotted black;"+ , " padding:10px; margin:10px; }"+ , "div.submain { padding:10px; margin:11px; }"+ , "p.subtitle { font-size:large; font-weight:bold; }"+ , "input.type { font-family:monospace; }"+ , "input[type=\"submit\"] { font-family:monospace; background-color:#efefef; }"+ , "span.mono { font-family:monospace; }"+ , "pre { margin:10px; margin-left:20px; padding:10px;"+ , " border:1px solid black; }"+ , "textarea { margin:10px; margin-left:20px; padding:10px; }"+ , "p { text-align:justify; }"+ ]+
+ bff-shell.hs view
@@ -0,0 +1,24 @@+import MyInterpret+import System.Directory+import System.IO+++main = (=<<) (either putStrLn return) $ catchInterpreterErrors $ do+ setCurrentDirectory "/tmp"+ hSetBuffering stdout NoBuffering+ putStrLn "Bff demo bot"+ putStrLn "Please enter source Data (on one line):"+ putStr "source = "+ source <- getLine+ putStrLn "Please enter get Function"+ putStr "get s = "+ getter <- getLine++ putStrLn "Running \"get source\""+ simpleInterpret ("source = " ++ source ++ "\nget s = " ++ getter ) "get source" >>= putStrLn++ putStrLn "Please enter modified view"+ view <- getLine++ putStrLn "Running \"bff get source view\""+ simpleInterpret ("source = " ++ source ++ "\nget s = " ++ getter ++ "\nview = " ++ view ) "bff get source view" >>= putStrLn
+ bff.cabal view
@@ -0,0 +1,117 @@+name: bff+version: 0.1+license: PublicDomain+description:+ This is an implementation of the ideas presented in "Bidirectionalization+ for Free!" (paper at POPL'09) by Janis Voigtlaender.+ .+ It also includes an automatic deriver for the Zippable type class.+ .+ Using the cabal flag "binaries" will enable the creation of a web frontend+ to bff, in the form of a CGI program. Make sure you understand the+ security implications before allowing untrusted access to the script.+ .+ Using the cabal flag "stats" will generate programs that collect performance+ statistics about bff and print them as a table.+ .+ Using the cabal flag "render" will generate a program that renders collected+ performance statistics as PDF files.++author: Janis Voigtlaender, Joachim Breitner++maintainer: Janis Voigtlaender++category: Data+synopsis: Bidirectionalization for Free! (POPL'09)++build-type: Simple+cabal-version: >= 1.2++extra-source-files:+ QuickCheckTH.hs+ QuickCheck.hs+ testcgi.py++flag binaries+ description: Build the binaries bff-shell and bff-cgi+ default: False++flag stats+ description: Build the stats-generating and -printing programs+ default: False++flag render+ description: Build the stats-rendering program+ default: False++library+ exposed-modules:+ SimpleTree+ Data.Zippable+ Data.IntMapEq+ Data.IntMapOrd+ Data.Bff+ other-modules:+ Data.Derive.Zippable+ Data.Zippable.Definition+ build-depends:+ base, containers, mtl, template-haskell, category-extras == 0.53.5, derive == 0.1.1,+ haskell98, bimap == 0.2.3, unix+ +executable bff-shell+ main-is:+ bff-shell.hs+ other-modules:+ MyInterpret+ if flag(binaries)+ build-depends:+ base, directory, hint+ buildable: True + else+ buildable: False++executable bff-cgi+ main-is:+ bff-cgi.hs+ other-modules:+ MyInterpret+ if flag(binaries)+ build-depends:+ base, directory, xhtml, cgi, hint, utf8-string+ buildable: True + else+ buildable: False++executable bff-stats+ main-is:+ Stats.hs+ other-modules:+ StatsDef+ if flag(stats)+ buildable: True + build-depends:+ benchpress == 0.2.2.2+ else+ buildable: False++executable bff-stats-print+ main-is:+ StatsPrint.hs+ other-modules:+ StatsDef+ if flag(stats)+ buildable: True + else+ buildable: False++executable bff-stats-render+ main-is:+ StatsRender.hs+ other-modules:+ StatsDef+ if flag(render)+ buildable: True + build-depends:+ Chart == 0.8+ else+ buildable: False
+ testcgi.py view
@@ -0,0 +1,18 @@+#!/usr/bin/python++from BaseHTTPServer import HTTPServer+from CGIHTTPServer import CGIHTTPRequestHandler+import sys++class MyRequestHandler(CGIHTTPRequestHandler):+ def is_cgi(self):+ self.cgi_info = ("","")+ return True++ def translate_path(self, path):+ return sys.argv[1]+++server_address = ('', 8000)+http = HTTPServer(server_address, MyRequestHandler)+http.serve_forever()