-- 
-- (c) Susumu Katayama
--
{-# LANGUAGE TemplateHaskell, RankNTypes, CPP, PatternGuards, ImpredicativeTypes #-}
module MagicHaskeller.Instantiate(mkRandTrie, mkRandTrieExt, 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 :: p -> p -> p
trace p
_ p
e = p
e

dynApp :: Dynamic -> Dynamic -> Dynamic
dynApp = String -> Dynamic -> Dynamic -> Dynamic
dynAppErr String
"in MagicHaskeller.Instantiate"

type Order = Maybe ([Dynamic], PackedOrd)

type ExpResult = ([Dynamic],CoreExpr)
mkUncurry :: TyConLib -> Dynamic
mkUncurry :: TyConLib -> Dynamic
mkUncurry TyConLib
tcl =
                $(dynamic [|tcl|] [| uncurry :: (a->b->c)->((,) a b)->c |])

uncurryDyn :: Dynamic -> Type -> Dynamic -> Dynamic
uncurryDyn :: Dynamic -> Type -> Dynamic -> Dynamic
uncurryDyn Dynamic
unc (Type
_ :-> b :: Type
b@(Type
_:->Type
_)) Dynamic
f = String -> Dynamic -> Dynamic -> Dynamic
dynAppErr String
"while uncurrying." Dynamic
unc (Dynamic -> Type -> Dynamic -> Dynamic
uncurryDyn Dynamic
unc Type
b Dynamic
f)
uncurryDyn Dynamic
_   Type
_                 Dynamic
x = Dynamic
x

mkCurry :: TyConLib -> Dynamic
mkCurry :: TyConLib -> Dynamic
mkCurry TyConLib
tcl =
                $(dynamic [|tcl|] [| curry :: ((,) a b -> c)-> a->b->c |])

curryDyn :: Dynamic -> Type -> Dynamic -> Dynamic
curryDyn :: Dynamic -> Type -> Dynamic -> Dynamic
curryDyn Dynamic
cur (Type
_ :-> b :: Type
b@(Type
_:->Type
_)) Dynamic
f = String -> Dynamic -> Dynamic -> Dynamic
dynAppErr String
"while currying." Dynamic
cur (Dynamic -> Type -> Dynamic -> Dynamic
curryDyn Dynamic
cur Type
b Dynamic
f)
curryDyn Dynamic
_   Type
_                 Dynamic
x = Dynamic
x

{-
varsInts (TA t u) = TA (varsInts t) (varsInts u)
varsInts (u:->t)  = varsInts u :-> varsInts t
varsInts (TV 
-}
uniqueVars :: Type -> Type
uniqueVars (TA Type
t Type
u) = Type -> Type -> Type
TA (Type -> Type
uniqueVars Type
t) (Type -> Type
uniqueVars Type
u)
uniqueVars (Type
u:->Type
t)  = Type -> Type
uniqueVars Type
u Type -> Type -> Type
:-> Type -> Type
uniqueVars Type
t
uniqueVars (TV TyVar
_)   = TyVar -> Type
TV TyVar
0
uniqueVars Type
tc       = Type
tc

-- uniqueVars はmemoizeしない場合はやってもしょうがないし，memoizeする場合はsynergeticとそうでないのと両方でやるべきでは?


-- memoizeしない場合
typeToRandomsOrd :: TyConLib -> RTrie -> Type -> Order
typeToRandomsOrd :: TyConLib -> RTrie -> Type -> Order
typeToRandomsOrd TyConLib
tcl = (RTrie -> Type -> Maybe [Dynamic])
-> TyConLib -> RTrie -> Type -> Order
forall a.
(RTrie -> Type -> Maybe [a])
-> TyConLib -> RTrie -> Type -> Maybe ([a], PackedOrd)
ttro (\(CmpMap
cmap,Maps
maps,MemoMap
_,Tries
_,MapType (Dynamic, Dynamic)
_) -> TyConLib -> CmpMap -> Maps -> Type -> Maybe [Dynamic]
argTypeToRandoms TyConLib
tcl CmpMap
cmap Maps
maps) TyConLib
tcl
typeToRandomsOrdDM :: [Int] -> TyConLib -> RTrie -> Type -> Maybe ([[Dynamic]], PackedOrd)
typeToRandomsOrdDM :: [Int]
-> TyConLib -> RTrie -> Type -> Maybe ([[Dynamic]], PackedOrd)
typeToRandomsOrdDM [Int]
nrnds TyConLib
tcl = (RTrie -> Type -> Maybe [[Dynamic]])
-> TyConLib -> RTrie -> Type -> Maybe ([[Dynamic]], PackedOrd)
forall a.
(RTrie -> Type -> Maybe [a])
-> TyConLib -> RTrie -> Type -> Maybe ([a], PackedOrd)
ttro (\(CmpMap
cmap,Maps
maps,MemoMap
_,Tries
_,MapType (Dynamic, Dynamic)
_) -> [Int] -> TyConLib -> CmpMap -> Maps -> Type -> Maybe [[Dynamic]]
argTypeToRandomss [Int]
nrnds TyConLib
tcl CmpMap
cmap Maps
maps) TyConLib
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 :: (RTrie -> Type -> Maybe [a])
-> TyConLib -> RTrie -> Type -> Maybe ([a], PackedOrd)
ttro RTrie -> Type -> Maybe [a]
attr TyConLib
tcl rtrie :: RTrie
rtrie@(CmpMap
cmap,Maps
_,MemoMap
_,Tries
_,MapType (Dynamic, Dynamic)
_) (Type
a1:->Type
rest)
    = let (Type
a,Type
r) = TyConLib -> Type -> Type -> (Type, Type)
uncurryTy' TyConLib
tcl Type
a1 Type
rest
      in do PackedOrd
cmp  <- TyConLib -> CmpMap -> Type -> Maybe PackedOrd
typeToCompare TyConLib
tcl CmpMap
cmap Type
r
            [a]
rnds <- RTrie -> Type -> Maybe [a]
attr RTrie
rtrie Type
a
            ([a], PackedOrd) -> Maybe ([a], PackedOrd)
forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
rnds, PackedOrd
cmp)
ttro RTrie -> Type -> Maybe [a]
attr TyConLib
tcl (CmpMap
cmap, Maps
_, MemoMap
_, Tries
_, MapType (Dynamic, Dynamic)
_) Type
t
    = do PackedOrd
cmp <- TyConLib -> CmpMap -> Type -> Maybe PackedOrd
typeToCompare TyConLib
tcl CmpMap
cmap Type
t
         ([a], PackedOrd) -> Maybe ([a], PackedOrd)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], PackedOrd
cmp)



dynToCompare :: TyConLib -> Dynamic -> (Dynamic -> Dynamic -> Ordering)
dynToCompare :: TyConLib -> Dynamic -> PackedOrd
dynToCompare TyConLib
tcl Dynamic
dyn Dynamic
d0 Dynamic
d1 = TyConLib -> Dynamic -> Ordering -> Ordering
forall a. Typeable a => TyConLib -> Dynamic -> a -> a
fromDyn TyConLib
tcl (String -> Dynamic -> Dynamic -> Dynamic
dynAppErr String
"in dynToCompare (1)" (String -> Dynamic -> Dynamic -> Dynamic
dynAppErr String
"in dynToCompare (2)" Dynamic
dyn Dynamic
d0) Dynamic
d1) (String -> Ordering
forall a. HasCallStack => String -> a
error String
"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 :: TyConLib -> Type -> Type
uncurryTy TyConLib
tcl (Type
a:->Type
b) = case TyConLib -> Type -> Type -> (Type, Type)
uncurryTy' TyConLib
tcl Type
a Type
b of (Type
c,Type
r) -> Type
cType -> Type -> Type
:->Type
r
uncurryTy TyConLib
_   Type
t       = Type
t
uncurryTy' :: TyConLib -> Type -> Type -> (Type,Type)
uncurryTy' :: TyConLib -> Type -> Type -> (Type, Type)
uncurryTy' TyConLib
tcl Type
a (Type
b:->Type
r) = TyConLib -> Type -> Type -> (Type, Type)
uncurryTy' TyConLib
tcl (TyConLib -> Type -> Type -> Type
pair TyConLib
tcl Type
a Type
b) Type
r
uncurryTy' TyConLib
tcl Type
a Type
r       = (Type
a,Type
r)

pair :: TyConLib -> Type -> Type -> Type
pair TyConLib
tcl Type
a Type
b = (Type -> Type -> Type
TA (Type -> Type -> Type
TA (TyVar -> Type
TC (TyConLib -> Int -> TyVar
tuple TyConLib
tcl Int
2)) Type
a) Type
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 :: [Int] -> TyConLib -> Generator -> RTrie
mkRandTrie = [[(String, Dynamic)]]
-> [[(String, Dynamic)]]
-> [[(String, Dynamic)]]
-> [Int]
-> TyConLib
-> Generator
-> RTrie
mkRandTrieExt ([(String, Dynamic)] -> [[(String, Dynamic)]]
forall a. a -> [a]
repeat []) ([(String, Dynamic)] -> [[(String, Dynamic)]]
forall a. a -> [a]
repeat []) ([(String, Dynamic)] -> [[(String, Dynamic)]]
forall a. a -> [a]
repeat [])
-- | @mkRandTrieExt@ is an extensible version of 'mkRandTrie' that can be used with various types including user-defined ones.
mkRandTrieExt :: [[(String,Dynamic)]] -> [[(String,Dynamic)]] -> [[(String,Dynamic)]] -> [Int] -> TyConLib -> Generator -> RTrie
mkRandTrieExt :: [[(String, Dynamic)]]
-> [[(String, Dynamic)]]
-> [[(String, Dynamic)]]
-> [Int]
-> TyConLib
-> Generator
-> RTrie
mkRandTrieExt [[(String, Dynamic)]]
cmpExt [[(String, Dynamic)]]
arbExt [[(String, Dynamic)]]
coarbExt [Int]
nrnds TyConLib
tcl Generator
gen
                   = let arbtup :: ArbMap
arbtup   = [[(String, Dynamic)]] -> TyConLib -> ArbMap
mkArbMapExt [[(String, Dynamic)]]
arbExt TyConLib
tcl
                         coarbtup :: ArbMap
coarbtup = [[(String, Dynamic)]] -> TyConLib -> ArbMap
mkCoarbMapExt [[(String, Dynamic)]]
coarbExt TyConLib
tcl
                         (Generator
g0,Generator
g1)  = Generator -> (Generator, Generator)
forall g. RandomGen g => g -> (g, g)
split Generator
gen
                         maps :: Maps
maps     = (ArbMap
arbtup, ArbMap
coarbtup, Generator
g0, Generator
g1)
                         cmap :: CmpMap
cmap     = [[(String, Dynamic)]] -> TyConLib -> CmpMap
mkCmpMapExt [[(String, Dynamic)]]
cmpExt TyConLib
tcl
                         mmap :: MemoMap
mmap     = TyConLib -> MemoMap
mkMemoMap TyConLib
tcl
                     in (CmpMap
cmap, Maps
maps, MemoMap
mmap,
                            (TyConLib -> (Type -> Maybe [Dynamic]) -> MapType (Maybe [Dynamic])
forall a. TyConLib -> (Type -> a) -> MapType a
mkMT TyConLib
tcl (TyConLib -> CmpMap -> Maps -> Type -> Maybe [Dynamic]
argTypeToRandoms TyConLib
tcl CmpMap
cmap Maps
maps), TyConLib
-> (Type -> Maybe [[Dynamic]]) -> MapType (Maybe [[Dynamic]])
forall a. TyConLib -> (Type -> a) -> MapType a
mkMT TyConLib
tcl ([Int] -> TyConLib -> CmpMap -> Maps -> Type -> Maybe [[Dynamic]]
argTypeToRandomss [Int]
nrnds TyConLib
tcl CmpMap
cmap Maps
maps)),
                            (TyConLib
-> (Type -> (Dynamic, Dynamic)) -> MapType (Dynamic, Dynamic)
forall a. TyConLib -> (Type -> a) -> MapType a
mkMT TyConLib
tcl (MemoMap -> Type -> (Dynamic, Dynamic)
typeToMemo MemoMap
mmap)))
argTypeToRandoms :: TyConLib -> CmpMap -> Maps -> Type -> Maybe [Dynamic]
argTypeToRandoms :: TyConLib -> CmpMap -> Maps -> Type -> Maybe [Dynamic]
argTypeToRandoms  TyConLib
tcl CmpMap
cmap (ArbMap
arbtup, ArbMap
coarbtup, Generator
gen, Generator
_) Type
a
    = do Dynamic
arb  <- ArbMap -> ArbMap -> Type -> Maybe Dynamic
typeToArb ArbMap
arbtup ArbMap
coarbtup Type
a
         [Dynamic] -> Maybe [Dynamic]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dynamic] -> Maybe [Dynamic]) -> [Dynamic] -> Maybe [Dynamic]
forall a b. (a -> b) -> a -> b
$ TyConLib -> Dynamic -> Arb Dynamic
arbitrariesByDyn TyConLib
tcl Dynamic
arb Generator
gen
argTypeToRandomss :: [Int] -> TyConLib -> CmpMap -> Maps -> Type -> Maybe [[Dynamic]]
argTypeToRandomss :: [Int] -> TyConLib -> CmpMap -> Maps -> Type -> Maybe [[Dynamic]]
argTypeToRandomss [Int]
nrnds TyConLib
tcl CmpMap
cmap (ArbMap
arbtup, ArbMap
coarbtup, Generator
_, Generator
gen) Type
a
    = do Dynamic
arb  <- ArbMap -> ArbMap -> Type -> Maybe Dynamic
typeToArb ArbMap
arbtup ArbMap
coarbtup Type
a
         let arbssDyn :: [[Dynamic]]
arbssDyn = [Int] -> TyConLib -> Dynamic -> Generator -> [[Dynamic]]
arbitrariessByDyn [Int]
nrnds TyConLib
tcl Dynamic
arb Generator
gen
         case TyConLib -> CmpMap -> Type -> Maybe PackedOrd
typeToCompare TyConLib
tcl CmpMap
cmap Type
a of Maybe PackedOrd
Nothing  -> [[Dynamic]] -> Maybe [[Dynamic]]
forall (m :: * -> *) a. Monad m => a -> m a
return [[Dynamic]]
arbssDyn
                                          Just PackedOrd
cmp -> [[Dynamic]] -> Maybe [[Dynamic]]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Dynamic]] -> Maybe [[Dynamic]])
-> [[Dynamic]] -> Maybe [[Dynamic]]
forall a b. (a -> b) -> a -> b
$ ([Dynamic] -> [Dynamic]) -> [[Dynamic]] -> [[Dynamic]]
forall a b. (a -> b) -> [a] -> [b]
map (PackedOrd -> [Dynamic] -> [Dynamic]
forall t. (t -> t -> Ordering) -> [t] -> [t]
nubByCmp PackedOrd
cmp ([Dynamic] -> [Dynamic])
-> ([Dynamic] -> [Dynamic]) -> [Dynamic] -> [Dynamic]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Dynamic] -> [Dynamic]
forall a. Int -> [a] -> [a]
take Int
20) [[Dynamic]]
arbssDyn
nubByCmp :: (t -> t -> Ordering) -> [t] -> [t]
nubByCmp t -> t -> Ordering
cmp = (t -> t -> Bool) -> [t] -> [t]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (\t
a t
b -> t -> t -> Ordering
cmp t
a t
b Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
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 :: TyConLib -> [[(String, a)]] -> MapTC a
mkMap tcl :: TyConLib
tcl@(Map String TyVar
mapNameTyCon,Array Int [(String, TyVar)]
_) [[(String, a)]]
mcts = [(Int, IntMap a)] -> MapTC a
forall a. [(Int, a)] -> IntMap a
IntMap.fromAscList ([(Int, IntMap a)] -> MapTC a) -> [(Int, IntMap a)] -> MapTC a
forall a b. (a -> b) -> a -> b
$ [Int] -> [IntMap a] -> [(Int, IntMap a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] ([IntMap a] -> [(Int, IntMap a)])
-> [IntMap a] -> [(Int, IntMap a)]
forall a b. (a -> b) -> a -> b
$ ([(String, a)] -> IntMap a) -> [[(String, a)]] -> [IntMap a]
forall a b. (a -> b) -> [a] -> [b]
map ([(Int, a)] -> IntMap a
forall a. [(Int, a)] -> IntMap a
IntMap.fromList ([(Int, a)] -> IntMap a)
-> ([(String, a)] -> [(Int, a)]) -> [(String, a)] -> IntMap a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, a) -> (Int, a)) -> [(String, a)] -> [(Int, a)]
forall a b. (a -> b) -> [a] -> [b]
map (\ (String
name, a
dyn) -> (TyVar -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Map String TyVar
mapNameTyCon Map String TyVar -> String -> TyVar
forall k a. Ord k => Map k a -> k -> a
Map.! String
name),  a
dyn))) [[(String, a)]]
mcts
mkCmpMap :: TyConLib -> CmpMap
mkCmpMap :: TyConLib -> CmpMap
mkCmpMap = [[(String, Dynamic)]] -> TyConLib -> CmpMap
mkCmpMapExt ([[(String, Dynamic)]] -> TyConLib -> CmpMap)
-> [[(String, Dynamic)]] -> TyConLib -> CmpMap
forall a b. (a -> b) -> a -> b
$ [(String, Dynamic)] -> [[(String, Dynamic)]]
forall a. a -> [a]
repeat []
mkCmpMapExt :: [[(String,Dynamic)]] -> TyConLib -> CmpMap
mkCmpMapExt :: [[(String, Dynamic)]] -> TyConLib -> CmpMap
mkCmpMapExt [[(String, Dynamic)]]
ext TyConLib
tcl = (TyConLib -> [[(String, Dynamic)]] -> MapTC Dynamic
forall a. TyConLib -> [[(String, a)]] -> MapTC a
mkMap TyConLib
tcl ([[(String, Dynamic)]] -> MapTC Dynamic)
-> [[(String, Dynamic)]] -> MapTC Dynamic
forall a b. (a -> b) -> a -> b
$ ([(String, Dynamic)] -> [(String, Dynamic)] -> [(String, Dynamic)])
-> [[(String, Dynamic)]]
-> [[(String, Dynamic)]]
-> [[(String, Dynamic)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [(String, Dynamic)] -> [(String, Dynamic)] -> [(String, Dynamic)]
forall a. [a] -> [a] -> [a]
(++) [[(String, Dynamic)]
mct0, [(String, Dynamic)]
mct1, [(String, Dynamic)]
mct2] [[(String, Dynamic)]]
ext,
                TyConLib -> [(String, String, Dynamic)] -> IntMap Dynamic
mkSpecialMap TyConLib
tcl [(String
"Ratio", String
"Int",     $(dynamic [|tcl|] [| compareRatio :: Ratio Int -> Ratio Int -> Ordering |])),
                                  (String
"Ratio", String
"Integer", $(dynamic [|tcl|] [| compareRatio :: Ratio Integer -> Ratio Integer -> Ordering |]))],
                Dynamic
cmpChar)
    where
          cmpChar :: Dynamic
cmpChar = $(dynamic [|tcl|] [| compare :: Char -> Char -> Ordering |])
          mct0, mct1, mct2 :: [(String,Dynamic)]
          mct0 :: [(String, Dynamic)]
mct0 = [(String
"Int",     $(dynamic [|tcl|] [| compare      :: Int     -> Int     -> Ordering |])),
                  (String
"Integer", $(dynamic [|tcl|] [| compare      :: Integer -> Integer -> Ordering |])),
                  (String
"Char",    Dynamic
cmpChar),
                  (String
"Bool",    $(dynamic [|tcl|] [| compare      :: Bool    -> Bool    -> Ordering |])),
                  (String
"Double",  $(dynamic [|tcl|] [| compareRealFloat :: Double  -> Double  -> Ordering |])),
                  (String
"Float",   $(dynamic [|tcl|] [| compareRealFloat :: Float   -> Float   -> Ordering |])),
                  (String
"()",      $(dynamic [|tcl|] [| compare      :: ()      -> ()      -> Ordering |])),
                  (String
"Ordering",$(dynamic [|tcl|] [| compare      :: Ordering-> Ordering-> Ordering |]))]
          mct1 :: [(String, Dynamic)]
mct1 = [(String
"Maybe",   $(dynamic [|tcl|] [| compareMaybe :: (a -> a -> Ordering) -> Maybe a -> Maybe a -> Ordering |])),
                  (String
"[]",      $(dynamic [|tcl|] [| compareList  :: (a -> a -> Ordering) -> [a]     -> [a]     -> Ordering |]))]
          mct2 :: [(String, Dynamic)]
mct2 = [(String
"Either",  $(dynamic [|tcl|] [| compareEither:: (a -> a -> Ordering) ->
                                                                   (b -> b -> Ordering) -> Either a b -> Either a b -> Ordering |])),
                  (String
"(,)",     $(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 :: (t -> t -> Ordering) -> Maybe t -> Maybe t -> Ordering
compareMaybe t -> t -> Ordering
_   Maybe t
Nothing  Maybe t
Nothing  = Ordering
EQ
compareMaybe t -> t -> Ordering
_   Maybe t
Nothing  Maybe t
_        = Ordering
LT
compareMaybe t -> t -> Ordering
_   Maybe t
_        Maybe t
Nothing  = Ordering
GT
compareMaybe t -> t -> Ordering
cmp (Just t
x) (Just t
y) = t -> t -> Ordering
cmp t
x t
y
compareRatio :: Integral i => Ratio i -> Ratio i -> Ordering
compareRatio :: Ratio i -> Ratio i -> Ordering
compareRatio Ratio i
x Ratio i
y = case (Ratio i -> i
forall a. Integral a => Ratio a -> a
denominator Ratio i
x, Ratio i -> i
forall a. Integral a => Ratio a -> a
denominator Ratio i
y) of (i
0,i
0) -> Ordering
EQ -- Because the comparison is just for removing duplicates efficiently,
                                                          (i
0,i
_) -> Ordering
LT -- notANumber should be a normal element here.
                                                          (i
_,i
0) -> Ordering
GT
                                                          (i, i)
_     -> i -> i -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Ratio i -> i
forall a. Integral a => Ratio a -> a
numerator Ratio i
x i -> i -> i
forall a. Num a => a -> a -> a
* Ratio i -> i
forall a. Integral a => Ratio a -> a
denominator Ratio i
y) (Ratio i -> i
forall a. Integral a => Ratio a -> a
numerator Ratio i
y i -> i -> i
forall a. Num a => a -> a -> a
* Ratio i -> i
forall a. Integral a => Ratio a -> a
denominator Ratio i
x)
compareRealFloat  :: (NearEq a, RealFloat a) => a->a->Ordering
compareRealFloat :: a -> a -> Ordering
compareRealFloat a
x a
y = case (a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
x, a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
y) of -- Because the comparison is just for removing duplicates efficiently,
                             (Bool
True, Bool
True)  -> Ordering
EQ  -- NaN should be a normal element here.
                             (Bool
True, Bool
False) -> Ordering
LT
                             (Bool
False,Bool
True)  -> Ordering
GT
                             (Bool
False,Bool
False) -> if a
xa -> a -> Bool
forall a. NearEq a => a -> a -> Bool
~=a
y then Ordering
EQ else a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
x a
y


compareList :: (t -> t -> Ordering) -> [t] -> [t] -> Ordering
compareList t -> t -> Ordering
_   []     []     = Ordering
EQ
compareList t -> t -> Ordering
_   []     [t]
_      = Ordering
LT
compareList t -> t -> Ordering
_   [t]
_      []     = Ordering
GT
compareList t -> t -> Ordering
cmp (t
x:[t]
xs) (t
y:[t]
ys) = case t -> t -> Ordering
cmp t
x t
y of Ordering
EQ -> (t -> t -> Ordering) -> [t] -> [t] -> Ordering
compareList t -> t -> Ordering
cmp [t]
xs [t]
ys
                                                Ordering
c  -> Ordering
c
compareEither :: (t -> t -> Ordering)
-> (t -> t -> Ordering) -> Either t t -> Either t t -> Ordering
compareEither t -> t -> Ordering
cmp0 t -> t -> Ordering
cmp1 (Left t
x)  (Left t
y)  = t -> t -> Ordering
cmp0 t
x t
y
compareEither t -> t -> Ordering
cmp0 t -> t -> Ordering
cmp1 (Left t
_)  Either t t
_         = Ordering
LT
compareEither t -> t -> Ordering
cmp0 t -> t -> Ordering
cmp1 Either t t
_         (Left t
_)  = Ordering
GT
compareEither t -> t -> Ordering
cmp0 t -> t -> Ordering
cmp1 (Right t
x) (Right t
y) = t -> t -> Ordering
cmp1 t
x t
y
comparePair :: (t -> t -> Ordering)
-> (t -> t -> Ordering) -> (t, t) -> (t, t) -> Ordering
comparePair   t -> t -> Ordering
cmp0 t -> t -> Ordering
cmp1 (t
x0,t
x1)  (t
y0,t
y1) = case t -> t -> Ordering
cmp0 t
x0 t
y0 of Ordering
EQ -> t -> t -> Ordering
cmp1 t
x1 t
y1
                                                              Ordering
c  -> Ordering
c

typeToCompare :: TyConLib -> CmpMap -> Type -> Maybe (Dynamic -> Dynamic -> Ordering)
typeToCompare :: TyConLib -> CmpMap -> Type -> Maybe PackedOrd
typeToCompare TyConLib
tcl CmpMap
cmap Type
ty = do Dynamic
cmp <- CmpMap -> Type -> Maybe Dynamic
typeToOrd CmpMap
cmap Type
ty
                               PackedOrd -> Maybe PackedOrd
forall (m :: * -> *) a. Monad m => a -> m a
return (TyConLib -> Dynamic -> PackedOrd
dynToCompare TyConLib
tcl Dynamic
cmp)
typeToOrd :: CmpMap -> Type -> Maybe Dynamic
typeToOrd :: CmpMap -> Type -> Maybe Dynamic
typeToOrd (MapTC Dynamic
cmpmap,IntMap Dynamic
spmap,Dynamic
cmpchar) Type
ty = Int -> Type -> Maybe Dynamic
tto Int
0 Type
ty
    where tto :: Int -> Type -> Maybe Dynamic
tto Int
0 (TA (TC TyVar
tc1) (TC TyVar
tc2)) | Just Dynamic
dyn <- Int -> IntMap Dynamic -> Maybe Dynamic
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup (TyVar -> TyVar -> Int
combineTCs TyVar
tc1 TyVar
tc2) IntMap Dynamic
spmap = Dynamic -> Maybe Dynamic
forall (m :: * -> *) a. Monad m => a -> m a
return Dynamic
dyn
          tto Int
k (TA Type
t Type
u) = (Dynamic -> Dynamic -> Dynamic)
-> Maybe Dynamic -> Maybe Dynamic -> Maybe Dynamic
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Dynamic -> Dynamic -> Dynamic
dynApp (Int -> Type -> Maybe Dynamic
tto (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Type
t) (Int -> Type -> Maybe Dynamic
tto Int
0 Type
u) -- Higher-order kinds break everything.
          tto Int
_ (Type
_:->Type
_)  = Maybe Dynamic
forall a. Maybe a
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 Int
0 (TV TyVar
_)   = Dynamic -> Maybe Dynamic
forall a. a -> Maybe a
Just Dynamic
cmpchar -- same as the Char case
          tto Int
_ (TV TyVar
_)   = Maybe Dynamic
forall a. Maybe a
Nothing -- これについては一般的なやりかたはなさそう．
          tto Int
k (TC TyVar
tc)  = do Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (TyVar
tc TyVar -> TyVar -> Bool
forall a. Ord a => a -> a -> Bool
>= TyVar
0)
                              IntMap Dynamic
imap <- Int -> MapTC Dynamic -> Maybe (IntMap Dynamic)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
k MapTC Dynamic
cmpmap
                              Int -> IntMap Dynamic -> Maybe Dynamic
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup (TyVar -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral TyVar
tc) IntMap Dynamic
imap
          tto Int
_ Type
_        = Maybe Dynamic
forall a. Maybe a
Nothing
type ArbMap   = (MapTC Dynamic, SpecialMap, Dynamic, Dynamic)
type CoarbMap = (MapTC Dynamic, SpecialMap, Dynamic, Dynamic)

mkArbMap :: TyConLib -> ArbMap
mkArbMap :: TyConLib -> ArbMap
mkArbMap = [[(String, Dynamic)]] -> TyConLib -> ArbMap
mkArbMapExt ([[(String, Dynamic)]] -> TyConLib -> ArbMap)
-> [[(String, Dynamic)]] -> TyConLib -> ArbMap
forall a b. (a -> b) -> a -> b
$ [(String, Dynamic)] -> [[(String, Dynamic)]]
forall a. a -> [a]
repeat []
mkArbMapExt :: [[(String,Dynamic)]] -> TyConLib -> ArbMap
mkArbMapExt :: [[(String, Dynamic)]] -> TyConLib -> ArbMap
mkArbMapExt [[(String, Dynamic)]]
ext tcl :: TyConLib
tcl@(Map String TyVar
mapNameTyCon,Array Int [(String, TyVar)]
_) = (TyConLib -> [[(String, Dynamic)]] -> MapTC Dynamic
forall a. TyConLib -> [[(String, a)]] -> MapTC a
mkMap TyConLib
tcl ([[(String, Dynamic)]] -> MapTC Dynamic)
-> [[(String, Dynamic)]] -> MapTC Dynamic
forall a b. (a -> b) -> a -> b
$ ([(String, Dynamic)] -> [(String, Dynamic)] -> [(String, Dynamic)])
-> [[(String, Dynamic)]]
-> [[(String, Dynamic)]]
-> [[(String, Dynamic)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [(String, Dynamic)] -> [(String, Dynamic)] -> [(String, Dynamic)]
forall a. [a] -> [a] -> [a]
(++) [[(String, Dynamic)]
mct0, [(String, Dynamic)]
mct1, [(String, Dynamic)]
mct2, [(String, Dynamic)]
mct3] [[(String, Dynamic)]]
ext,
                                 TyConLib -> [(String, String, Dynamic)] -> IntMap Dynamic
mkSpecialMap TyConLib
tcl [(String
"Ratio", String
"Int",     $(dynamic [|tcl|] [| arbitraryRatio   :: Gen (Ratio Int) |])),
                                                   (String
"Ratio", String
"Integer", $(dynamic [|tcl|] [| arbitraryRatio   :: Gen (Ratio Integer) |]))],
                                Dynamic
arbChar, -- same as the Char case
                                $(dynamic [|tcl|] [| arbitraryFun :: (a -> Gen b -> Gen b) -> Gen b -> Gen (a->b) |])
                                )

    where
          arbChar :: Dynamic
arbChar = $(dynamic [|tcl|] [| arbitraryChar :: Gen Char |])
          mct0, mct1, mct2, mct3 :: [(String,Dynamic)]
          mct0 :: [(String, Dynamic)]
mct0 = [(String
"Int",     $(dynamic [|tcl|] [| arbitraryInt     :: Gen Int |])),
                  (String
"Char",    Dynamic
arbChar),
                  (String
"Integer", $(dynamic [|tcl|] [| arbitraryInteger :: Gen Integer |])),
                  (String
"Bool",    $(dynamic [|tcl|] [| arbitraryBool    :: Gen Bool    |])),
                  (String
"Double",  $(dynamic [|tcl|] [| arbitraryDouble  :: Gen Double  |])),
                  (String
"Float",   $(dynamic [|tcl|] [| arbitraryFloat   :: Gen Float   |])),
                  (String
"()",      $(dynamic [|tcl|] [| arbitraryUnit    :: Gen ()      |])),
                  (String
"Ordering",$(dynamic [|tcl|] [| arbitraryOrdering:: Gen Ordering|]))]
          mct1 :: [(String, Dynamic)]
mct1 = [(String
"Maybe",   $(dynamic [|tcl|] [| arbitraryMaybe   :: Gen a -> Gen (Maybe a) |])),
                  (String
"[]",      $(dynamic [|tcl|] [| arbitraryList    :: Gen a -> Gen [a]       |]))]
          mct2 :: [(String, Dynamic)]
mct2 = [(String
"Either",  $(dynamic [|tcl|] [| arbitraryEither  :: Gen a -> Gen b -> Gen (Either a b) |])),
                  (String
"(,)",     $(dynamic [|tcl|] [| arbitraryPair    :: Gen a -> Gen b -> Gen (a, b)       |]))]
          mct3 :: [(String, Dynamic)]
mct3 = [(String
"(,,)",    $(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 :: TyConLib -> [(String, String, Dynamic)] -> IntMap Dynamic
mkSpecialMap tcl :: TyConLib
tcl@(Map String TyVar
mapNameTyCon,Array Int [(String, TyVar)]
_) = [(Int, Dynamic)] -> IntMap Dynamic
forall a. [(Int, a)] -> IntMap a
IntMap.fromList ([(Int, Dynamic)] -> IntMap Dynamic)
-> ([(String, String, Dynamic)] -> [(Int, Dynamic)])
-> [(String, String, Dynamic)]
-> IntMap Dynamic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String, Dynamic) -> (Int, Dynamic))
-> [(String, String, Dynamic)] -> [(Int, Dynamic)]
forall a b. (a -> b) -> [a] -> [b]
map (\ (String
name1, String
name2, Dynamic
dyn) -> (TyVar -> TyVar -> Int
combineTCs (Map String TyVar
mapNameTyCon Map String TyVar -> String -> TyVar
forall k a. Ord k => Map k a -> k -> a
Map.! String
name1) (Map String TyVar
mapNameTyCon Map String TyVar -> String -> TyVar
forall k a. Ord k => Map k a -> k -> a
Map.! String
name2),  Dynamic
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 :: TyVar -> TyVar -> Int
combineTCs TyVar
tc1 TyVar
tc2 = TyVar -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral TyVar
tc1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
256 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ TyVar -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral TyVar
tc2


typeToArb :: ArbMap -> CoarbMap -> Type -> Maybe Dynamic
typeToArb :: ArbMap -> ArbMap -> Type -> Maybe Dynamic
typeToArb arbtup :: ArbMap
arbtup@(MapTC Dynamic
arbmap, IntMap Dynamic
spmap, Dynamic
arbchar, Dynamic
arbfun) coarbtup :: ArbMap
coarbtup@(MapTC Dynamic
coarbmap, IntMap Dynamic
_, Dynamic
coarbchar, Dynamic
coarbfun) Type
ty = Int -> Type -> Maybe Dynamic
tta Int
0 Type
ty
    where
          tta :: Int -> Type -> Maybe Dynamic
tta Int
0 ty :: Type
ty@(Type
t :-> Type
u) = do Dynamic
coarb <- ArbMap -> ArbMap -> Type -> Maybe Dynamic
typeToCoarb ArbMap
arbtup ArbMap
coarbtup Type
t
                                  Dynamic
arb   <- Int -> Type -> Maybe Dynamic
tta Int
0 Type
u
                                  Dynamic -> Maybe Dynamic
forall (m :: * -> *) a. Monad m => a -> m a
return (-- trace ("t = "++show t++" and u = "++show u ++ " and coarb = "++show coarb) $
                                          Dynamic -> Dynamic -> Dynamic
dynApp (Dynamic -> Dynamic -> Dynamic
dynApp Dynamic
arbfun Dynamic
coarb) Dynamic
arb)
          tta Int
0 (TV TyVar
_)  = Dynamic -> Maybe Dynamic
forall a. a -> Maybe a
Just Dynamic
arbchar -- same as the Char case
          tta Int
_ (TV TyVar
_)  = Maybe Dynamic
forall a. Maybe a
Nothing -- これについては一般的なやりかたはなさそう．
          tta Int
k (TC TyVar
tc)
              = do Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (TyVar
tc TyVar -> TyVar -> Bool
forall a. Ord a => a -> a -> Bool
>= TyVar
0)
                   IntMap Dynamic
imap <- Int -> MapTC Dynamic -> Maybe (IntMap Dynamic)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
k MapTC Dynamic
arbmap
                   Int -> IntMap Dynamic -> Maybe Dynamic
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup (TyVar -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral TyVar
tc) IntMap Dynamic
imap
          tta Int
0 (TA (TC TyVar
tc1) (TC TyVar
tc2)) | Just Dynamic
dyn <- Int -> IntMap Dynamic -> Maybe Dynamic
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup (TyVar -> TyVar -> Int
combineTCs TyVar
tc1 TyVar
tc2) IntMap Dynamic
spmap = Dynamic -> Maybe Dynamic
forall (m :: * -> *) a. Monad m => a -> m a
return Dynamic
dyn
          tta Int
k (TA Type
t0 Type
t1) = do Dynamic
arb0 <- Int -> Type -> Maybe Dynamic
tta (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Type
t0
                                Dynamic
arb1 <- Int -> Type -> Maybe Dynamic
tta Int
0     Type
t1
                                Dynamic -> Maybe Dynamic
forall (m :: * -> *) a. Monad m => a -> m a
return (-- trace ("t0 = "++show t0++" and t1 = "++show t1) $
                                        Dynamic -> Dynamic -> Dynamic
dynApp Dynamic
arb0 Dynamic
arb1)
          tta Int
_ Type
_ = Maybe Dynamic
forall a. Maybe a
Nothing
mkCoarbMap :: TyConLib -> CoarbMap
mkCoarbMap :: TyConLib -> ArbMap
mkCoarbMap = [[(String, Dynamic)]] -> TyConLib -> ArbMap
mkCoarbMapExt ([[(String, Dynamic)]] -> TyConLib -> ArbMap)
-> [[(String, Dynamic)]] -> TyConLib -> ArbMap
forall a b. (a -> b) -> a -> b
$ [(String, Dynamic)] -> [[(String, Dynamic)]]
forall a. a -> [a]
repeat []
mkCoarbMapExt :: [[(String,Dynamic)]] -> TyConLib -> CoarbMap
mkCoarbMapExt :: [[(String, Dynamic)]] -> TyConLib -> ArbMap
mkCoarbMapExt [[(String, Dynamic)]]
ext tcl :: TyConLib
tcl@(Map String TyVar
mapNameTyCon,Array Int [(String, TyVar)]
_) = (TyConLib -> [[(String, Dynamic)]] -> MapTC Dynamic
forall a. TyConLib -> [[(String, a)]] -> MapTC a
mkMap TyConLib
tcl ([[(String, Dynamic)]] -> MapTC Dynamic)
-> [[(String, Dynamic)]] -> MapTC Dynamic
forall a b. (a -> b) -> a -> b
$ ([(String, Dynamic)] -> [(String, Dynamic)] -> [(String, Dynamic)])
-> [[(String, Dynamic)]]
-> [[(String, Dynamic)]]
-> [[(String, Dynamic)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [(String, Dynamic)] -> [(String, Dynamic)] -> [(String, Dynamic)]
forall a. [a] -> [a] -> [a]
(++) [[(String, Dynamic)]
mct0, [(String, Dynamic)]
mct1, [(String, Dynamic)]
mct2, [(String, Dynamic)]
mct3] [[(String, Dynamic)]]
ext,
                                   TyConLib -> [(String, String, Dynamic)] -> IntMap Dynamic
mkSpecialMap TyConLib
tcl [(String
"Ratio", String
"Int",     $(dynamic [|tcl|] [| coarbitraryRatio   :: Ratio Int -> Gen x -> Gen x |])),
                                                     (String
"Ratio", String
"Integer", $(dynamic [|tcl|] [| coarbitraryRatio   :: Ratio Integer -> Gen x -> Gen x |]))],
                                   Dynamic
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
coarbChar = $(dynamic [|tcl|] [| coarbitraryChar :: Char -> Gen x -> Gen x |])
          mct0, mct1, mct2, mct3 :: [(String,Dynamic)]
          mct0 :: [(String, Dynamic)]
mct0 = [(String
"Int",      $(dynamic [|tcl|] [| coarbitraryInt     :: Int     -> Gen x -> Gen x |])),
                  (String
"Char",     Dynamic
coarbChar),
                  (String
"Integer",  $(dynamic [|tcl|] [| coarbitraryInteger  :: Integer  -> Gen x -> Gen x |])),
                  (String
"Bool",     $(dynamic [|tcl|] [| coarbitraryBool     :: Bool     -> Gen x -> Gen x |])),
                  (String
"Double",   $(dynamic [|tcl|] [| coarbitraryDouble   :: Double   -> Gen x -> Gen x |])),
                  (String
"Float",    $(dynamic [|tcl|] [| coarbitraryFloat    :: Float    -> Gen x -> Gen x |])),
                  (String
"()",       $(dynamic [|tcl|] [| coarbitraryUnit     :: ()       -> Gen x -> Gen x |])),
                  (String
"Ordering", $(dynamic [|tcl|] [| coarbitraryOrdering :: Ordering -> Gen x -> Gen x |]))]
          mct1 :: [(String, Dynamic)]
mct1 = [(String
"[]",     $(dynamic [|tcl|] [| coarbitraryList   :: (a -> Gen x -> Gen x) -> [a]     -> Gen x -> Gen x |])),
                  (String
"Maybe",  $(dynamic [|tcl|] [| coarbitraryMaybe  :: (a -> Gen x -> Gen x) -> Maybe a -> Gen x -> Gen x |]))]
          mct2 :: [(String, Dynamic)]
mct2 = [(String
"Either", $(dynamic [|tcl|] [| coarbitraryEither :: (a -> Gen x -> Gen x) ->
                                                                       (b -> Gen x -> Gen x) -> Either a b -> Gen x -> Gen x |])),
                  (String
"(,)",    $(dynamic [|tcl|] [| coarbitraryPair   :: (a -> Gen x -> Gen x) ->
                                                                       (b -> Gen x -> Gen x) -> (a, b) -> Gen x -> Gen x |]))]
          mct3 :: [(String, Dynamic)]
mct3 = [(String
"(,,)",   $(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 :: ArbMap -> ArbMap -> Type -> Maybe Dynamic
typeToCoarb arbtup :: ArbMap
arbtup@(MapTC Dynamic
arbmap,IntMap Dynamic
_,Dynamic
arbchar,Dynamic
arbfun) coarbtup :: ArbMap
coarbtup@(MapTC Dynamic
coarbmap,IntMap Dynamic
spmap,Dynamic
coarbchar,Dynamic
coarbfun) Type
ty = Int -> Type -> Maybe Dynamic
ttc Int
0 Type
ty
    where -- ttc :: Type -> Maybe (Coarb Dynamic)
          ttc :: Int -> Type -> Maybe Dynamic
ttc Int
0 ty :: Type
ty@(Type
t :-> Type
u) = do Dynamic
arb <- ArbMap -> ArbMap -> Type -> Maybe Dynamic
typeToArb ArbMap
arbtup ArbMap
coarbtup Type
t
                                  Dynamic
coarb <- Int -> Type -> Maybe Dynamic
ttc Int
0 Type
u
                                  Dynamic -> Maybe Dynamic
forall (m :: * -> *) a. Monad m => a -> m a
return (Dynamic -> Dynamic -> Dynamic
dynApp (Dynamic -> Dynamic -> Dynamic
dynApp Dynamic
coarbfun Dynamic
arb) Dynamic
coarb)
          ttc Int
0 (TV TyVar
_)  = Dynamic -> Maybe Dynamic
forall a. a -> Maybe a
Just Dynamic
coarbchar -- same as the Char case
          ttc Int
_ (TV TyVar
_)  = Maybe Dynamic
forall a. Maybe a
Nothing
          ttc Int
k (TC TyVar
tc)
              = do Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (TyVar
tc TyVar -> TyVar -> Bool
forall a. Ord a => a -> a -> Bool
>= TyVar
0)
                   IntMap Dynamic
imap <- Int -> MapTC Dynamic -> Maybe (IntMap Dynamic)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
k MapTC Dynamic
coarbmap
                   Int -> IntMap Dynamic -> Maybe Dynamic
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup (TyVar -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral TyVar
tc) IntMap Dynamic
imap
          ttc Int
0 (TA (TC TyVar
tc1) (TC TyVar
tc2)) | Just Dynamic
dyn <- Int -> IntMap Dynamic -> Maybe Dynamic
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup (TyVar -> TyVar -> Int
combineTCs TyVar
tc1 TyVar
tc2) IntMap Dynamic
spmap = Dynamic -> Maybe Dynamic
forall (m :: * -> *) a. Monad m => a -> m a
return Dynamic
dyn
          ttc Int
k (TA Type
t0 Type
t1) = do Dynamic
arb0 <- Int -> Type -> Maybe Dynamic
ttc (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Type
t0
                                Dynamic
arb1 <- Int -> Type -> Maybe Dynamic
ttc Int
0     Type
t1
                                Dynamic -> Maybe Dynamic
forall (m :: * -> *) a. Monad m => a -> m a
return (-- trace ("arb0 = "++show arb0++"arb1 = "++show arb1) $
                                        Dynamic -> Dynamic -> Dynamic
dynApp Dynamic
arb0 Dynamic
arb1)
          ttc Int
_ Type
_ = Maybe Dynamic
forall a. Maybe a
Nothing -- めんどくさいので取り合えず．



type MemoMap = (IntMap.IntMap (IntMap.IntMap (Dynamic,Dynamic)), (Dynamic,Dynamic))
mkMemoMap :: TyConLib -> MemoMap
mkMemoMap :: TyConLib -> MemoMap
mkMemoMap tcl :: TyConLib
tcl@(Map String TyVar
mapNameTyCon,Array Int [(String, TyVar)]
_) = (TyConLib
-> [[(String, (Dynamic, Dynamic))]] -> MapTC (Dynamic, Dynamic)
forall a. TyConLib -> [[(String, a)]] -> MapTC a
mkMap TyConLib
tcl [[(String, (Dynamic, Dynamic))]
mct0, [(String, (Dynamic, Dynamic))]
mct1, [(String, (Dynamic, Dynamic))]
mct2, [(String, (Dynamic, Dynamic))]
mct3],
                                  (Dynamic, Dynamic)
memoAppChar)
    where memoAppChar :: (Dynamic, Dynamic)
memoAppChar = ( $(dynamic [|tcl|] [| memoChar :: (Char->a) -> MapChar a |]), 
                          $(dynamic [|tcl|] [| appChar  :: MapChar a -> (Char->a) |]) )
          mct0, mct1, mct2, mct3 :: [(String,(Dynamic,Dynamic))]
          mct0 :: [(String, (Dynamic, Dynamic))]
mct0 = [(String
"Int",     ($(dynamic  [|tcl|] [| memoIx3      :: (Int->a) -> MapIx Int a |]),
                               $(dynamic  [|tcl|] [| appIx       :: MapIx Int a -> (Int->a) |]))),
                  (String
"Char",    (Dynamic, Dynamic)
memoAppChar),
                  (String
"Integer", ($(dynamic  [|tcl|] [| memoInteger  :: (Integer->a) -> MapInteger a |]),
                               $(dynamic  [|tcl|] [| appInteger   :: MapInteger a -> (Integer->a) |]))),
                  (String
"Bool",    ($(dynamic  [|tcl|] [| memoBool     :: (Bool->a) -> MapBool a |]),
                               $(dynamic  [|tcl|] [| appBool      :: MapBool a -> (Bool->a) |]))),
                  (String
"Ordering",($(dynamic  [|tcl|] [| memoOrdering :: (Ordering->a) -> MapOrdering a |]),
                               $(dynamic  [|tcl|] [| appOrdering  :: MapOrdering a -> (Ordering->a) |]))),
                  (String
"()",      ($(dynamic  [|tcl|] [| memoUnit     :: (()->a) -> MapUnit a |]),
                               $(dynamic  [|tcl|] [| appUnit      :: MapUnit a -> (()->a) |]))),
                  (String
"Double",  ($(dynamic  [|tcl|] [| memoReal     :: (Double->a) -> MapReal a |]),
                               $(dynamic  [|tcl|] [| appReal      :: MapReal a -> (Double->a) |]))),
                  (String
"Float",   ($(dynamic  [|tcl|] [| memoReal     :: (Float->a) -> MapReal a |]),
                               $(dynamic  [|tcl|] [| appReal      :: MapReal a -> (Float->a) |])))]
          mct1 :: [(String, (Dynamic, Dynamic))]
mct1 = [(String
"[]",      ($(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) |]))),
                  (String
"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 :: [(String, (Dynamic, Dynamic))]
mct2 = [(String
"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) |]))),
                  (String
"(,)",     ($(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 :: [(String, (Dynamic, Dynamic))]
mct3 = [(String
"(,,)",    ($(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 :: Integer
memoLength = Integer
10
typeToMemo :: MemoMap -> Type -> (Dynamic,Dynamic)
typeToMemo :: MemoMap -> Type -> (Dynamic, Dynamic)
typeToMemo memotup :: MemoMap
memotup@(MapTC (Dynamic, Dynamic)
memomap,(Dynamic, Dynamic)
memochar) Type
ty = case Int -> Type -> Maybe (Dynamic, Dynamic)
ttc Int
0 Type
ty of Maybe (Dynamic, Dynamic)
Nothing -> (Dynamic
dynI,Dynamic
dynI) -- メモできない場合．テストするときは取り合えず全部(dynI,dynI)にしてもいいかも．
                                                            Just (Dynamic, Dynamic)
t  -> (Dynamic, Dynamic)
t
    where ttc :: Int -> Type -> Maybe (Dynamic, Dynamic)
ttc Int
0 (Type
t:->Type
u) = Maybe (Dynamic, Dynamic)
forall a. Maybe a
Nothing
          ttc Int
0 (TV TyVar
_)  = (Dynamic, Dynamic) -> Maybe (Dynamic, Dynamic)
forall a. a -> Maybe a
Just (Dynamic, Dynamic)
memochar
          ttc Int
_ (TV TyVar
_)  = Maybe (Dynamic, Dynamic)
forall a. Maybe a
Nothing
          ttc Int
k (TC TyVar
tc) | TyVar
tc TyVar -> TyVar -> Bool
forall a. Ord a => a -> a -> Bool
< TyVar
0    = Maybe (Dynamic, Dynamic)
forall a. Maybe a
Nothing
                        | Bool
otherwise = do IntMap (Dynamic, Dynamic)
imap <- Int
-> MapTC (Dynamic, Dynamic) -> Maybe (IntMap (Dynamic, Dynamic))
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
k MapTC (Dynamic, Dynamic)
memomap
                                         Int -> IntMap (Dynamic, Dynamic) -> Maybe (Dynamic, Dynamic)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup (TyVar -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral TyVar
tc) IntMap (Dynamic, Dynamic)
imap
          ttc Int
k (TA Type
t0 Type
t1) = do (Dynamic
m0,Dynamic
a0) <- Int -> Type -> Maybe (Dynamic, Dynamic)
ttc (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Type
t0
                                (Dynamic
m1,Dynamic
a1) <- Int -> Type -> Maybe (Dynamic, Dynamic)
ttc Int
0     Type
t1
                                (Dynamic, Dynamic) -> Maybe (Dynamic, Dynamic)
forall (m :: * -> *) a. Monad m => a -> m a
return (Dynamic -> Dynamic -> Dynamic
dynApp Dynamic
m0 Dynamic
m1, Dynamic -> Dynamic -> Dynamic
dynApp Dynamic
a0 Dynamic
a1)
          ttc Int
_ Type
_          = Maybe (Dynamic, Dynamic)
forall a. Maybe a
Nothing
-- Test.QuickCheck.GenはRandom.StdGen限定で，それ以外のRandomGen g => gではダメみたい．
-- Test.QuickCheck.generateの定義がちょっと変だと思う．usableだとは思うけど．

type Arb a = Generator -> [a]

arbitrariesByDyn :: TyConLib -> Dynamic -> Arb Dynamic
arbitrariesByDyn :: TyConLib -> Dynamic -> Arb Dynamic
arbitrariesByDyn TyConLib
tcl Dynamic
arb = TyConLib -> Dynamic -> Int -> Arb Dynamic
arbsByDyn TyConLib
tcl Dynamic
arb Int
0
arbsByDyn :: TyConLib -> Dynamic -> Int -> Generator -> [Dynamic]
arbsByDyn :: TyConLib -> Dynamic -> Int -> Arb Dynamic
arbsByDyn TyConLib
tcl Dynamic
arbDyn Int
depth Generator
stdgen = (Int -> Generator -> Dynamic) -> [Int] -> [Generator] -> [Dynamic]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (TyConLib -> Dynamic -> Int -> Generator -> Dynamic
genAppDyn TyConLib
tcl Dynamic
arbDyn) [Int
depth..] (Generator -> [Generator]
forall t. RandomGen t => t -> [t]
gens Generator
stdgen)

genAppDyn :: TyConLib -> Dynamic -> Int -> Generator -> Dynamic
genAppDyn :: TyConLib -> Dynamic -> Int -> Generator -> Dynamic
genAppDyn TyConLib
tcl Dynamic
arbDyn Int
size Generator
stdgen = Dynamic -> Dynamic -> Dynamic
dynApp $(dynamic [|tcl|] [| (\(Gen f) -> f size stdgen) :: Gen a -> a |] ) Dynamic
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 :: [Int] -> TyConLib -> Dynamic -> Generator -> [[Dynamic]]
arbitrariessByDyn [Int]
nrnds TyConLib
tcl Dynamic
arb Generator
gen = [Int] -> TyConLib -> Dynamic -> Int -> Generator -> [[Dynamic]]
abd [Int]
nrnds TyConLib
tcl Dynamic
arb Int
0 Generator
gen
-- abd _ _ arb depth gen = zipWith (arbsByDyn arb) [depth..] (gens gen) -- 乱数サイズを小さい値から増やしていく場合
abd :: [Int] -> TyConLib -> Dynamic -> Int -> Generator -> [[Dynamic]]
abd [Int]
nrnds TyConLib
tcl Dynamic
arb Int
depth Generator
gen = (Int -> Arb Dynamic) -> [Int] -> [Generator] -> [[Dynamic]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ([Int] -> TyConLib -> Dynamic -> Int -> Arb Dynamic
arbsByDyn' [Int]
nrnds TyConLib
tcl Dynamic
arb) [Int
depth..] (Generator -> [Generator]
forall t. RandomGen t => t -> [t]
gens Generator
gen) -- 乱数サイズを一定にする場合
arbsByDyn' :: [Int] -> TyConLib -> Dynamic -> Int -> Arb Dynamic
arbsByDyn' [Int]
nrnds TyConLib
tcl Dynamic
arbDyn Int
depth Generator
stdgen = (Generator -> Dynamic) -> [Generator] -> [Dynamic]
forall a b. (a -> b) -> [a] -> [b]
map (TyConLib -> Dynamic -> Int -> Generator -> Dynamic
genAppDyn TyConLib
tcl Dynamic
arbDyn Int
size) (Generator -> [Generator]
forall t. RandomGen t => t -> [t]
gens Generator
stdgen)
    where size :: Int
size = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
depth ([Int]
nrnds [Int] -> Int -> Int
forall a. [a] -> Int -> a
!! Int
depth)
#ifdef TFRANDOM
gens gen = case map (splitn gen 8) [0..255] of g0:gs -> gs ++ gens g0
#else
gens :: t -> [t]
gens t
gen = case t -> (t, t)
forall g. RandomGen g => g -> (g, g)
split t
gen of (t
g0,t
g1) -> t
g0 t -> [t] -> [t]
forall a. a -> [a] -> [a]
: t -> [t]
gens t
g1
#endif