dragen (empty) → 0.1.0.0

raw patch · 15 files changed

+1686/−0 lines, 15 filesdep +QuickCheckdep +basedep +containerssetup-changed

Dependencies added: QuickCheck, base, containers, dragen, extra, ghc-prim, matrix, split, template-haskell, text, transformers

Files

LICENSE +30/−0
README.md +16/−0
Setup.hs +2/−0
dragen.cabal +70/−0
src/Arbitrary.hs +200/−0
src/Countable.hs +173/−0
src/Dragen.hs +62/−0
src/Megadeth.hs +245/−0
src/Optimization.hs +122/−0
src/Prediction.hs +200/−0
src/Reification.hs +181/−0
src/TypeInfo.hs +116/−0
test/Examples.hs +190/−0
test/Main.hs +6/−0
test/TestCountable.hs +73/−0

+ LICENSE view

@@ -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.

+ README.md view

@@ -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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ dragen.cabal view

@@ -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

+ src/Arbitrary.hs view

@@ -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)

+ src/Countable.hs view

@@ -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

+ src/Dragen.hs view

@@ -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

+ src/Megadeth.hs view

@@ -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)

+ src/Optimization.hs view

@@ -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+

+ src/Prediction.hs view

@@ -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)

+ src/Reification.hs view

@@ -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

+ src/TypeInfo.hs view

@@ -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)

+ test/Examples.hs view

@@ -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)+

+ test/Main.hs view

@@ -0,0 +1,6 @@+module Main where++import Examples+import Dragen++main = putStrLn "\n\nExamples were compiled correctly!"

+ test/TestCountable.hs view

@@ -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)]