MagicHaskeller-0.8.6.2: MagicHaskeller/Instantiate.hs
--
-- (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