-- -- (c) Susumu Katayama -- {-# LANGUAGE TemplateHaskell, RankNTypes, CPP, PatternGuards, ImpredicativeTypes #-} module MagicHaskeller.Instantiate(mkRandTrie, RTrie, -- arbitraries, uncurryDyn, uncurryTy, mkUncurry, typeToOrd, typeToRandomsOrd, typeToRandomsOrdDM, mkCurry, curryDyn, argTypeToRandoms , typeToArb -- exported just for testing Classification.tex , PackedOrd, typeToCompare, compareRealFloat ) where import MagicHaskeller.CoreLang import qualified Data.Map as Map import MagicHaskeller.MyCheck #ifdef TFRANDOM import System.Random.TF.Gen #else import System.Random #endif 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 Data.Ratio import MagicHaskeller.FastRatio 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 MagicHaskeller.NearEq(NearEq(..)) -- 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 #ifdef TFRANDOM type Generator = TFGen #else type Generator = StdGen #endif type Maps = (ArbMap, CoarbMap, Generator, Generator) -- 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 -> Generator -> 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 return $ arbitrariesByDyn tcl arb gen 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 . take 20) arbssDyn nubByCmp cmp = nubBy (\a b -> cmp a b == EQ) -- nubByCmpは同じ乱数が入らないようにする働きがある．ただし，Boolなどのように本質的に2種類しかないものに対してnubByCmpして乱数を5つ取ろうとすると無限ループに入ってしまうので，それを避けるためにtake 20を入れている． -- argTypeToRandomsでもそれをしようとすると結構ややこしいことになるので，そっちではnubByCmpしないことにする．2012/5/29のnewnotes参照． -- てゆーか，argTypeToRandomssだけで全部やればいいんだけど． type MapTC a = IntMap.IntMap (IntMap.IntMap a) type CmpMap = (MapTC Dynamic, SpecialMap, Dynamic) mkMap :: TyConLib -> [[(String,a)]] -> MapTC a mkMap tcl@(mapNameTyCon,_) mcts = IntMap.fromAscList $ zip [0..] $ map (IntMap.fromList . map (\ (name, dyn) -> (fromIntegral (mapNameTyCon Map.! name), dyn))) mcts mkCmpMap :: TyConLib -> CmpMap mkCmpMap tcl = (mkMap tcl [mct0, mct1, mct2], mkSpecialMap tcl [("Ratio", "Int", $(dynamic [|tcl|] [| compareRatio :: Ratio Int -> Ratio Int -> Ordering |])), ("Ratio", "Integer", $(dynamic [|tcl|] [| compareRatio :: Ratio Integer -> Ratio Integer -> Ordering |]))], 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|] [| compareRealFloat :: Double -> Double -> Ordering |])), ("Float", $(dynamic [|tcl|] [| compareRealFloat :: 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 compareRatio :: Integral i => Ratio i -> Ratio i -> Ordering compareRatio x y = case (denominator x, denominator y) of (0,0) -> EQ -- Because the comparison is just for removing duplicates efficiently, (0,_) -> LT -- notANumber should be a normal element here. (_,0) -> GT _ -> compare (numerator x * denominator y) (numerator y * denominator x) compareRealFloat :: (NearEq a, RealFloat a) => a->a->Ordering compareRealFloat x y = case (isNaN x, isNaN y) of -- Because the comparison is just for removing duplicates efficiently, (True, True) -> EQ -- NaN should be a normal element here. (True, False) -> LT (False,True) -> GT (False,False) -> if x~=y then EQ else compare 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,spmap,cmpchar) ty = tto 0 ty where tto 0 (TA (TC tc1) (TC tc2)) | Just dyn <- IntMap.lookup (combineTCs tc1 tc2) spmap = return dyn 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 (fromIntegral tc) imap tto _ _ = Nothing type ArbMap = (MapTC Dynamic, SpecialMap, Dynamic, Dynamic) type CoarbMap = (MapTC Dynamic, SpecialMap, Dynamic, Dynamic) mkArbMap :: TyConLib -> ArbMap mkArbMap tcl@(mapNameTyCon,_) = (mkMap tcl [mct0, mct1, mct2, mct3], mkSpecialMap tcl [("Ratio", "Int", $(dynamic [|tcl|] [| arbitraryRatio :: Gen (Ratio Int) |])), ("Ratio", "Integer", $(dynamic [|tcl|] [| arbitraryRatio :: Gen (Ratio Integer) |]))], 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|] [| arbitraryUnit :: 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) |]))] -- ArbMap specialized for Ratio Int, etc. -- This is necessary because we cannot have something like arbitraryRatio :: Gen a -> Gen (Ratio a) (without type constraint), -- in order to avoid zero-denominator cases. type SpecialMap = IntMap.IntMap Dynamic mkSpecialMap :: TyConLib -> [(String,String,Dynamic)] -> IntMap.IntMap Dynamic mkSpecialMap tcl@(mapNameTyCon,_) = IntMap.fromList . map (\ (name1, name2, dyn) -> (combineTCs (mapNameTyCon Map.! name1) (mapNameTyCon Map.! name2), dyn)) {- こっちにすべき --------------------------------------- -- This signature silently makes sure that TyCon == Int8. This should cause an error when TyCon /= Int8. combineTCs :: Int8 -> Int8 -> Int combineTCs tc1 tc2 = fromIntegral tc1 * 256 + fromIntegral tc2 -} -- debug目的でこっちにしている。--------------------------------- combineTCs :: TyCon -> TyCon -> Int combineTCs tc1 tc2 = fromIntegral tc1 * 256 + fromIntegral tc2 typeToArb :: ArbMap -> CoarbMap -> Type -> Maybe Dynamic typeToArb arbtup@(arbmap, spmap, 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 (fromIntegral tc) imap tta 0 (TA (TC tc1) (TC tc2)) | Just dyn <- IntMap.lookup (combineTCs tc1 tc2) spmap = return dyn 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 -> CoarbMap mkCoarbMap tcl@(mapNameTyCon,_) = (mkMap tcl [mct0, mct1, mct2, mct3], mkSpecialMap tcl [("Ratio", "Int", $(dynamic [|tcl|] [| coarbitraryRatio :: Ratio Int -> Gen x -> Gen x |])), ("Ratio", "Integer", $(dynamic [|tcl|] [| coarbitraryRatio :: Ratio Integer -> Gen x -> Gen x |]))], 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|] [| coarbitraryUnit :: () -> 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 -> CoarbMap -> Type -> Maybe Dynamic typeToCoarb arbtup@(arbmap,_,arbchar,arbfun) coarbtup@(coarbmap,spmap,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 (fromIntegral tc) imap ttc 0 (TA (TC tc1) (TC tc2)) | Just dyn <- IntMap.lookup (combineTCs tc1 tc2) spmap = return dyn 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 (fromIntegral 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 = Generator -> [a] arbitrariesByDyn :: TyConLib -> Dynamic -> Arb Dynamic arbitrariesByDyn tcl arb = arbsByDyn tcl arb 0 arbsByDyn :: TyConLib -> Dynamic -> Int -> Generator -> [Dynamic] arbsByDyn tcl arbDyn depth stdgen = zipWith (genAppDyn tcl arbDyn) [depth..] (gens stdgen) genAppDyn :: TyConLib -> Dynamic -> Int -> Generator -> 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 -> Generator -> [[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) #ifdef TFRANDOM gens gen = case map (splitn gen 8) [0..255] of g0:gs -> gs ++ gens g0 #else gens gen = case split gen of (g0,g1) -> g0 : gens g1 #endif