diff --git a/Data/Bff.hs b/Data/Bff.hs new file mode 100644 --- /dev/null +++ b/Data/Bff.hs @@ -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') diff --git a/Data/Derive/Zippable.hs b/Data/Derive/Zippable.hs new file mode 100644 --- /dev/null +++ b/Data/Derive/Zippable.hs @@ -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!" diff --git a/Data/IntMapEq.hs b/Data/IntMapEq.hs new file mode 100644 --- /dev/null +++ b/Data/IntMapEq.hs @@ -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 diff --git a/Data/IntMapOrd.hs b/Data/IntMapOrd.hs new file mode 100644 --- /dev/null +++ b/Data/IntMapOrd.hs @@ -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 diff --git a/Data/Zippable.hs b/Data/Zippable.hs new file mode 100644 --- /dev/null +++ b/Data/Zippable.hs @@ -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 ''[]) + diff --git a/Data/Zippable/Definition.hs b/Data/Zippable/Definition.hs new file mode 100644 --- /dev/null +++ b/Data/Zippable/Definition.hs @@ -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 (,) + diff --git a/MyInterpret.hs b/MyInterpret.hs new file mode 100644 --- /dev/null +++ b/MyInterpret.hs @@ -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 diff --git a/QuickCheck.hs b/QuickCheck.hs new file mode 100644 --- /dev/null +++ b/QuickCheck.hs @@ -0,0 +1,445 @@ +{-# LANGUAGE TemplateHaskell #-} +----------------------------------------------------------------------------- +-- | +-- Module : QuickCheck +-- Copyright : (c) 2008 Joachim Breitner +-- +-- Maintainer : Joachim Breitner +-- 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 ( + 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 ( + 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 ( + 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 + ] ) diff --git a/QuickCheckTH.hs b/QuickCheckTH.hs new file mode 100644 --- /dev/null +++ b/QuickCheckTH.hs @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +#!/usr/bin/runhaskell + +import Distribution.Simple + +main = defaultMainWithHooks simpleUserHooks diff --git a/SimpleTree.hs b/SimpleTree.hs new file mode 100644 --- /dev/null +++ b/SimpleTree.hs @@ -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 ) diff --git a/Stats.hs b/Stats.hs new file mode 100644 --- /dev/null +++ b/Stats.hs @@ -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) diff --git a/StatsDef.hs b/StatsDef.hs new file mode 100644 --- /dev/null +++ b/StatsDef.hs @@ -0,0 +1,5 @@ +module StatsDef where + +type DataPoint = (Int, Double, Double) +type StatRunData = [DataPoint] +type StatRuns = [(String, StatRunData)] diff --git a/StatsPrint.hs b/StatsPrint.hs new file mode 100644 --- /dev/null +++ b/StatsPrint.hs @@ -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) diff --git a/StatsRender.hs b/StatsRender.hs new file mode 100644 --- /dev/null +++ b/StatsRender.hs @@ -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) + diff --git a/bff-cgi.hs b/bff-cgi.hs new file mode 100644 --- /dev/null +++ b/bff-cgi.hs @@ -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 ("") + +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; }" + ] + diff --git a/bff-shell.hs b/bff-shell.hs new file mode 100644 --- /dev/null +++ b/bff-shell.hs @@ -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 diff --git a/bff.cabal b/bff.cabal new file mode 100644 --- /dev/null +++ b/bff.cabal @@ -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 diff --git a/testcgi.py b/testcgi.py new file mode 100644 --- /dev/null +++ b/testcgi.py @@ -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()