diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Agustín Mista (c) 2018 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,16 @@ +![](img/logo.png) + +# DRAGEN - Derivation of Random Generators + +To test the tool please run: + +``` +$ stack setup +$ stack build +$ stack test +``` + +Please make sure you have `BLAS` and `LAPACK` installed in your system before compiling. + +The predictions can be confirmed averaging a large set of generated values. +See file `test/Examples.hs` for an example of this. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/dragen.cabal b/dragen.cabal new file mode 100644 --- /dev/null +++ b/dragen.cabal @@ -0,0 +1,70 @@ +cabal-version: 1.12 +name: dragen +version: 0.1.0.0 +license: BSD3 +license-file: LICENSE +copyright: 2018 Agustín Mista +maintainer: Agustín Mista +author: Agustín Mista +homepage: https://github.com/OctopiChalmers/dragen#readme +bug-reports: https://github.com/OctopiChalmers/dragen/issues +synopsis: Automatic derivation of optimized QuickCheck random generators. +description: + DRAGEN is a Template Haskell tool for automatically deriving QuickCheck generators in compile-time. The user sets a desired distribution of values, and DRAGEN will try optimize the generation parameters to satisfy it using probabilistic analyses based on multi-type branching processes. + DRAGEN is based on the following paper + Branching processes for QuickCheck generators. Agustín Mista, Alejandro Russo, John Hughes. Haskell Symposium, 2018. https://dl.acm.org/citation.cfm?doid=3242744.3242747 +category: Testing +build-type: Simple +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/OctopiChalmers/dragen + +library + exposed-modules: + Countable + Dragen + TypeInfo + Reification + Prediction + Optimization + Arbitrary + Megadeth + hs-source-dirs: src + other-modules: + Paths_dragen + default-language: Haskell2010 + build-depends: + QuickCheck >=2.11.3 && <2.12, + base >=4.7 && <5, + containers >=0.5.11.0 && <0.6, + extra >=1.6.9 && <1.7, + ghc-prim >=0.5.2.0 && <0.6, + matrix >=0.3.6.1 && <0.4, + split >=0.2.3.3 && <0.3, + template-haskell >=2.13.0.0 && <2.14, + transformers >=0.5.5.0 && <0.6 + +test-suite examples + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test/ + other-modules: + Examples + TestCountable + Paths_dragen + default-language: Haskell2010 + build-depends: + QuickCheck >=2.11.3 && <2.12, + base >=4.7 && <5, + containers >=0.5.11.0 && <0.6, + dragen -any, + extra >=1.6.9 && <1.7, + ghc-prim >=0.5.2.0 && <0.6, + matrix >=0.3.6.1 && <0.4, + split >=0.2.3.3 && <0.3, + template-haskell >=2.13.0.0 && <2.14, + text >=1.2.3.0 && <1.3, + transformers >=0.5.5.0 && <0.6 diff --git a/src/Arbitrary.hs b/src/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/src/Arbitrary.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE LambdaCase #-} + +module Arbitrary where + +import Data.Maybe +import Data.List +import Data.Map.Strict ((!)) +import qualified Data.Map.Strict as Map + +import Test.QuickCheck +import Language.Haskell.TH +import Language.Haskell.TH.Syntax as TH + +import Megadeth +import TypeInfo +import Prediction + + +customListGen :: Arbitrary t => Int -> Int -> Gen [t] +customListGen fnil fcons = sized go + where + go 0 = return [] + go n = frequency + [ (fnil, return []) + , (fcons, (:) <$> resize (n-1) arbitrary <*> go (n-1)) ] + +customMaybeGen :: Arbitrary t => Int -> Int -> Gen (Maybe t) +customMaybeGen fnothing fjust = sized go + where + go 0 = return Nothing + go n = frequency + [ (fnothing, return Nothing) + , (fjust, Just <$> resize (n-1) arbitrary) + ] + +chooseExpQ :: FreqMap -> Name -> Name -> Name -> Bool -> TH.Type -> ExpQ +chooseExpQ freqs goName nName target recursive ty + | not recursive + = [| arbitrary |] + | headOf ty == target + = [| $(varE goName) (max 0 ($(varE nName) - 1)) |] + -- For the case of lists we use a custom generator, since its Arbitrary + -- instance does not preserve generation frequencies on each iteration. + -- Dirty hack to dodge Haskell's typeclasses system. This should be + -- generalized to any type having this issue. + | headOf ty == ''[] + = let (fnil, fcons) = (freqs ! '[], freqs ! '(:)) in + [| resize (max 0 ($(varE nName) - 1)) (customListGen fnil fcons) |] + -- We need to do this hack for Maybe too. Clearly, this does not scale at + -- all and we should refactor the code making it independent of the + -- Arbitrary typeclass. + | headOf ty == ''Maybe + = let (fnothing, fjust) = (freqs ! 'Nothing, freqs ! 'Just) in + [| resize (max 0 ($(varE nName) - 1)) (customMaybeGen fnothing fjust) |] + | otherwise + = [| resize (max 0 ($(varE nName) - 1)) arbitrary |] + + +makeArbExpsQ :: FreqMap -> Name -> Name -> Name -> [ConView] -> [ExpQ] +makeArbExpsQ freqs goName nName targetName cons + = map (fmap fixAppl) + [ foldl (applyTParam rec) (conE conName) conArgs + | SimpleCon conName rec conArgs <- cons ] + where + applyTParam rec rem param = rem `infixAppE` (chooseExp rec param) + chooseExp rec = chooseExpQ freqs goName nName targetName rec + infixAppE l r = uInfixE l (varE '(<*>)) r + +frequencyExpQ :: FreqMap -> Name -> Name -> Name -> [ConView] -> ExpQ +frequencyExpQ freqs goName nName target cons + = [| frequency $(listE tuples) |] + where + tuples = map (\(f,g) -> tupE [f,g]) (zip freqExpsQ arbExpsQ) + freqExpsQ = map getFreqExpQ cons + arbExpsQ = makeArbExpsQ freqs goName nName target cons + getFreqExpQ con = maybe [|1|] (\f->[|f|]) (Map.lookup (nm con) freqs) + + +genTupleArbs :: Int -> ExpQ +genTupleArbs n = doE $ + map (\x -> bindS (varP x) (varE 'arbitrary)) vars ++ + [ noBindS $ appE (varE 'return) (tupE (map varE vars))] + where vars = take n varNames + +isMutRec :: TypeEnv -> ConView -> Bool +isMutRec env con = nm con `elem` recs + where recs = map cname (getRecursives env) + +updateMutRec :: TypeEnv -> ConView -> ConView +updateMutRec env con + | isMutRec env con = con { recursive = True } + | otherwise = con + + +deriveArbitraryInstance :: TypeEnv -> FreqMap -> Name -> Q [Dec] +deriveArbitraryInstance env freqs target = reify target >>= \case + + {- data T {...} = C1 {...} | C2 {...} | ... -} + TyConI (DataD _ _ params _ cons _) -> do + let paramExps = map varT (paramNames params) + allCons = map (updateMutRec env . simpleConView target) cons + (recCons, termCons) = partition recursive allCons + + mkGo goName nName + | length allCons == 1 + = head (makeArbExpsQ freqs goName nName target allCons) + | length recCons == length allCons + = frequencyExpQ freqs goName nName target recCons + | length termCons == 1 + = condE [| $(varE nName) == 0 |] + (head (makeArbExpsQ freqs goName nName target termCons)) + (frequencyExpQ freqs goName nName target allCons) + | otherwise + = condE [| $(varE nName) == 0 |] + (frequencyExpQ freqs goName nName target termCons) + (frequencyExpQ freqs goName nName target allCons) + + if not (null paramExps) + then + [d| + instance $(applyTo (tupleT (length paramExps)) + (map (appT (conT ''Arbitrary)) paramExps)) + => Arbitrary $(applyTo (conT target) paramExps) where + arbitrary = sized go + where + go n = $(mkGo 'go 'n) + |] + else + [d| + instance Arbitrary $(applyTo (conT target) paramExps) where + arbitrary = sized go + where + go n = $(mkGo 'go 'n) + |] + + + {- newtype T {...} = SingleCon {...} -} + TyConI (NewtypeD _ _ params _ con _) -> do + let paramExps = map varT (paramNames params) + singleCon = simpleConView target con + + if not (null paramExps) + then + [d| + instance $(applyTo (tupleT (length paramExps)) + (map (appT (conT ''Arbitrary)) paramExps)) + => Arbitrary $(applyTo (conT target) paramExps) where + arbitrary = sized go + where go n = $(head (makeArbExpsQ freqs 'go 'n target [singleCon])) + |] + else + [d| + instance Arbitrary $(applyTo (conT target) paramExps) where + arbitrary = sized go + where + go n = $(head (makeArbExpsQ freqs 'go 'n target [singleCon])) + |] + + + {- type T {...} = U {...} -} + TyConI (TySynD _ params ty) -> + case (getTy ty) of + + {- type T {...} = ({...}, {...}, ...) -} + (TupleT n) -> do + let paramExps = map varT (paramNames params) + + if not (null paramExps) + then + [d| + instance $(applyTo (tupleT (length paramExps)) + (map (appT (conT ''Arbitrary)) paramExps)) + => Arbitrary $(applyTo (conT target) paramExps) where + arbitrary = $(genTupleArbs n) + |] + else + [d| + instance Arbitrary $(applyTo (conT target) paramExps) where + arbitrary = $(genTupleArbs n) + |] + + -- This type should had been derived already, It is clearly a + -- dependency and it should be put before in the topsort. + (ConT n) -> return [] + + _ -> runIO (putStrLn ("IGNORING: " ++ show ty)) >> return [] + + + {- Int#, Bool#, ... -} + PrimTyConI {} -> return [] + + + {- Not supported yet. ([], (,), ...) -} + x -> error ("Case not defined: " ++ show x) + + +devArbitrary :: TypeEnv -> FreqMap -> Name -> Q [Dec] +devArbitrary env freqs + = megaderive (deriveArbitraryInstance env freqs) (isInsName ''Arbitrary) diff --git a/src/Countable.hs b/src/Countable.hs new file mode 100644 --- /dev/null +++ b/src/Countable.hs @@ -0,0 +1,173 @@ +{-| +Module : Countable + +This file provides a generic implementation for counting how many times a data +constructor appears in a value. We use two different type classes in order to +achieve this, called `Countable` (for types of kind *) and `Countable1` (for +types of kind (* -> *)). + +> class Countable (a :: *) where +> count :: a -> ConsMap + +> class Countable1 (f :: * -> *) where +> count1 :: f a -> ConsMap + +Let us suppose we have the following type definition: + +> data Tree = Leaf | Node Tree Tree + +if we want to count how many times each type constructor appears within a +given value of type `Tree`, we need to add the following instance +derivations: + +> deriving instance Generic Tree +> instance Countable Tree + +Then, we can count type constructors over values of type `Tree`: + +> count (Node (Node Leaf Leaf) (Node Leaf Leaf)) +> ==> fromList [("Leaf",4),("Node",3)] + +Note that, if the `Tree` data type definition is available, the `deriving +instance Generic Tree` could be avoided by including Generic at the +type definition deriving clause: + +> data Tree = Leaf | Node Tree Tree deriving Generic + +`Countable` requires every subtype of a `Countable` data type to be also +`Countable` in order to work. If we modify our `Tree` definition as + +> data GTree a = GLeaf | GNode GTree a GTree + +then is necessary to add the following instance derivations: + +> instance deriving Generic a => Generic (GTree a) +> instance (Generic a, Countable a) => Countable (GTree a) + +and the `Generic` and `Countable` derivations for whatever `a` we want to +use. For example, let `a` be `Bool` (`Bool` already has a `Generic` +instance): + +> instance Countable Bool + +then we can count type constructors on values of type `GTree Bool` + +> count (GNode (GNode GLeaf False GLeaf) True (GNode GLeaf True GLeaf)) +> ==> fromList [("False",1),("GLeaf",4),("GNode",3),("True",2)] + +but what if we are just interested in counting `GLeaf` and `GNode` +type constructors within values of type `GTree a`? Using `Countable` type +class would require to provide (or derive) proper `Generic` and `Countable` +instances for whatever type we instantiate `a` with. Fortunately, we can +define a new type class, `Countable1`, for types of kind (* -> *) that does +not count type constructors further than the outter data type. Later, we +derive a `Countable1` instance for `GTree`. + +> instance Countable1 GTree + +> count1 (GNode (GNode GLeaf 1 GLeaf) 2 (GNode GLeaf 3 GLeaf)) +> ==> fromList [("GLeaf",4),("GNode",3)] + +> count1 (GNode (GNode GLeaf "a" GLeaf) "b" (GNode GLeaf "c" GLeaf)) +> ==> fromList [("GLeaf",4),("GNode",3)] +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeOperators #-} + +module Countable where + +import GHC.Generics + +import Data.Map.Strict (Map, (!)) +import qualified Data.Map.Strict as Map + + +-- | A map that associates constructors names and the times each one appears +-- within a value. +type ConsMap = Map String Int + +class Countable (a :: *) where + count :: a -> ConsMap + + default count :: (Generic a, GCountable (Rep a)) => a -> ConsMap + count = gcount . from + + +class GCountable f where + gcount :: f a -> ConsMap + + +instance GCountable (URec a) where + gcount _ = Map.empty + +instance GCountable V1 where + gcount _ = Map.empty + +instance GCountable U1 where + gcount U1 = Map.empty + +instance Countable a => GCountable (K1 i a) where + gcount (K1 x) = count x + +instance (GCountable f, GCountable g) => GCountable (f :*: g) where + gcount (f :*: g) = Map.unionWith (+) (gcount f) (gcount g) + +instance (GCountable f, GCountable g) => GCountable (f :+: g) where + gcount (L1 x) = gcount x + gcount (R1 x) = gcount x + +instance (Constructor c, GCountable f) => GCountable (C1 c f) where + gcount cons@(M1 inner) = Map.unionWith (+) + (Map.singleton (conName cons) 1) (gcount inner) + +instance GCountable f => GCountable (D1 c f) where + gcount (M1 x) = gcount x + +instance GCountable f => GCountable (S1 c f) where + gcount (M1 x) = gcount x + +-------------------------------------------------------------------------------- + +class Countable1 (f :: * -> *) where + count1 :: f a -> ConsMap + + default count1 :: (Generic1 f, GCountable1 (Rep1 f)) => f a -> ConsMap + count1 = gcount1 . from1 + + +class GCountable1 f where + gcount1 :: f a -> ConsMap + + +instance GCountable1 V1 where + gcount1 _ = Map.empty + +instance GCountable1 U1 where + gcount1 U1 = Map.empty + +instance GCountable1 Par1 where + gcount1 (Par1 _) = Map.empty + +instance (Countable1 f) => GCountable1 (Rec1 f) where + gcount1 (Rec1 a) = count1 a + +instance (GCountable1 f, GCountable1 g) => GCountable1 (f :*: g) where + gcount1 (f :*: g) = Map.unionWith (+) (gcount1 f) (gcount1 g) + +instance (GCountable1 f, GCountable1 g) => GCountable1 (f :+: g) where + gcount1 (L1 x) = gcount1 x + gcount1 (R1 x) = gcount1 x + +instance (Constructor c, GCountable1 f) => GCountable1 (C1 c f) where + gcount1 cons@(M1 inner) = Map.unionWith (+) + (Map.singleton (conName cons) 1) (gcount1 inner) + +instance GCountable1 f => GCountable1 (D1 c f) where + gcount1 (M1 x) = gcount1 x + +instance GCountable1 f => GCountable1 (S1 c f) where + gcount1 (M1 x) = gcount1 x diff --git a/src/Dragen.hs b/src/Dragen.hs new file mode 100644 --- /dev/null +++ b/src/Dragen.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE BangPatterns #-} + +module Dragen +( dragenArbitrary +, Optimization.uniform +, Optimization.weighted +, Optimization.only +, Optimization.without +, Optimization.types +, Optimization.constructors +, Prediction.confirm +) where + +import Language.Haskell.TH + +import Reification +import TypeInfo +import Prediction +import Optimization +import Arbitrary + + +-- | Derives an Abitrary instance for the type `target`, optimizing each type +-- constructor frequency in order to minimize the output of a given cost +-- function. +dragenArbitrary :: Name -> Size -> CostFunction -> DecsQ +dragenArbitrary target size cost = do + + let putStrLnQ = runIO . putStrLn + + putStrLnQ $ "\nReifiying: " ++ show target + + targetEnv <- reifyNameEnv target + + putStrLnQ $ "\nTypes involved with " ++ show target ++ ":" + putStrLnQ $ show (map tsig targetEnv) + + let !freqMap = initMap targetEnv + !prediction = predict targetEnv size freqMap + !initCost = cost targetEnv size freqMap + + putStrLnQ $ "\nInitial frequencies map:" + putStrLnQ $ showMap freqMap + putStrLnQ $ "\nPredicted distribution for the initial frequencies map:" + putStrLnQ $ showMap prediction + + putStrLnQ $ "\nOptimizing the frequencies map:" + let !optimized = optimizeLS targetEnv size cost freqMap + !prediction' = predict targetEnv size optimized + !finalCost = cost targetEnv size optimized + + putStrLnQ $ "\n\nOptimized frequencies map:" + putStrLnQ $ showMap optimized + putStrLnQ $ "\nPredicted distribution for the optimized frequencies map:" + putStrLnQ $ showMap prediction' + + putStrLnQ $ "\nInitial cost: " ++ show initCost + putStrLnQ $ "Final cost: " ++ show finalCost + putStrLnQ $ "Optimization ratio: " ++ show (initCost / finalCost) + + putStrLnQ $ "\nDeriving optimized generator..." + devArbitrary targetEnv optimized target diff --git a/src/Megadeth.hs b/src/Megadeth.hs new file mode 100644 --- /dev/null +++ b/src/Megadeth.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} + +module Megadeth where + +import Data.List +import Control.Monad +import qualified Data.Map.Strict as M +import qualified Data.Graph as G + +import qualified Control.Monad.Trans.Class as TC +import Control.Monad.Trans.State.Lazy + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +-- TH 2.11 introduced kind type +#if MIN_VERSION_template_haskell(2,11,0) +# define TH211MBKIND _maybe_kind +#else +# define TH211MBKIND +#endif + +-- | View Pattern for Types +data ConView = SimpleCon + { nm :: Name + , recursive :: Bool + , tt :: [Type] + } deriving Show + +isRecursive :: Name -> Type -> Bool +isRecursive target (ForallT _ _ t) = isRecursive target t +isRecursive target (AppT l r) = isRecursive target l || isRecursive target r +isRecursive target (SigT t _) = isRecursive target t +isRecursive target (ConT t) = t == target +isRecursive _ _ = False + +varNames = map (mkName . ('a':) . show) [0..] + +paramNames :: [TyVarBndr] -> [Name] +paramNames = map f + where f (PlainTV n) = n + f (KindedTV n _) = n + +applyTo :: TypeQ -> [TypeQ] -> TypeQ +applyTo = foldl appT + +fixAppl :: Exp -> Exp +fixAppl (UInfixE e1@UInfixE {} op e2) = UInfixE (fixAppl e1) op e2 +fixAppl (UInfixE con op e) = UInfixE con (VarE '(<$>)) e +fixAppl e = AppE (VarE 'return) e + + +-- | Look up the first type name in a type structure. +-- This function is not complete, so it could fail and it will +-- with an error message with the case that is missing +headOf :: Type -> Name +headOf (AppT ArrowT e) = headOf e +headOf (AppT ty1 _) = headOf ty1 +headOf (SigT ty _) = headOf ty +headOf (ConT n) = n +headOf (VarT n) = n +headOf (TupleT n) = tupleTypeName n +headOf ListT = ''[] +headOf e = error ("Missing :" ++ show e) + + +-- | Check whether a type is a Primitive Type. +-- Something like Int#, Bool#, etc. +isPrim :: Info -> Bool +isPrim PrimTyConI {} = True +isPrim _ = False + + +-- | View Pattern for Constructors +simpleConView :: Name -> Con -> ConView +simpleConView tyName c = + let anyRec = any (isRecursive tyName) + proj3 (_,_,z) = z + in case c of + + NormalC n sts -> let ts = map snd sts in SimpleCon n (anyRec ts) ts +#if MIN_VERSION_template_haskell(2,11,0) + GadtC [n] sts _ -> let ts = map snd sts in SimpleCon n (anyRec ts) ts +#endif + RecC n vsts -> let ts = map proj3 vsts in SimpleCon n (anyRec ts) ts + + InfixC (_,t1) n (_,t2) -> SimpleCon n (anyRec [t1] || anyRec [t2]) [t1,t2] + + ForallC _ _ innerCon -> simpleConView tyName innerCon + + _ -> error $ "simpleConView: failed on " ++ show c + + +-- | Get the first type in a type application. +-- Maybe we should improve this one +getTy :: Type -> Type +getTy (AppT t _) = getTy t +getTy t = t + +isVarT (VarT _) = True +isVarT _ = False + +isUnit (TupleT 0) = True +isUnit _ = False + +-- | Find all simple Types that are part of another Type. +findLeafTypes :: Type -> [Type] +findLeafTypes (AppT ListT ty) = findLeafTypes ty +findLeafTypes (AppT (TupleT n) ty) = findLeafTypes ty +findLeafTypes (AppT p@(ConT _) ty) = p : findLeafTypes ty +findLeafTypes (AppT ty1 ty2) = findLeafTypes ty1 ++ findLeafTypes ty2 +findLeafTypes (VarT _) = [] +findLeafTypes (ForallT _ _ ty) = findLeafTypes ty +findLeafTypes ArrowT = [] +findLeafTypes ListT = [] +findLeafTypes StarT = [] +findLeafTypes ty = [ty] + + +type StQ s a = StateT s Q a +type Names = [Name] + +member :: Name -> StQ (M.Map Name Names) Bool +member t = do + mk <- get + return $ M.member t mk + +addDep :: Name -> Names -> StQ (M.Map Name Names) () +addDep n ns = do + mapp <- get + let newmapp = M.insert n ns mapp + put newmapp + +headOfNoVar :: Type -> [Name] +headOfNoVar (ConT n) = [n] +headOfNoVar (VarT _) = [] +headOfNoVar (SigT t _ ) = headOfNoVar t +headOfNoVar (AppT ty1 ty2) = headOfNoVar ty1 ++ headOfNoVar ty2 +headOfNoVar _ = [] + +getDeps :: Name -> (Name -> Q Bool) -> StQ (M.Map Name Names) () +getDeps t ban = do + + visited <- member t + b <- TC.lift (ban t) + + let cond = b || visited || hasArbIns t + + unless cond $ do + + TC.lift $ runIO (putStrLn ("Visiting:" ++ show t)) + tip <- TC.lift (reify t) + + case tip of + + TyConI (DataD _ _ _ TH211MBKIND cons _) -> do + + let inner = nub $ concat + [ findLeafTypes ty + | (simpleConView t -> SimpleCon _ _ tys) <- cons + , ty <- tys + , not (isVarT ty) ] + hof = map headOf (filter (not . isUnit) inner) + + addDep t hof + mapM_ getDeps' hof + + + TyConI (NewtypeD _ nm _ TH211MBKIND con _) -> do + + let (SimpleCon _ _ ts) = simpleConView nm con + inner = nub (concatMap findLeafTypes (filter (not . isVarT) ts)) + hof = map headOf (filter (not . isUnit) inner) + + addDep t hof + mapM_ getDeps' hof + + + TyConI (TySynD _ _ m) -> do + addDep t (headOfNoVar m) + mapM_ getDeps' (headOfNoVar m) + + _ -> return () + + where getDeps' = flip getDeps ban + + +tocheck :: [TyVarBndr] -> Name -> Type +tocheck bndrs nm = foldl AppT (ConT nm) ns + where ns = map VarT (paramNames bndrs) + + +hasArbIns :: Name -> Bool +hasArbIns n = let sn = show n in + isPrefixOf "GHC." sn + || isPrefixOf "Data.Text" sn + || isPrefixOf "Data.Vector" sn + || isPrefixOf "Data.ByteString" sn + || isPrefixOf "Codec.Picture.Types" sn + || isPrefixOf "Codec.Picture.Metadata.Elem" sn + || isPrefixOf "Codec.Picture.Metadata.Keys" sn +-- || isPrefixOf "Data.Time" sn + + +doPreq :: Name -> Name -> [TyVarBndr] -> Q Bool +doPreq classname n [] = fmap not (isInstance classname [ConT n]) +doPreq classname n xs = fmap not (isInstance classname [tocheck xs n]) + + +isInsName :: Name -> Name -> Q Bool +isInsName className n = do + inf <- reify n + case inf of + TyConI (DataD _ _ preq TH211MBKIND _ _) -> doPreq className n preq + TyConI (NewtypeD _ _ preq TH211MBKIND _ _) -> doPreq className n preq + TyConI (TySynD _ preq _ ) -> doPreq className n preq + d -> do + runIO $ print $ "Weird case:: " ++ show d + doPreq className n [] + + +prevDev :: Name -> (Name -> Q Bool) -> Q [Name] +prevDev t ban = do + mapp <- execStateT (getDeps t ban) M.empty + let rs = M.foldrWithKey (\ k d ds -> (k,k,d) : ds) [] mapp + let (graph, v2ter, f) = G.graphFromEdges rs + let topsorted = reverse $ G.topSort graph + return (map (\p -> (let (n,_,_) = v2ter p in n)) topsorted) + + +megaderivePrim :: (Name -> Q [Dec]) -- ^ Instance generator + -> (Name -> Q Bool) -- ^ Blacklist dependences before + -> (Name -> Q Bool) -- ^ Instance name + -> Name -> Q [Dec] +megaderivePrim inst prefil filt t = do + ts' <- prevDev t prefil + ts'' <- filterM filt ts' -- Remove already known instances + ts <- mapM inst ts'' + return $ concat ts + + +megaderive :: (Name -> Q [Dec]) -> (Name -> Q Bool) -> Name -> Q [Dec] +megaderive inst = megaderivePrim inst (const $ return False) diff --git a/src/Optimization.hs b/src/Optimization.hs new file mode 100644 --- /dev/null +++ b/src/Optimization.hs @@ -0,0 +1,122 @@ +module Optimization where + +import Data.List +import Data.Maybe +import Data.Ord +import qualified Data.Map.Strict as Map + +import Prediction +import TypeInfo + +import System.IO.Unsafe +import System.IO + +dot :: a -> a +dot x = unsafePerformIO (putStr "*" >> hFlush stdout >> return x) + +epsilon :: Double +epsilon = 0.00001 + +type CostFunction = TypeEnv -> Size -> FreqMap -> Double + +uniform :: CostFunction +uniform env size freqs = chiSquare (fromIntegral size) observed + where observed = Map.elems (predict env size freqs) + +weighted :: [(Name, Int)] -> CostFunction +weighted weights env size freqs = chiSquareVec expected observed + where + prediction = predict env size freqs + (cnames, observed) = unzip (Map.toList (Map.filterWithKey weighted prediction)) + weighted cn cp = isJust (lookup cn weights) + expected = map multWeight cnames + multWeight cn = fromIntegral (fromJust (lookup cn weights) * size) + + +whitelist :: ([Name] -> TypeEnv -> [Name]) -> [Name] -> CostFunction +whitelist f names env size freqs = chiSquareVec expected observed + where + prediction = predict env size freqs + (cnames, observed) = unzip (Map.toList prediction) + expected = map applyBan cnames + applyBan cn + | cn `elem` f names env = fromIntegral size + | otherwise = epsilon + +blacklist :: ([Name] -> TypeEnv -> [Name]) -> [Name] -> CostFunction +blacklist f names env size freqs = chiSquareVec expected observed + where + prediction = predict env size freqs + (cnames, observed) = unzip (Map.toList prediction) + expected = map applyBan cnames + applyBan cn + | cn `notElem` f names env = fromIntegral size + | otherwise = epsilon + + +types :: [Name] -> TypeEnv -> [Name] +types ts env = filter ((`elem` ts) . typeName . conType env) (consList env) + +constructors :: [Name] -> TypeEnv -> [Name] +constructors names _ = names + +only, onlyTypes :: [Name] -> CostFunction +only = whitelist constructors +onlyTypes = whitelist types + +without, withoutTypes :: [Name] -> CostFunction +without = blacklist constructors +withoutTypes = blacklist types + +-------------------------------------------------------------------------------- + +chiSquareVec :: (Floating a) => [a] -> [a] -> a +chiSquareVec expected observed + = sum (zipWith (\o e -> (o - e)^2 / e) observed expected) + +chiSquare :: (Floating a) => a -> [a] -> a +chiSquare expected observed = chiSquareVec (repeat expected) observed + + +-- +-- Local search optimization method. +-- +type Heat = Double + +optimizeLS :: TypeEnv -> Size -> CostFunction -> FreqMap -> FreqMap +optimizeLS env size cost freqs + = localSearch env size (fromIntegral size ^ 2) cost freqs [] + +localSearch :: TypeEnv -> Size -> Heat -> CostFunction + -> FreqMap -> [FreqMap] -> FreqMap +localSearch env size heat cost focus visited + | null newNeighbors = focus + | delta <= epsilon && heat == 1 = focus + | delta <= epsilon + = dot $ localSearch env size 1 cost bestNeighbor newFrontier + | otherwise + = dot $ localSearch env size newHeat cost bestNeighbor newFrontier + where + delta = focusCost - bestNeighborCost + focusCost = cost env size focus + (bestNeighbor, bestNeighborCost) = minimumBy (comparing snd) neighborsCosts + neighborsCosts = zip newNeighbors (map (cost env size) newNeighbors) + newNeighbors = neighborhood focus heat \\ (focus:visited) + + newHeat = max 1 ((heat / (1 + 0.01 * (gainRatio / fromIntegral size)))) + gainRatio = bestNeighborCost / focusCost + newFrontier = newNeighbors ++ (take (length env ^ 2)) visited + +neighborhood :: FreqMap -> Heat -> [FreqMap] +neighborhood freqs heat = map (Map.fromList . zip names) neighborFreqs + where + (names, ints) = unzip (Map.toList freqs) + neighborFreqs = concatMap neighborsAt notBuiltInFreqs + + neighborsAt i = [ updateAt i (ints!!i + floor heat) + , updateAt i (max 1 (ints!!i - floor heat)) ] + updateAt i v = take i ints ++ [v] ++ drop (i+1) ints + + notBuiltInFreqs = filter (not . builtIn) (take (length names) [0..]) + builtIn i = Map.member (names !! i) builtInFreqs + diff --git a/src/Prediction.hs b/src/Prediction.hs new file mode 100644 --- /dev/null +++ b/src/Prediction.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Prediction where + +import Data.Maybe +import Data.Either +import Data.Graph +import Data.List hiding (transpose) +import Data.Matrix hiding ((!), trace) +import Data.Map.Strict (Map, (!)) +import qualified Data.Map.Strict as Map + +import Test.QuickCheck + +import TypeInfo +import Countable + +import Debug.Trace + +type Size = Int + +-- A FreqMap is a mapping between type constructor names and Int values +-- representing the frequencies we want each one of them to occur in a random +-- generated value. This mapping is later provided to QuickCheck `frequency` in +-- order to derivate random value generators. +type FreqMap = Map Name Int + +-- Hardcoded instances distributions. This does not work very well, since even +-- if we hardcode the frequencies, the built-in instances does not reduce the +-- size of the inner generation. The solution requires to get rid of the +-- Arbitrary instances and carry arround concrete generators. +builtInFreqs :: FreqMap +builtInFreqs = Map.fromList + [ {- Bool-} ('True, 1), ('False, 1) + , {- Either -} ('Left, 1), ('Right, 1) + ] + + +initMap :: TypeEnv -> FreqMap +initMap = Map.fromList . map setInitialFreq . consList + where setInitialFreq cn + | Map.member cn builtInFreqs = (cn, builtInFreqs ! cn * 100) + | otherwise = (cn, 100) + + +-- A ProbMap is similar to a FreqMap in the sense that it represents types +-- constructor names vs. frequencies. The difference lie in the fact that for +-- every data type T = C1 .. | C2 .. | ... | Cn then it must hold that +-- pC1 + pC2 + ... + pCn = 1. +type ProbMap = Map Name Double + + +showMap :: (Show a, Show b) => Map a b -> String +showMap m = intercalate "\n" (map showElem (Map.toList m)) + where showElem e = " * " ++ show e + +filterKeys :: (Name -> Bool) -> Map Name b -> Map Name b +filterKeys f = Map.filterWithKey (const . f) + + + +normalize :: TypeEnv -> FreqMap -> ProbMap +normalize env freqMap = Map.mapWithKey freqRatio freqMap + where + freqRatio cn cfreq = fromIntegral cfreq / fromIntegral (freqSum cn) + freqSum cn = Map.foldr (+) 0 (filterKeys (isSibling env cn) freqMap) + + +normalizeTerminals :: TypeEnv -> FreqMap -> ProbMap +normalizeTerminals env freqMap = Map.mapWithKey freqRatio terminalsMap + where + terminalsMap = filterKeys (isTerminal env) freqMap + freqRatio cn cfreq = fromIntegral cfreq / fromIntegral (freqSum cn) + freqSum cn = Map.foldr (+) 0 (filterKeys (isSibling env cn) terminalsMap) + + +genGWMatrix :: TypeEnv -> ProbMap -> Matrix Double +genGWMatrix env probMap = matrix size size genElem + where + size = length env + genElem (m, n) = sum $ map multProb $ occsFromTo (env!!(m-1)) (env!!(n-1)) + multProb (cn, occs) = probMap ! cn * fromIntegral occs + occsFromTo from to = map (conOccurrences to) (tcons from) + conOccurrences to con = (cname con, occurrences (tsig to) con) + + +-- Predicts the distribution for a given type constructor frequencies map. +predict :: TypeEnv -> Size -> FreqMap -> ProbMap +predict env size freqs = prediction + where + + -- Normalize the frequencies into probabilities + allProbs = normalize env freqs + termProbs = normalizeTerminals env freqs + + -- Split the type environment into branching types and leaf types. + rootType = env !! 0 + isBranchingType t = t == rootType || any rec (tcons t) + (branchingTypes, leafTypes) = partition isBranchingType env + + -- Helpers + bct = tsig . conType branchingTypes -- branching constructor type + lct = tsig . conType leafTypes -- simple constructor type + m !$ cn = Map.findWithDefault 0 cn m -- safe lookup + + ---------------------------------------------------------------------------- + -- First we need to calculate the expectancy of the types involved at the + -- branching process, we do this by calculating the pure random generation + -- process at the first (size-1) levels, and adding the expectancy of the + -- pseudo-random generation of the last level. + ---------------------------------------------------------------------------- + branchingTypesExp = Map.unionWith (+) brFirstLevels brLastLevel + + branchingProbs = filterKeys isBranchingTypeCon allProbs + branchingTermProbs = filterKeys isBranchingTypeCon termProbs + + isBranchingTypeCon cn = cn `elem` consList branchingTypes + branchingSigs = typeSigs branchingTypes + + -- Generate the Galton-Watson matrix with the given branching probabilities. + mT = genGWMatrix branchingTypes branchingProbs + ez0 = fromList 1 (length branchingTypes) (1 : repeat 0) + + genLevel 0 = ez0 + genLevel k = ez0 * (mT^k) + + {- Branching process @ first (size-1) levels -} + brFirstLevels = Map.mapWithKey multTypeExp branchingProbs + where + multTypeExp cn cp + -- Is safe to use the geometric series simplification formula + | length branchingTypes == 1 && mT' /= 1 + = cp * ((1 - mT' ^ size) / (1 - mT')) + -- Otherwise, we need to sum every level :( + | otherwise = cp * typeExp ! bct cn + + mT' = getElem 1 1 mT + typeExp = Map.fromList $ zip branchingSigs (toList predMatrix) + predMatrix = foldr1 (+) (map genLevel [0..size-1]) + + + {- Branching process @ last level -} + brLastLevel = Map.mapWithKey sumTermExp branchingTermProbs + where + sumTermExp tn tp + = sum [ tp + * allProbs ! cname con + * fromIntegral (occurrences (bct tn) con) + * prevLvlExp ! bct (cname con) + | con <- concatMap tcons branchingTypes ] + + prevLvlExp = Map.fromList $ zip branchingSigs (toList (genLevel (size-1))) + + + ---------------------------------------------------------------------------- + -- Once we have the expectancy for every type constructor involved at the + -- branching process, we can incorporate the expectancy of the leaf types by + -- counting how many times they are generated as result of the branching + -- process. It is important to note here that a leaf type could generate + -- another leaf type, so we need to perform a topological sort in order to + -- start calculating the expectancy of the 'nearest' types to the branching + -- process ones. This way the farthest ones are not multiplied by zero. + ---------------------------------------------------------------------------- + prediction = addLeafTypesExp branchingTypesExp sortedLeafTypeCons + + addLeafTypesExp pred [] = pred + addLeafTypesExp pred (cn:cns) + = addLeafTypesExp (Map.insert cn (sumOccurrences pred cn) pred) cns + + sumOccurrences pred cn + = sum [ allProbs ! cn + * pred !$ cname con + * fromIntegral (occurrences (lct cn) con) + | con <- allCons ] + + allCons = concatMap tcons env + leafTypeCons = concatMap tcons leafTypes + + generatorsOf cn = [ cname con | con <- allCons, any (== lct cn) (cargs con) ] + + sortedLeafTypeCons = reverse (map (extractCName . gvert) (topSort graph)) + (graph, gvert) = graphFromEdges' leafTypeDeps + leafTypeDeps = map createVertex leafTypeCons + extractCName (_, cn, _) = cn + createVertex con = ((), cname con, generatorsOf (cname con)) + + + +-- Generates a bunch of samples using a given generator and prints the average +-- number of type constructors generated in a random sample of size n. The +-- _arb_ parameter needs a type annotation when the function is used with +-- _arbitraty_ in order to break the ambiguity. +-- E.g. confirm 10 (arbitrary @Tree) +confirm :: (Countable a) => Size -> Gen a -> IO () +confirm size arb = do + let samples = 100000 + values <- sequence (replicate samples (generate (resize size arb))) + let consCount = Map.unionsWith (+) (map count values) + consAvg = Map.map (\c -> fromIntegral c / fromIntegral samples) consCount + putStrLn (showMap consAvg) diff --git a/src/Reification.hs b/src/Reification.hs new file mode 100644 --- /dev/null +++ b/src/Reification.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} + +module Reification where + +import Data.List +import Control.Monad.Extra + +import Language.Haskell.TH hiding (Type, Con, prim) +import qualified Language.Haskell.TH as TH + +import Megadeth +import TypeInfo + + +-- Add some info to unsupported features error messages. +unsupported :: Show value => String -> value -> a +unsupported fun input = error $ fun ++ ": unsupported input: " ++ show input + +-- Given a type name, extracts its information and the information of the types +-- involved with it from the compiling environment. This functions performs a +-- reachability analysis, looking for mutually recursive type definitions, and +-- marks the _rec_ field of each type constructor accordingly. +-- IMPORTANT: This function should be called with non-parametric (kind ~ *) +-- type names, since we can not resolve the implicit type vars. To reify fully +-- instantiated parametric types, first define a non-parametric type synonym of +-- the target (e.g. type MaybeInt = Maybe Int), or use _reifyTypeEnv_ instead. +reifyNameEnv :: Name -> Q TypeEnv +reifyNameEnv = reifyName >=> reifyInvolvedTypes + +-- Similar to _reifyTypeEnv_, but allows us to reify parametric type +-- definitions without needing to define an ad-hoc non-parametric type synonym. +-- E.g. reifyNameEnv ''MaybeInt == reifyTypeEnv (Base ''Maybe `App` Base ''Int) +reifyTypeEnv :: Type -> Q TypeEnv +reifyTypeEnv = reifyType >=> reifyInvolvedTypes + + + +-- Given a type name, extracts its information from the compiling environment. +-- Note this function does not mark the type constructors as mutually recursive +-- if they are mutually recursive with any other type. +-- IMPORTANT: This function should be called with non-parametric (kind ~ *) +-- type names, since we can not resolve the implicit type vars. +reifyName :: Name -> Q TypeDef +reifyName name = reifyType (Base name) + + +-- Given a type, reifies the leftmost type constructor, and instantiates its +-- type vars with the types applied to the original type. +-- E.g. reifyType (Base ''Maybe `App` Base ''Int) +-- ===> +-- TypeDef { tsig = App (Base ''Maybe) (Base ''Int) +-- , tcons = [ Con { cname = 'Nothing, ... } +-- , Con { cname = 'Just, cargs = [Base ''Int], ...} ] +-- , ... } +reifyType :: Type -> Q TypeDef +reifyType this = do + + let (name, args) = unapply this + reify name >>= \case + + {- data T {...} = C1 {...} | C2 {...} | ... -} + TyConI (DataD _ _ vars _ cons _) -> do + let vars' = map extractTVar vars + binds = zip vars' args + cons' = map (extractCon binds this) cons + fields = concatMap (concatMap flatten . cargs) cons' + emptyCon = Con { cname = name, cargs = [], rec = False } + + primitive <- any isPrim <$> mapM reify fields + + if primitive + then return + TypeDef { tsig = apply name [], tcons = [emptyCon], prim = True } + else return + TypeDef { tsig = this, tcons = cons', prim = False } + + {- newtype T {...} = Con T' -} + TyConI (NewtypeD _ _ vars _ con _ ) -> do + let vars' = map extractTVar vars + binds = zip vars' args + con' = extractCon binds this con + fields = concatMap flatten (cargs con') + emptyCon = Con { cname = name, cargs = [], rec = False } + + primitive <- any isPrim <$> mapM reify fields + + if primitive + then return + TypeDef { tsig = apply name [], tcons = [emptyCon], prim = True } + else return + TypeDef { tsig = this, tcons = [con'], prim = False } + + {- type T {...} = U {...} -} + TyConI (TySynD _ vars ty) -> do + let vars' = map extractTVar vars + binds = zip vars' args + realT = instantiate binds (extractType ty) + realDef <- reifyType realT + return realDef { tsig = this } + + {- Int#, Bool#, ... -} + PrimTyConI {} -> return + TypeDef { tsig = apply name [], tcons = [], prim = True } + + {- Not supported yet. -} + x -> unsupported "reifyType" x + + +extractTVar :: TyVarBndr -> Name +extractTVar (PlainTV tv) = tv +extractTVar (KindedTV tv _) = tv + +extractCon :: [(Name, Type)] -> Type -> TH.Con -> Con +extractCon binds this (NormalC cn cas) + = Con { cname = cn, cargs = args, rec = this `elem` args } + where args = map (instantiate binds . extractType . snd) cas +extractCon binds this (InfixC lt op rt) + = Con { cname = op, cargs = args, rec = this `elem` args } + where args = map (instantiate binds . extractType . snd) [lt,rt] +extractCon binds this (RecC cn vbts) + = Con { cname = cn, cargs = args, rec = this `elem` args } + where args = map (instantiate binds . extractType . (\(_,_,x) -> x)) vbts +extractCon _ _ x = unsupported "extractCon" x + +extractType :: TH.Type -> Type +extractType (AppT t1 t2) = App (extractType t1) (extractType t2) +extractType (ConT nm) = Base nm +extractType (VarT nm) = Var nm +extractType (TupleT s) = Base (TH.tupleTypeName s) +extractType ListT = Base ''[] +extractType x = unsupported "extractType" x + +instantiate :: [(Name, Type)] -> Type -> Type +instantiate binds (Base name) = Base name +instantiate binds (App l r) = App (instantiate binds l) (instantiate binds r) +instantiate binds (Var v) = maybe (Var v) id (lookup v binds) + + + +-- Traverse a data type definition, extracting recursively every data type +-- reachable from the root data type. This function also calculates mutually +-- recursive dependencies in type constructors and updates its `rec` field +-- accordingly. +reifyInvolvedTypes :: TypeDef -> Q TypeEnv +reifyInvolvedTypes root = addMutRecLoops <$> reifyInvolvedTypes' [root] root + where + reifyInvolvedTypes' _ this | prim this = return [this] + reifyInvolvedTypes' visited this = do + let newTypes = involvedWith this \\ map tsig visited + newTypeDefs <- mapM reifyType newTypes + newReached <- mapM (reifyInvolvedTypes' (this:visited)) newTypeDefs + return (nub (this : concat newReached)) + + +-- Calculate if any type constructor is mutually recursive and update the +-- `rec` field accordingly. +addMutRecLoops :: TypeEnv -> TypeEnv +addMutRecLoops env = map (addMutRecLoop env) env + where + addMutRecLoop env this + = this { tcons = map (setIsRecursive env (tsig this)) (tcons this) } + + setIsRecursive env this con + | rec con = con + | reachableFrom env this con = con { rec = True } + | otherwise = con + + reachableFrom env this con = any (reachableFrom' env this []) (cargs con) + + reachableFrom' env this visited arg + | this `subtype` arg = True + | any (this `subtype`) argImmDefs = True + | otherwise = any (reachableFrom' env this (arg:visited)) nextArgs + where + argDef = find ((==arg) . tsig) env + argImmDefs = maybe [] involvedWith argDef + nextArgs = maybe [] (\def -> involvedWith def \\ visited) argDef + -- ToDo: look why some definitions are not in the env sometimes. + -- Just nextArgs = involvedWith argDef \\ visited diff --git a/src/TypeInfo.hs b/src/TypeInfo.hs new file mode 100644 --- /dev/null +++ b/src/TypeInfo.hs @@ -0,0 +1,116 @@ +module TypeInfo +( module Language.Haskell.TH +, module TypeInfo +) where + +import Data.List +import Data.Maybe +import Data.Function + +import qualified Language.Haskell.TH as TH +import Language.Haskell.TH (Name) + +import Debug.Trace + +-- Data types for representing Haskell data type definitions. +data TypeDef = TypeDef + { tsig :: Type -- ^ Left hand side of the type definition. + , tcons :: [Con] -- ^ Type constructors + , prim :: Bool -- ^ Is this data type primitive? (e.g. Int, Bool) + } deriving Show + +data Con = Con + { cname :: Name -- ^ Constructor name + , cargs :: [Type] -- ^ Constructor args + , rec :: Bool -- ^ Is this constructor recursive? + } deriving Show + +data Type + = Base Name -- ^ A base type name (e.g. Int, Maybe, Either) + | Var Name -- ^ A type variable (e.g. a, b) + | App Type Type -- ^ A type application (e.g. T U) + deriving (Show, Eq, Ord) + +instance Eq TypeDef where + (==) = (==) `on` tsig + +apply :: Name -> [Type] -> Type +apply name = foldl App (Base name) + +unapply :: Type -> (Name, [Type]) +unapply (Base name) = (name, []) +unapply (Var name) = (name, []) +unapply (App l r) = (name, l' ++ [r]) + where (name, l') = unapply l + +typeName :: TypeDef -> Name +typeName = fst . unapply . tsig + +typeArgs :: TypeDef -> [Type] +typeArgs = snd . unapply . tsig + +flatten :: Type -> [Name] +flatten (Base name) = [name] +flatten (Var name) = [name] +flatten (App l r) = flatten l ++ flatten r + +subtype :: Type -> Type -> Bool +subtype t t' | t == t' = True +subtype t (App l r) = subtype t l || subtype t r +subtype t t' = False + +occurrences :: Type -> Con -> Int +occurrences ts con = countSat (==ts) (cargs con) + +countSat :: (a -> Bool) -> [a] -> Int +countSat p = length . filter p + + + +type TypeEnv = [TypeDef] + +-- Extract type signatures from a type env. +typeSigs :: TypeEnv -> [Type] +typeSigs = map tsig + +-- Extract the list of type constructor names from a type env. +consList :: TypeEnv -> [Name] +consList env = nub (map cname (concatMap tcons env)) + +-- Extracts type parameters of every type constructor. +involvedWith :: TypeDef -> [Type] +involvedWith = nub . concatMap cargs . tcons + +-- Extracts a type constructor from a given type. +getCon :: Name -> TypeDef -> Con +getCon cn t = fromMaybe + (error $ "getCon: looking for " ++ show cn ++ " in " ++ show (tsig t)) + (find ((cn==) . cname) (tcons t)) + +-- Given a type constructor name, finds its associated type. +conType :: TypeEnv -> Name -> TypeDef +conType env cn = fromMaybe + (error $ "conType: " ++ show cn ++ " not found in " ++ show env) + (find (any ((cn==) . cname) . tcons) env) + +-- Given a type constructor name, returns its siblings (including itself). +getSiblings :: Name -> TypeEnv -> [Con] +getSiblings cn env = tcons (conType env cn) + +-- Is a type constructor sibling with another? +isSibling :: TypeEnv -> Name -> Name -> Bool +isSibling env = (==) `on` conType env + +-- Split constructors into recursive and terminals. +splitCons :: TypeEnv -> ([Con], [Con]) +splitCons = partition rec . concatMap tcons + +getRecursives :: TypeEnv -> [Con] +getRecursives = fst . splitCons + +getTerminals :: TypeEnv -> [Con] +getTerminals = snd . splitCons + +-- Is this constructor terminal? +isTerminal :: TypeEnv -> Name -> Bool +isTerminal env cn = cn `elem` map cname (getTerminals env) diff --git a/test/Examples.hs b/test/Examples.hs new file mode 100644 --- /dev/null +++ b/test/Examples.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances #-} + +module Examples where + +import Test.QuickCheck +import Language.Haskell.TH +import GHC.Generics + +import Countable +import Dragen + +deriving instance Generic Int +instance Countable Int +instance Countable a => Countable (Maybe a) + +-------------------------------------------------------------------------------- + +-- +-- Binary tree with three kinds of leafs +-- + +data Tree + = LeafA + | LeafB + | LeafC + | Node Tree Tree + deriving (Show, Generic) + +-- Countable generic typeclass let us count the number of each kind of +-- constructors are present within a value. We automatically derive a type +-- instance for Tree as follows: +instance Countable Tree + +-- Now we derive and optimize a random generator for Tree, defining an Arbitrary +-- Tree class instance. The predicted distribution of the derived generator is +-- shown in the derivation process as follows: + +dragenArbitrary ''Tree 10 uniform + +-- Finally, we can confirm the predicted distribution of this derived generator +-- sampling a big number of values, and averaging the number of generated +-- constructors of each kind of type constructor: +confirmTree :: IO () +confirmTree = confirm 10 (arbitrary :: Gen Tree) +-- =====> +-- * ("LeafA",5.23938) +-- * ("LeafB",5.23396) +-- * ("LeafC",5.18283) +-- * ("Node",14.65617) + +-------------------------------------------------------------------------------- + +-- +-- Mutually recursive data types +-- + +data T1 + = A + | B T1 T2 + deriving (Show, Generic) + +data T2 + = C + | D T1 + deriving (Show, Generic) + +instance Countable T1 +instance Countable T2 + +dragenArbitrary ''T1 10 uniform + +confirmT1 = confirm 10 (arbitrary :: Gen T1) +-- =====> +-- * ("A",8.63757) +-- * ("B",13.67604) +-- * ("C",6.03847) +-- * ("D",7.63757) + +-------------------------------------------------------------------------------- + +-- +-- Rose trees (mutually recursive between Rose and [] data types) with composite +-- types Maybe and Bool +-- + +data Rose + = RLeaf (Maybe Bool) + | RNode [Rose] + deriving (Show, Generic) + +instance Countable a => Countable [a] +instance Countable Rose +instance Countable Bool + +dragenArbitrary ''Rose 10 uniform + +confirmRose = confirm 10 (arbitrary :: Gen Rose) +-- =====> +-- * (":",16.61068) +-- * ("False",4.17641) +-- * ("Just",8.35818) +-- * ("Nothing",2.79404) +-- * ("RLeaf",11.15222) +-- * ("RNode",6.45846) +-- * ("True",4.18177) +-- * ("[]",6.45846) + +-------------------------------------------------------------------------------- + +-- +-- Weighted generation. +-- + +data Tree' + = Leaf + | NodeA Tree' Tree' + | NodeB Tree' Tree' + deriving (Show, Generic) + +instance Countable Tree' + +dragenArbitrary ''Tree' 10 (weighted [('NodeA, 3), ('NodeB, 1)]) + +confirmTree' = confirm 10 (arbitrary :: Gen Tree') +-- =====> +-- * ("Leaf",41.11079) +-- * ("NodeA",30.47836) +-- * ("NodeB",9.63243) + +-------------------------------------------------------------------------------- + +-- +-- Lambda expressions with weighted generation +-- + +data Expr + = Var Char + | App Expr Expr + | Lam Char Expr + deriving (Show, Generic) + +deriving instance Generic Char +instance Countable Char +instance Countable Expr + +dragenArbitrary ''Expr 10 (weighted [('Var, 3), ('Lam, 1)]) + +confirmExpr = confirm 10 (arbitrary :: Gen Expr) +-- =====> +-- * ("App",29.15031) +-- * ("C#",40.21184) (boxed char) +-- * ("Lam",10.06153) +-- * ("Var",30.15031) + +-------------------------------------------------------------------------------- + +-- +-- Lisp expressions used in the paper presentation +-- + +data Text + = Text + deriving (Show, Generic) + +data Lisp + = Symbol Text + | String Text + | Number Int + | List [Lisp] + deriving (Show, Generic) + +instance Countable Text +instance Countable Lisp + +dragenArbitrary ''Lisp 10 uniform + +confirmLisp = confirm 10 (arbitrary :: Gen Lisp) +-- =====> +-- * (GHC.Types.:,17.838586498464217) +-- * (GHC.Types.[],7.0449940565497196) +-- * (Examples.List,7.0449940565497196) +-- * (Examples.Number,5.018549975282765) +-- * (Examples.String,3.3875212333158666) +-- * (Examples.Symbol,3.3875212333158666) +-- * (Examples.Text,6.775042466631733) +-- * (GHC.Types.Int,5.018549975282765) + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Examples +import Dragen + +main = putStrLn "\n\nExamples were compiled correctly!" diff --git a/test/TestCountable.hs b/test/TestCountable.hs new file mode 100644 --- /dev/null +++ b/test/TestCountable.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} + +module TestCountable where + +import GHC.Generics +import Countable + +---------------------------------------- + +data T1 + = A + | B T1 T2 + deriving (Show, Generic) + +data T2 + = C + | D T1 + deriving (Show, Generic) + +instance Countable T1 +instance Countable T2 + +countT1T2 = count (B (B (B A (D (B A C))) (D A)) (D A)) +-- ==> fromList [("A",4),("B",4),("C",1),("D",3)] + +---------------------------------------- + +data List + = Nil + | Cons () List + deriving (Show, Generic) + +instance Countable List +instance Countable () + +countList = count (Cons () (Cons () Nil)) +-- ==> fromList [("()",2),("Cons",2),("Nil",1)] + +---------------------------------------- + +data Tree + = Leaf + | Node Tree Tree + deriving (Show, Generic) + +instance Countable Tree + +countTree = count (Node (Node Leaf Leaf) (Node Leaf Leaf)) +-- ==> fromList [("Leaf",4),("Node",3)] + +---------------------------------------- + +data GTree a + = GLeaf + | GNode (GTree a) a (GTree a) + deriving (Show, Generic1) + +deriving instance (Generic a) => Generic (GTree a) +instance (Generic a, Countable a) => Countable (GTree a) + +instance Countable Bool + +countGTree = count (GNode (GNode GLeaf True GLeaf) False (GNode GLeaf True GLeaf)) +-- ==> fromList [("False",1),("GLeaf",4),("GNode",3),("True",2)] + +instance Countable1 GTree + +count1GTreeInt = count1 (GNode (GNode GLeaf 1 GLeaf) 2 (GNode GLeaf 3 GLeaf)) +-- ==> fromList [("GLeaf",4),("GNode",3)] + +count1GTreeBool = count (GNode (GNode GLeaf True GLeaf) False (GNode GLeaf True GLeaf)) +-- ==> fromList [("GLeaf",4),("GNode",3)]