-- -- (c) Susumu Katayama -- {-# OPTIONS -fglasgow-exts -cpp #-} module MagicHaskeller.Instantiate(mkRandTrie, RTrie, -- arbitraries, uncurryDyn, uncurryTy, mkUncurry, typeToOrd, typeToRandomsOrd, typeToRandomsOrdDM, mkCurry, curryDyn , typeToArb -- exported just for testing Classification.tex ) where import MagicHaskeller.CoreLang import qualified Data.Map as Map import MagicHaskeller.MyCheck import System.Random import MagicHaskeller.Types import Control.Monad.Search.Combinatorial import Data.Array((!)) import MagicHaskeller.TyConLib import MagicHaskeller.DebMT import Data.List hiding (insert) import Control.Monad import qualified Data.IntMap as IntMap import MagicHaskeller.MyDynamic hiding (dynApp) -- import Data.Typeable import MagicHaskeller.ReadDynamic(dynI) import Data.Memo import MagicHaskeller.T10 -- import ReadTypeRep(typeToTR) import Language.Haskell.TH hiding (Type) -- import Debug.Trace trace _ e = e dynApp = dynAppErr "in MagicHaskeller.Instantiate" type Order = Maybe ([Dynamic], PackedOrd) type ExpResult = ([Dynamic],CoreExpr) mkUncurry :: TyConLib -> Dynamic mkUncurry tcl = $(dynamic [|tcl|] [| uncurry :: (a->b->c)->((,) a b)->c |]) uncurryDyn :: Dynamic -> Type -> Dynamic -> Dynamic uncurryDyn unc (_ :-> b@(_:->_)) f = dynAppErr "while uncurrying." unc (uncurryDyn unc b f) uncurryDyn _ _ x = x mkCurry :: TyConLib -> Dynamic mkCurry tcl = $(dynamic [|tcl|] [| curry :: ((,) a b -> c)-> a->b->c |]) curryDyn :: Dynamic -> Type -> Dynamic -> Dynamic curryDyn cur (_ :-> b@(_:->_)) f = dynAppErr "while currying." cur (curryDyn cur b f) curryDyn _ _ x = x {- varsInts (TA t u) = TA (varsInts t) (varsInts u) varsInts (u:->t) = varsInts u :-> varsInts t varsInts (TV -} uniqueVars (TA t u) = TA (uniqueVars t) (uniqueVars u) uniqueVars (u:->t) = uniqueVars u :-> uniqueVars t uniqueVars (TV _) = TV 0 uniqueVars tc = tc -- uniqueVars はmemoizeしない場合はやってもしょうがないし，memoizeする場合はsynergeticとそうでないのと両方でやるべきでは? -- memoizeしない場合 typeToRandomsOrd :: TyConLib -> RTrie -> Type -> Order typeToRandomsOrd tcl = ttro (\(cmap,maps,_,_,_) -> argTypeToRandoms tcl cmap maps) tcl typeToRandomsOrdDM :: [Int] -> TyConLib -> RTrie -> Type -> Maybe ([[Dynamic]], PackedOrd) typeToRandomsOrdDM nrnds tcl = ttro (\(cmap,maps,_,_,_) -> argTypeToRandomss nrnds tcl cmap maps) tcl {- -- memoizeする場合 typeToRandomsOrd :: TyConLib -> RTrie -> Type -> Order typeToRandomsOrd tcl rtrie = ttro (\(_,_,(mtrands,_)) -> lookupMT mtrands) tcl rtrie . uniqueVars typeToRandomsOrdDM :: TyConLib -> RTrie -> Type -> Maybe ([[Dynamic]], PackedOrd) typeToRandomsOrdDM tcl rtrie = ttro (\(_,_,(_,mtrands)) -> lookupMT mtrands) tcl rtrie . uniqueVars -} ttro :: (RTrie -> Type -> Maybe [a]) -> TyConLib -> RTrie -> Type -> Maybe ([a], PackedOrd) ttro attr tcl rtrie@(cmap,_,_,_,_) (a1:->rest) = let (a,r) = uncurryTy' tcl a1 rest in do cmp <- typeToCompare tcl cmap r rnds <- attr rtrie a return (rnds, cmp) ttro attr tcl (cmap, _, _, _, _) t = do cmp <- typeToCompare tcl cmap t return ([], cmp) dynToCompare :: TyConLib -> Dynamic -> (Dynamic -> Dynamic -> Ordering) dynToCompare tcl dyn d0 d1 = fromDyn tcl (dynAppErr "in dynToCompare (1)" (dynAppErr "in dynToCompare (2)" dyn d0) d1) (error "dynToCompare: type mismatch") --dynToCompare tcl dyn d0 d1 = aLittleSafeFromDyn (readType' tcl "Ordering") (dynApp (dynApp dyn d0) d1) -- 引数の型が確定しても返り値の型が確定しない場合：たとえばundefinedやerrorとか．このへんをちゃんとtake careしとかないと，むりやりIntに変換することになる．...まあいっか？ -- procUndef = Just ([], mkHV (\_ _ -> True)) -- | 'uncurryTy' converts @a->b->c->d->e->r@ into @((((a,b),c),d),e)->r@ -- Note that @Arbitrary (a,b,c,d,e)@ is not defined in @Test.QuickCheck@. uncurryTy :: TyConLib -> Type -> Type uncurryTy tcl (a:->b) = case uncurryTy' tcl a b of (c,r) -> c:->r uncurryTy _ t = t uncurryTy' :: TyConLib -> Type -> Type -> (Type,Type) uncurryTy' tcl a (b:->r) = uncurryTy' tcl (pair tcl a b) r uncurryTy' tcl a r = (a,r) pair tcl a b = (TA (TA (TC (tuple tcl 2)) a) b) {- tupleに対応するやつないし，やっぱTH.Typeに一旦変換した方がよい？ あるいは，Types.TypeでTupleを特別視するか．まあ，律速段階ではないので"(,)"みたいな感じでやってもいいけど． ただ，tclに"(,)"とかが含まれない場合は？ 単にdefaultTyConsに入れておけばいいか．ただ，Arbitraryは(,,,)までしか定義されていない． $(support [t| forall a b c. ((Int,Integer,Char), ([a], Maybe a), (Either a b, (a,b))) |]) みたいに書くとtypeToOrdやtypeToRandomsが生成されてくれると便利． まあとりあえずは限られた型だけでやってもいいけど． てゆーか，Ordな型とArbitraryな型は別なので，supportOrd, supportArbの２つを用意しておくか． てゆーか，Dynamicはどうよ？ 同じことか -} type PackedOrd = Dynamic -> Dynamic -> Ordering type Cmp a = a->a->Ordering type Maps = (ArbMap, ArbMap, StdGen, StdGen) -- used if we do not memoize type Tries = (MapType (Maybe [Dynamic]), MapType (Maybe [[Dynamic]])) -- used if we memoize type RTrie = (CmpMap, Maps, MemoMap, Tries, MapType (Dynamic,Dynamic)) mkRandTrie :: [Int] -> TyConLib -> StdGen -> RTrie mkRandTrie nrnds tcl gen = let arbtup = mkArbMap tcl coarbtup = mkCoarbMap tcl (g0,g1) = split gen maps = (arbtup, coarbtup, g0, g1) cmap = mkCmpMap tcl mmap = mkMemoMap tcl in (cmap, maps, mmap, (mkMT tcl (argTypeToRandoms tcl cmap maps), mkMT tcl (argTypeToRandomss nrnds tcl cmap maps)), (mkMT tcl (typeToMemo mmap))) argTypeToRandoms :: TyConLib -> CmpMap -> Maps -> Type -> Maybe [Dynamic] argTypeToRandoms tcl cmap (arbtup, coarbtup, gen, _) a = do arb <- typeToArb arbtup coarbtup a let arbsDyn = arbitrariesByDyn tcl arb gen case typeToCompare tcl cmap a of Nothing -> return arbsDyn Just cmp -> return $ nubByCmp cmp arbsDyn argTypeToRandomss :: [Int] -> TyConLib -> CmpMap -> Maps -> Type -> Maybe [[Dynamic]] argTypeToRandomss nrnds tcl cmap (arbtup, coarbtup, _, gen) a = do arb <- typeToArb arbtup coarbtup a let arbssDyn = arbitrariessByDyn nrnds tcl arb gen case typeToCompare tcl cmap a of Nothing -> return arbssDyn Just cmp -> return $ map (nubByCmp cmp) arbssDyn nubByCmp cmp = nubBy (\a b -> cmp a b == EQ) type MapTC a = IntMap.IntMap (IntMap.IntMap a) type CmpMap = (MapTC Dynamic, Dynamic) mkMap :: TyConLib -> [[(String,a)]] -> MapTC a mkMap tcl@(mapNameTyCon,_) mcts = IntMap.fromAscList $ zip [0..] $ map (IntMap.fromList . map (\ (name, dyn) -> (mapNameTyCon Map.! name, dyn))) mcts mkCmpMap :: TyConLib -> CmpMap mkCmpMap tcl = (mkMap tcl [mct0, mct1, mct2], cmpChar) where cmpChar = $(dynamic [|tcl|] [| compare :: Char -> Char -> Ordering |]) mct0, mct1, mct2 :: [(String,Dynamic)] mct0 = [("Int", $(dynamic [|tcl|] [| compare :: Int -> Int -> Ordering |])), ("Integer", $(dynamic [|tcl|] [| compare :: Integer -> Integer -> Ordering |])), ("Char", cmpChar), ("Bool", $(dynamic [|tcl|] [| compare :: Bool -> Bool -> Ordering |])), ("Double", $(dynamic [|tcl|] [| compare :: Double -> Double -> Ordering |])), ("Float", $(dynamic [|tcl|] [| compare :: Float -> Float -> Ordering |])), ("()", $(dynamic [|tcl|] [| compare :: () -> () -> Ordering |])), ("Ordering",$(dynamic [|tcl|] [| compare :: Ordering-> Ordering-> Ordering |]))] mct1 = [("Maybe", $(dynamic [|tcl|] [| compareMaybe :: (a -> a -> Ordering) -> Maybe a -> Maybe a -> Ordering |])), ("[]", $(dynamic [|tcl|] [| compareList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering |]))] mct2 = [("Either", $(dynamic [|tcl|] [| compareEither:: (a -> a -> Ordering) -> (b -> b -> Ordering) -> Either a b -> Either a b -> Ordering |])), ("(,)", $(dynamic [|tcl|] [| comparePair :: (a -> a -> Ordering) -> (b -> b -> Ordering) -> (a,b) -> (a,b) -> Ordering |]))] -- ("Array", unsafeToDyn (readType' tcl "Cmp a -> Cmp b -> Cmp (Array a b)") (\cmp0 cmp1 x y -> compareList (comparePair cmp0 cmp1) (assocs x) (assocs y)))] -- tto (TA (TA (TA (TC tc) t) u) v) = case (ar ! 3) !! tc of ("(,,)",_) -> packCmp (\ (x0,x1,x2) (y0,y1,y2) -> compareTup (pair tcl (pair tcl t u) v) ((x0,x1),x2) ((y0,y1),y2)) -- _ -> Nothing compareMaybe _ Nothing Nothing = EQ compareMaybe _ Nothing _ = LT compareMaybe _ _ Nothing = GT compareMaybe cmp (Just x) (Just y) = cmp x y compareList _ [] [] = EQ compareList _ [] _ = LT compareList _ _ [] = GT compareList cmp (x:xs) (y:ys) = case cmp x y of EQ -> compareList cmp xs ys c -> c compareEither cmp0 cmp1 (Left x) (Left y) = cmp0 x y compareEither cmp0 cmp1 (Left _) _ = LT compareEither cmp0 cmp1 _ (Left _) = GT compareEither cmp0 cmp1 (Right x) (Right y) = cmp1 x y comparePair cmp0 cmp1 (x0,x1) (y0,y1) = case cmp0 x0 y0 of EQ -> cmp1 x1 y1 c -> c typeToCompare :: TyConLib -> CmpMap -> Type -> Maybe (Dynamic -> Dynamic -> Ordering) typeToCompare tcl cmap ty = do cmp <- typeToOrd cmap ty return (dynToCompare tcl cmp) typeToOrd :: CmpMap -> Type -> Maybe Dynamic typeToOrd (cmpmap,cmpchar) ty = tto 0 ty where tto k (TA t u) = liftM2 dynApp (tto (k+1) t) (tto 0 u) -- Higher-order kinds break everything. tto _ (_:->_) = Nothing -- error "Functions in containers are not allowed." -- note that ty is (part of) the return type, so this means higher-order datatype is returned. tto 0 (TV _) = Just cmpchar -- same as the Char case tto _ (TV _) = Nothing -- これについては一般的なやりかたはなさそう． tto k (TC tc) = do guard (tc >= 0) imap <- IntMap.lookup k cmpmap IntMap.lookup tc imap tto _ _ = Nothing type ArbMap = (MapTC Dynamic, Dynamic, Dynamic) mkArbMap :: TyConLib -> ArbMap mkArbMap tcl@(mapNameTyCon,_) = (mkMap tcl [mct0, mct1, mct2, mct3], arbChar, -- same as the Char case $(dynamic [|tcl|] [| arbitraryFun :: (a -> Gen b -> Gen b) -> Gen b -> Gen (a->b) |]) ) where arbChar = $(dynamic [|tcl|] [| arbitraryChar :: Gen Char |]) mct0, mct1, mct2, mct3 :: [(String,Dynamic)] mct0 = [("Int", $(dynamic [|tcl|] [| arbitraryInt :: Gen Int |])), ("Char", arbChar), ("Integer", $(dynamic [|tcl|] [| arbitraryInteger :: Gen Integer |])), ("Bool", $(dynamic [|tcl|] [| arbitraryBool :: Gen Bool |])), ("Double", $(dynamic [|tcl|] [| arbitraryDouble :: Gen Double |])), ("Float", $(dynamic [|tcl|] [| arbitraryFloat :: Gen Float |])), ("()", $(dynamic [|tcl|] [| arbitraryVoid :: Gen () |])), ("Ordering",$(dynamic [|tcl|] [| arbitraryOrdering:: Gen Ordering|]))] mct1 = [("Maybe", $(dynamic [|tcl|] [| arbitraryMaybe :: Gen a -> Gen (Maybe a) |])), ("[]", $(dynamic [|tcl|] [| arbitraryList :: Gen a -> Gen [a] |]))] mct2 = [("Either", $(dynamic [|tcl|] [| arbitraryEither :: Gen a -> Gen b -> Gen (Either a b) |])), ("(,)", $(dynamic [|tcl|] [| arbitraryPair :: Gen a -> Gen b -> Gen (a, b) |]))] mct3 = [("(,,)", $(dynamic [|tcl|] [| arbitraryTriplet :: Gen a -> Gen b -> Gen c -> Gen (a,b,c) |]))] typeToArb :: ArbMap -> ArbMap -> Type -> Maybe Dynamic typeToArb arbtup@(arbmap,arbchar,arbfun) coarbtup@(coarbmap,coarbchar,coarbfun) ty = tta 0 ty where tta 0 ty@(t :-> u) = do coarb <- typeToCoarb arbtup coarbtup t arb <- tta 0 u return (-- trace ("t = "++show t++" and u = "++show u ++ " and coarb = "++show coarb) $ dynApp (dynApp arbfun coarb) arb) tta 0 (TV _) = Just arbchar -- same as the Char case tta _ (TV _) = Nothing -- これについては一般的なやりかたはなさそう． tta k (TC tc) = do guard (tc >= 0) imap <- IntMap.lookup k arbmap IntMap.lookup tc imap tta k (TA t0 t1) = do arb0 <- tta (k+1) t0 arb1 <- tta 0 t1 return (-- trace ("t0 = "++show t0++" and t1 = "++show t1) $ dynApp arb0 arb1) tta _ _ = Nothing mkCoarbMap :: TyConLib -> ArbMap mkCoarbMap tcl@(mapNameTyCon,_) = (mkMap tcl [mct0, mct1, mct2, mct3], coarbChar, -- same as the Char case $(dynamic [|tcl|] [| coarbitraryFun :: Gen a -> (b -> Gen x -> Gen x) -> (a->b) -> Gen x -> Gen x |]) ) where coarbChar = $(dynamic [|tcl|] [| coarbitraryChar :: Char -> Gen x -> Gen x |]) mct0, mct1, mct2, mct3 :: [(String,Dynamic)] mct0 = [("Int", $(dynamic [|tcl|] [| coarbitraryInt :: Int -> Gen x -> Gen x |])), ("Char", coarbChar), ("Integer", $(dynamic [|tcl|] [| coarbitraryInteger :: Integer -> Gen x -> Gen x |])), ("Bool", $(dynamic [|tcl|] [| coarbitraryBool :: Bool -> Gen x -> Gen x |])), ("Double", $(dynamic [|tcl|] [| coarbitraryDouble :: Double -> Gen x -> Gen x |])), ("Float", $(dynamic [|tcl|] [| coarbitraryFloat :: Float -> Gen x -> Gen x |])), ("()", $(dynamic [|tcl|] [| coarbitraryVoid :: () -> Gen x -> Gen x |])), ("Ordering", $(dynamic [|tcl|] [| coarbitraryOrdering :: Ordering -> Gen x -> Gen x |]))] mct1 = [("[]", $(dynamic [|tcl|] [| coarbitraryList :: (a -> Gen x -> Gen x) -> [a] -> Gen x -> Gen x |])), ("Maybe", $(dynamic [|tcl|] [| coarbitraryMaybe :: (a -> Gen x -> Gen x) -> Maybe a -> Gen x -> Gen x |]))] mct2 = [("Either", $(dynamic [|tcl|] [| coarbitraryEither :: (a -> Gen x -> Gen x) -> (b -> Gen x -> Gen x) -> Either a b -> Gen x -> Gen x |])), ("(,)", $(dynamic [|tcl|] [| coarbitraryPair :: (a -> Gen x -> Gen x) -> (b -> Gen x -> Gen x) -> (a, b) -> Gen x -> Gen x |]))] mct3 = [("(,,)", $(dynamic [|tcl|] [| coarbitraryTriplet:: (a -> Gen x -> Gen x) -> (b -> Gen x -> Gen x) -> (c -> Gen x -> Gen x) -> (a,b,c) -> Gen x -> Gen x |]))] typeToCoarb :: ArbMap -> ArbMap -> Type -> Maybe Dynamic typeToCoarb arbtup@(arbmap,arbchar,arbfun) coarbtup@(coarbmap,coarbchar,coarbfun) ty = ttc 0 ty where -- ttc :: Type -> Maybe (Coarb Dynamic) ttc 0 ty@(t :-> u) = do arb <- typeToArb arbtup coarbtup t coarb <- ttc 0 u return (dynApp (dynApp coarbfun arb) coarb) ttc 0 (TV _) = Just coarbchar -- same as the Char case ttc _ (TV _) = Nothing ttc k (TC tc) = do guard (tc >= 0) imap <- IntMap.lookup k coarbmap IntMap.lookup tc imap ttc k (TA t0 t1) = do arb0 <- ttc (k+1) t0 arb1 <- ttc 0 t1 return (-- trace ("arb0 = "++show arb0++"arb1 = "++show arb1) $ dynApp arb0 arb1) ttc _ _ = Nothing -- めんどくさいので取り合えず． type MemoMap = (IntMap.IntMap (IntMap.IntMap (Dynamic,Dynamic)), (Dynamic,Dynamic)) mkMemoMap :: TyConLib -> MemoMap mkMemoMap tcl@(mapNameTyCon,_) = (mkMap tcl [mct0, mct1, mct2, mct3], memoAppChar) where memoAppChar = ( $(dynamic [|tcl|] [| memoChar :: (Char->a) -> MapChar a |]), $(dynamic [|tcl|] [| appChar :: MapChar a -> (Char->a) |]) ) mct0, mct1, mct2, mct3 :: [(String,(Dynamic,Dynamic))] mct0 = [("Int", ($(dynamic [|tcl|] [| memoIx3 :: (Int->a) -> MapIx Int a |]), $(dynamic [|tcl|] [| appIx :: MapIx Int a -> (Int->a) |]))), ("Char", memoAppChar), ("Integer", ($(dynamic [|tcl|] [| memoInteger :: (Integer->a) -> MapInteger a |]), $(dynamic [|tcl|] [| appInteger :: MapInteger a -> (Integer->a) |]))), ("Bool", ($(dynamic [|tcl|] [| memoBool :: (Bool->a) -> MapBool a |]), $(dynamic [|tcl|] [| appBool :: MapBool a -> (Bool->a) |]))), ("Ordering",($(dynamic [|tcl|] [| memoOrdering :: (Ordering->a) -> MapOrdering a |]), $(dynamic [|tcl|] [| appOrdering :: MapOrdering a -> (Ordering->a) |]))), ("()", ($(dynamic [|tcl|] [| memoUnit :: (()->a) -> MapUnit a |]), $(dynamic [|tcl|] [| appUnit :: MapUnit a -> (()->a) |]))), ("Double", ($(dynamic [|tcl|] [| memoReal :: (Double->a) -> MapReal a |]), $(dynamic [|tcl|] [| appReal :: MapReal a -> (Double->a) |]))), ("Float", ($(dynamic [|tcl|] [| memoReal :: (Float->a) -> MapReal a |]), $(dynamic [|tcl|] [| appReal :: MapReal a -> (Float->a) |])))] mct1 = [("[]", ($(dynamicH [|tcl|] 'memoList [t| forall m b a. (forall c. (b->c) -> m c) -> ([b] -> a) -> MapList m b a |]), -- use an undefined type, because forall is not supported. (But then does this work? I don't think so....) でも，単にforallを取ってinfinite typeを許せばOKって気もする．どうよ？ $(dynamicH [|tcl|] 'appList1 [t| forall m b a. (forall c. m c -> (b->c)) -> MapList m b a -> ([b]->a) |]))), ("Maybe", ($(dynamic [|tcl|] [| memoMaybe :: ((b->a)->m a) -> (Maybe b->a) -> MapMaybe m a |]), $(dynamic [|tcl|] [| appMaybe :: (m a->(b->a)) -> MapMaybe m a -> (Maybe b -> a) |])))] mct2 = [("Either", ($(dynamic [|tcl|] [| memoEither :: ((b->a) -> m a) -> ((d->a) -> n a) -> (Either b d -> a) -> MapEither m n a |]), $(dynamic [|tcl|] [| appEither :: (m a -> (b->a)) -> (n a -> (d->a)) -> MapEither m n a -> (Either b d -> a) |]))), ("(,)", ($(dynamicH [|tcl|] 'memoPair [t| forall m n b d a. (forall e. (b->e) -> m e) -> (forall f. (d->f) -> n f) -> ((b,d) -> a) -> MapPair m n a |]), $(dynamicH [|tcl|] 'appPair [t| forall m n b d a. (forall e. m e -> (b->e)) -> (forall f. n f -> (d->f)) -> MapPair m n a -> ((b,d) -> a) |])))] mct3 = [("(,,)", ($(dynamicH [|tcl|] 'memoTriplet [t| forall l m n b c d a. (forall f. (b->f) -> l f) -> (forall e. (c->e) -> m e) -> (forall e. (d->e) -> n e) -> ((b,c,d) -> a) -> MapTriplet l m n a |]), $(dynamicH [|tcl|] 'appTriplet [t| forall l m n b c d a. (forall e. l e -> (b->e)) -> (forall e. m e -> (c->e)) -> (forall e. n e -> (d->e)) -> MapTriplet l m n a -> ((b,c,d) -> a) |])))] memoLength = 10 typeToMemo :: MemoMap -> Type -> (Dynamic,Dynamic) typeToMemo memotup@(memomap,memochar) ty = case ttc 0 ty of Nothing -> (dynI,dynI) -- メモできない場合．テストするときは取り合えず全部(dynI,dynI)にしてもいいかも． Just t -> t where ttc 0 (t:->u) = Nothing ttc 0 (TV _) = Just memochar ttc _ (TV _) = Nothing ttc k (TC tc) | tc < 0 = Nothing | otherwise = do imap <- IntMap.lookup k memomap IntMap.lookup tc imap ttc k (TA t0 t1) = do (m0,a0) <- ttc (k+1) t0 (m1,a1) <- ttc 0 t1 return (dynApp m0 m1, dynApp a0 a1) ttc _ _ = Nothing -- Test.QuickCheck.GenはRandom.StdGen限定で，それ以外のRandomGen g => gではダメみたい． -- Test.QuickCheck.generateの定義がちょっと変だと思う．usableだとは思うけど． type Arb a = StdGen -> [a] arbitrariesByDyn :: TyConLib -> Dynamic -> Arb Dynamic arbitrariesByDyn tcl arb = arbsByDyn tcl arb 0 arbsByDyn :: TyConLib -> Dynamic -> Int -> StdGen -> [Dynamic] arbsByDyn tcl arbDyn depth stdgen = zipWith (genAppDyn tcl arbDyn) [depth..] (gens stdgen) genAppDyn :: TyConLib -> Dynamic -> Int -> StdGen -> Dynamic genAppDyn tcl arbDyn size stdgen = dynApp $(dynamic [|tcl|] [| (\(Gen f) -> f size stdgen) :: Gen a -> a |] ) arbDyn {- 実際もう使われていないし．間違えてこっちを編集しちゃうので，隠す． arbitrariesBy :: Gen a -> Arb a arbitrariesBy arb = arbsBy arb 0 arbsBy :: Gen a -> Int -> StdGen -> [a] arbsBy (Gen f) n stdgen = case split stdgen of (g0,g1) -> f n g0 : arbsBy arb (n+1) g1 arbitraries :: Arbitrary a => Arb a arbitraries = arbitrariesBy arbitrary -} -- nrndsは実はsizeを決めるためにしか使われていない．得られるのはStream (Bag Dynamic)ではなくStream (Stream Dynamic) arbitrariessByDyn :: [Int] -> TyConLib -> Dynamic -> StdGen -> [[Dynamic]] arbitrariessByDyn nrnds tcl arb gen = abd nrnds tcl arb 0 gen -- abd _ _ arb depth gen = zipWith (arbsByDyn arb) [depth..] (gens gen) -- 乱数サイズを小さい値から増やしていく場合 abd nrnds tcl arb depth gen = zipWith (arbsByDyn' nrnds tcl arb) [depth..] (gens gen) -- 乱数サイズを一定にする場合 arbsByDyn' nrnds tcl arbDyn depth stdgen = map (genAppDyn tcl arbDyn size) (gens stdgen) where size = max depth (nrnds !! depth) gens gen = case split gen of (g0,g1) -> g0 : gens g1