-- 
-- (c) Susumu Katayama 2009
--

\begin{code}
-- # prune

-- prune is supposed to prevent haddock from chasing imports, but seemingly it does not work.

{-# OPTIONS -fglasgow-exts -XTemplateHaskell  -cpp #-}
module MagicHaskeller(
       -- * Re-exported modules
       -- | This library implicitly re-exports the entities from
       --   @module Language.Haskell.TH as TH@ and @module Data.Typeable@ from the Standard Hierarchical Library of Haskell.
       --   Please refer to their documentations on types from them --- in this documentation, types from TH are all qualified and the only type used from @module Typeable@ is Typeable.Typeable. Other types you had never seen should be our internal representation.
       module TH, module Typeable,

       -- * Setting up your synthesis
       -- | Before synthesis, you have to define at least one program generator algorithm (or you may define one once and reuse it for later syntheses).
       --   Other parameters are memoization depth and time out interval, which have default values.
       --   You may elect either to set those values to the \'global variables\' using \'@set@*\' functions (i.e. functions whose names are prefixed by @set@), or hand them explicitly as parameters.

       -- ** Class for program generator algorithms
       -- | Please note that @ConstrL@ and @ConstrLSF@ are obsoleted and users are expected to use the 'constrL' option in 'Option'.
       ProgramGenerator,
       ProgGen, ProgGenSF, ProgGenXF,

       -- ** Functions for creating your program generator algorithm
       -- | You can set your primitives like, e.g., @'setPrimitives' $('p' [| ( (+) :: Int->Int->Int, 0 :: Int, \'A\', [] :: [a] ) |])@,
       --   where the primitive set is consisted of @(+)@ specialized to type @Int->Int->Int@, @0@ specialized to type @Int@, 
       --   @ \'A\' @ which has monomorphic type @Char@, and @[]@ with polymorphic type @[a]@.
       --   As primitive components one can include any variables and constructors within the scope. 
       --   However, because currently ad hoc polymorphism is not supported by this library, you may not write
       --   @'setPrimitives' $('p' [| (+) :: Num a => a->a->a |])@.
       --   Also, you have to specify the type unless you are using a primitive component whose type is monomorphic and instance of 'Data.Typeable.Typeable'
       --   (just like when using the dynamic expression of Concurrent Clean), and thus
       --   you may write @'setPrimitives' $('p' [| \'A\' |])@,
       --   while you have to write @'setPrimitives' $('p' [| [] :: [a] |])@ instead of @'setPrimitives' $('p' [| [] |])@.
       p, setPrimitives, mkPG, mkPGSF, setPG,
       --   'mkPG' and 'setPG' used to be called @mkMemo@ and @setMemo@ respectively (because the main ingredient of a program generator is a memoization table). というコメントはそぐわなくなってきたので止める．

       -- | Older versions prohibited data types holding functions such as @[a->b]@, @(Int->Char, Bool)@, etc. just for efficiency reasons.
       --   They are still available if you use 'mkMemo' and 'mkMemoSF' instead of 'mkPG' and 'mkPGSF' respectively, though actually this limitation does not affect the efficiency a lot.
       --   (NB: recently I noticed that use of 'mkMemo' or 'mkMemoSF' might not improve the efficiency of generating lambda terms at all, though when I generated combinatory expressions it WAS necessary.
       --   In fact, I mistakenly turned this limitation off, and 'mkMemo' and 'mkMemoSF' were equivalent to 'mkPG' and 'mkPGSF', but I did not notice that....)
       mkMemo, mkMemoSF,

       -- | @mkMemo075@ enables some more old good optimization options used until Version 0.7.5, including guess on the primitive functions.
       --   It is for you if you prefer speed, but the result can be non-exhaustive if you use it with your own LibTH.hs.
       --   Also, you need to use the prefixed |(->)| in order for the options to take effect. See LibTH.hs for examples.
       mkPG075, mkMemo075,

       -- | 'mkPGOpt' can be used along with its friends instead of 'mkPG' when the search should be fine-tuned.
       mkPGOpt, Options, Opt(..), options,

#ifdef HASKELLSRC
       -- ***  Alternative way to create your program generator algorithm
       -- | 'load', 'loadPrimitives', and 'loadPG' provides an alternative scheme to create program generator algorithms.
       --   (But most likely they will become obsolete....)
       load, loadPrimitives, loadPG,
#endif

       -- ** Memoization depth
       setDepth,

       -- ** Time out
       -- | NB: 'setTimeout' and 'unsetTimeout' will be obsoleted. They are provided for backward compatibility, but
       --   not exactly compatible with the old ones in that their results will not affect the behavior of 'everything', etc., which explicitly take a 'ProgramGenerator' as an argument.
       --   Also, in the current implementation, the result of 'setTimeout' and 'unsetTimeout' will be overwritten by setPrimitives.
       --   Use 'timeout' option instead.
       --
       --   Because the library generates all the expressions including those with non-linear recursions, you should note that there exist some expressions which take extraordinarily long time. (Imagine a function that takes an integer n and increments 0 for 2^(2^n) times.)
       --   For this reason, time out is taken after 0.02
       --   second since each invocation of evaluation by default. This default behavior can 
       --   be overridden by the following functions.
       setTimeout, unsetTimeout,

       -- ** Defining functions automatically
       -- | In this case \"automatically\" does not mean \"inductively\" but \"deductively using Template Haskell\";)
       define, Everything, Filter, Every,

       -- * Generating programs
       -- | (There are many variants, but most of the functions here just filter 'everything' with the predicates you provide.)
       --
       --   Functions suffixed with \"F\" (like 'everythingF', etc.) are filtered versions, where their results are filtered to totally remove semantic duplications. In general they are equivalent to applying 'everyF' afterwards.
       --   (Note that this is filtration AFTER the program generation, unlike the filtration by using 'ProgGenSF' is done DURING program generation.)

       -- ** Quick start
       findOne, printOne, printAny,

       -- ** Incremental filtration
       -- | Sometimes you may want to filter further after synthesis, because the predicate you previously provided did not specify
       --   the function enough. The following functions can be used to filter expressions incrementally.
       filterFirst, filterFirstF, filterThen, filterThenF,

       -- ** Expression generators
       -- | These functions generate all the expressions that have the type you provide.
       getEverything, everything, everythingM, unifyable, matching, getEverythingF, everythingF, unifyableF, matchingF,

       -- ** Utility to filter out equivalent expressions
       everyF,

       -- ** Pretty printers
       pprs, printQ,

       -- * Internal data representation
       -- | The following types are assigned to our internal data representations.
       Primitive, HValue(HV),

       -- other stuff which will not be documented by Haddock
       unsafeCoerce#, {- unifyablePos, -} exprToTHExp, trToTHType -- , specializedPossi
#ifdef HASKELLSRC
       , module Language.Haskell.Syntax -- , pprintType
#endif
      ) where

import Data.Generics(everywhere, mkT, Data)

import Data.Array.IArray
import MagicHaskeller.CoreLang(CoreExpr(..), HValue(..), exprToTHExp, VarLib)
import Language.Haskell.TH as TH
#ifdef HASKELLSRC
import Language.Haskell.Syntax
import Language.Haskell.Pretty
import ReadType
#endif
import MagicHaskeller.TyConLib
import qualified Data.Map as Map
import Data.Char

import MagicHaskeller.Types as Types

import MagicHaskeller.ProgGen(ProgGen(PG))
import MagicHaskeller.ProgGenSF(ProgGenSF, PGSF)
-- import MagicHaskeller.ProgGenLF(ProgGenLF)
import MagicHaskeller.ProgGenXF(ProgGenXF)
import MagicHaskeller.ProgramGenerator
import Control.Monad.Search.Combinatorial -- This should all be exposed?
import Data.Typeable as Typeable
import System.IO.Unsafe(unsafePerformIO)
import Data.IORef
import GHC.Exts(unsafeCoerce#)
-- import Maybe(fromJust)
import System.IO
import System.Random(mkStdGen,StdGen)
import MagicHaskeller.MHTH

import MagicHaskeller.ReadTHType
import MagicHaskeller.ReadTypeRep(trToType, trToTHType)
import MagicHaskeller.MyDynamic
import MagicHaskeller.Expression
import MagicHaskeller.Classify
import MagicHaskeller.Classification(unsafeRandomTestFilter, Filtrable)
import MagicHaskeller.Instantiate(mkRandTrie)

\end{code}

\begin{code}

-- "MemoDeb" name should be hidden, or maybe I could rename it.

type Primitive = (HValue, TH.Exp, TH.Type)

-- | 'define' eases use of this library by automating some function definitions. For example, 
--
-- > $( define ''ProgGen "Foo" 15 (p [| (1 :: Int, (+) :: Int -> Int -> Int) |]) )
--
-- is equivalent to 
--
-- > memoFoo :: ProgGen
-- > memoFoo = mkPG (p [| (1 :: Int, (+) :: Int -> Int -> Int) |])
-- > everyFoo :: Everything
-- > everyFoo = everything 15 memoFoo
-- > filterFoo :: Filter
-- > filterFoo pred = filterThen pred everyFoo
--
-- If you do not think this function reduces the number of your keystrokes a lot, you can do without it.
define   :: TH.Name -> String -> Integer -> TH.ExpQ -> TH.Q [TH.Dec]
define mn name depth pq = pq >>= \prims ->
                              return [ SigD (mkName ("memo"++name)) (ConT mn),
                                       ValD (VarP (mkName ("memo"++name))) (NormalB (AppE (VarE (mkName "mkPG")) prims -- (VarE (mkName "prims"))
														   )) [],
                                       SigD (mkName ("every"++name)) (ConT (mkName "Everything")),
                                       ValD (VarP (mkName ("every"++name))) (NormalB ((VarE (mkName "everything")  `AppE` LitE (IntegerL depth)) `AppE` VarE (mkName ("memo"++name)))) [],
                                       SigD (mkName ("filter"++name)) (ConT (mkName "Filter")),
                                       ValD (VarP (mkName ("filter"++name))) (NormalB ((VarE (mkName "flip")  `AppE` VarE (mkName "filterThen")) `AppE` VarE (mkName ("every"++name)))) [] ]
type Every a    = [[(TH.Exp,a)]]
type Everything = Typeable a => Every a
type Filter     = Typeable a => (a->Bool) -> IO (Every a)

{- Because the left hand side is not TH.Exp, we cannot splice directly there.
initialize name depth prims = [d| { $(return (VarE (mkName ("memo"++name)))) = mkPG $prims;
                                    $(return (VarE (mkName ("every"++name)))) :: Everything;
                                    $(return (VarE (mkName ("every"++name)))) = everything $(return (LitE (NumL depth))) $(return (VarE (mkName ("memo"++name)))); } |]
-}

{- It is unlikely that mkMTH will ever be used, and seemingly my version of haddock dislikes TH.
-- One could write, for example, $(mkMTH $15 [| ( 0::Int, succ, nat_para, [] ) |] ),
-- but I am not sure if this style using mkMTH will ever be used.
mkMTH :: TH.ExpQ -> TH.ExpQ -> TH.ExpQ
mkMTH n leq = [| mkMD $n $(m leq) |]
-}

-- Rather, one could write, e.g.,
-- mkMD 15 $(p [|  ( 0::Int, succ::Int->Int, nat_para, [] :: [a])  |] )

-- | 'p' is used to convert your primitive component set into the internal form.
p :: TH.ExpQ -- ^ Quasi-quote a tuple of primitive components here.
     -> TH.ExpQ -- ^ This becomes @[Primitive]@ when spliced.
p eq = eq >>= \e -> case e of TupE es -> (return . ListE) =<< (mapM p' es)
                              _       -> (return . ListE . return) =<< p' e      -- This default pattern should also be defined, because it takes two (or more) to tuple!
p' :: TH.Exp -> TH.ExpQ
p' se@(SigE e ty) = do ee <- expToExpExp e
                       et <- typeToExpType ty
                       return $ TupE [ AppE (ConE (mkName "HV")) (AppE (VarE (mkName "unsafeCoerce#")) se), ee, et]
p' e              = do ee <- expToExpExp e
                       return $ TupE [ AppE (ConE (mkName "HV")) (AppE (VarE (mkName "unsafeCoerce#")) e),  ee, AppE (VarE (mkName "trToTHType")) (AppE (VarE (mkName "typeOf")) e)]

-- nameToExpName :: TH.Name -> TH.Exp
-- nameToExpName = strToExpName . showName
-- strToExpName str = AppE (VarE (mkName "mkName")) (LitE (StringL str))

{- not used any longer
{- This should work in theory, but Language.Haskell.TH.pprint has a bug and it does not print parentheses....
pprintType (ForallT _ _ ty) = pprint ty
pprintType ty               = pprint ty
-}
-- 'pprintType' is a workaround for the problem that @Language.Haskell.TH.pprint :: Type -> String@ does not print parentheses correctly.
-- (try @Language.Haskell.TH.runQ [t| (Int->Int)->Int |] >>= \e -> putStrLn (pprint e)@ in your copy of GHCi.)
-- The implementation here is not so pretty, but that's OK for my purposes. Also note that 'pprintType' ignores foralls.
pprintType (ForallT _ [] ty) = pprintType ty
pprintType (ForallT _ _  ty) = error "Type classes are not supported yet. Sorry...."
pprintType (VarT name)      = pprint name
pprintType (ConT name)      = pprint name
pprintType (TupleT n)       = tuplename n
pprintType ArrowT           = "(->)"
pprintType ListT            = "[]"
pprintType (AppT t u)       = '(' : pprintType t ++ ' ' : pprintType u ++ ")"
-- The problem of @Language.Haskell.TH.pprint :: Type -> String@ is now fixed at the darcs HEAD.
-}

primitivesp :: TyConLib -> [Primitive] -> [Typed [CoreExpr]]
primitivesp tcl ps
    = zipWith (\ n (_,_,ty) -> [Primitive n] ::: thTypeToType tcl ty) [0..] ps
primitivesToVL :: TyConLib -> [Primitive] -> VarLib
primitivesToVL tcl ps
    = listArray (0, length ps - 1) $ map (\ (HV x, e, ty) -> (e, unsafeToDyn tcl (thTypeToType tcl ty) x e)) ps

{-
mkPG :: Int -- ^ memoization depth. (Sub)expressions within this size are memoized, while greater expressions will be recomputed (to save the heap space).
         -> [Primitive] -> (Int, Memo)
mkPG n tups = (n, mkPG' tups)
-}

mkPG :: ProgramGenerator pg => [Primitive] -> pg
mkPG   = mkPG' True
-- ^ 'mkPG' is defined as:
--
-- > mkPG prims = mkPGSF (mkStdGen 123456) (repeat 5) prims prims

mkMemo :: ProgramGenerator pg => [Primitive] -> pg
mkMemo = mkPG' False
mkPG' cont tups = case mkCommon options{contain=cont} tups of cmn -> mkTrie cmn (primitivesp (tcl cmn) tups)

-- | 'mkPGSF' and 'mkMemoSF' are provided mainly for backward compatibility. These functions are defined only for the 'ProgramGenerator's whose names end with @SF@ (i.e., generators with synergetic filtration).
--   For such generators, they are defined as:
--
-- > mkPGSF   gen nrnds optups tups = mkPGOpt (options{primopt = Just optups, contain = True,  stdgen = gen, nrands = nrnds}) tups
-- > mkMemoSF gen nrnds optups tups = mkPGOpt (options{primopt = Just optups, contain = False, stdgen = gen, nrands = nrnds}) tups

mkPGSF,mkMemoSF :: ProgramGenerator pg =>
           StdGen
        -> [Int] -- ^ number of random samples at each depth, for each type.
        -> [Primitive] 
        -> [Primitive] -> pg
mkPGSF   = mkPGSF' True
mkMemoSF = mkPGSF' False
mkPGSF' cont gen nrnds optups tups = mkPGOpt (options{primopt = Just optups, contain = cont, stdgen = gen, nrands = nrnds}) tups
--   Currently only the pg==ConstrLSF case makes sense. ってのは，optupsのみに関する話で，rndsは関係ない．

mkPG075 :: ProgramGenerator pg => [Primitive] -> pg
mkPG075 = mkPGOpt (options{primopt = Nothing, contain = True, guess = True})
mkMemo075 :: ProgramGenerator pg => [Primitive] -> pg
mkMemo075 = mkPGOpt (options{primopt = Nothing, contain = False, guess = True})

mkPGOpt :: ProgramGenerator pg => Options -> [Primitive] -> pg
mkPGOpt opt prims = case mkCommon opt prims of cmn -> mkTrieOpt cmn (primitivesp (tcl cmn) primsOpt) (primitivesp (tcl cmn) prims)
    where primsOpt   = case primopt opt of Nothing -> prims
                                           Just po -> po

-- this can be moved to somewhere near Common is defined (currently ProgramGenerator.lhs), when 'Primitive' is moved to some more adequate place.
-- 実際ProgramGenerator.lhsでPrimitiveを扱えればもっと単純化できるはず．
mkCommon :: Options -> [Primitive] -> Common
mkCommon opts prims = let (_, _, ts) = unzip3 prims
                          tyconlib = thTypesToTCL ts
                          optunit  = forget opts
                      in Cmn {opt = optunit, tcl = tyconlib, vl = primitivesToVL tyconlib prims, rt = mkRandTrie (nrands opts) tyconlib (stdgen opts)}

-- | options for limiting the hypothesis space.
type Options = Opt [Primitive]

forget :: Opt a -> Opt ()
forget opt = case primopt opt of Nothing -> opt{primopt = Nothing}
                                 Just _  -> opt{primopt = Just ()}

setPG :: ProgGen -> IO ()
setPG = writeIORef refmemodeb

-- | @setPrimitives@ creates a @ProgGen@ from the given set of primitives using the current set of options, and sets it as the current program generator. 
--   It used to be equivalent to @setPG . mkPG@ which overwrites the options with the default, but it is not now.
setPrimitives :: [Primitive] -> IO ()
setPrimitives tups = do PG (x,y,cmn) <- readIORef refmemodeb
                        setPG $ mkPGOpt ((opt cmn){primopt=Nothing}) tups
-- setPrimitives tups = writeIORef refmemodeb (mkPG tups) -- This definition overwrites the old configuration.

#ifdef HASKELLSRC
-- | 'load' loads a component library file.
load :: FilePath
     -> TH.ExpQ     -- ^ This becomes @([[HValue]], String)@ when spliced.
load fp = do str <- runIO $ readFile fp
	     f str
-- | f is supposed to be used by load, but not hidden.
f :: String -> TH.ExpQ
f str = return (TupE [ f' $ readHsDecls (str++"\n"), LitE (StringL str)])
f' :: [HsDecl] -> TH.Exp
f' decls =  ListE [ ListE $ map (\e -> AppE (ConE (mkName "HV")) (AppE (VarE (mkName "unsafeCoerce#")) (VarE (mkName (hsNameToName e))))) hsnames |
                    HsTypeSig _loc hsnames hsqt@(HsQualType _context hsty) <- decls ]

primitives :: [[HValue]] -> TyConLib -> [HsDecl] -> [Typed [CoreExpr]]
primitives cnl tcl decls
    = zipWith (\ (exps,ty) hvs -> zipWith (\ e (HV x) -> Primitive e (unsafeToDyn tcl ty x e)) exps hvs ::: ty)
	      [ (map (VarE . mkName . hsNameToName) hsnames, hsTypeToType tcl hsty) | HsTypeSig _loc hsnames hsqt@(HsQualType _context hsty) <- decls ]
	      cnl

{- I once thought the following definition would be better, but on the second thought I was bothered because loadPG will become obsolete....
loadPG :: Int      -- ^ memoization depth
         -> FilePath
         -> TH.ExpQ     -- ^ This becomes 'Memo' when spliced.
loadPG n str = [| loadPG' n 
-}
loadPG :: ProgramGenerator a => ([[HValue]], String) -> a
loadPG (cnl, str) = mkTrie tcl (primitives cnl tcl hsdecls)
    where tcl     = extractTyConLib hsdecls
          hsdecls = readHsDecls str

loadPrimitives :: ([[HValue]], String) -> IO ()
loadPrimitives tup = writeIORef refmemodeb (loadPG tup)
#endif


-- | 'setTimeout' sets the timeout in microseconds. Also, my implementation of timeout also catches inevitable exceptions like stack space overflow. Note that setting timeout makes the library referentially untransparent. (But currently @setTimeout 20000@ is the default!)
setTimeout :: Int -- ^ time in microseconds
              -> IO ()
setTimeout n = do pto <- newPTO n
                  PG (x,y,cmn) <- readIORef refmemodeb
                  writeIORef refmemodeb $ PG (x,y,cmn{opt = (opt cmn){timeout=Just pto}})
-- | 'unsetTimeout' disables timeout. This is the safe choice.
unsetTimeout :: IO ()
unsetTimeout = do PG (x,y,cmn) <- readIORef refmemodeb
                  writeIORef refmemodeb $ PG (x,y,cmn{opt = (opt cmn){timeout=Nothing}})
{-# NOINLINE refdepth #-}
refdepth :: IORef Int
refdepth = unsafePerformIO (newIORef defaultDepth)
defaultDepth = 10

setDepth :: Int -- ^ memoization depth. (Sub)expressions within this size are memoized, while greater expressions will be recomputed (to save the heap space).
         -> IO ()
setDepth d = writeIORef refdepth d
-- ^ Currently the default depth is 10. You may want to lower the value if your computer often swaps, or increase it if you have a lot of memory.

{-# NOINLINE refmemodeb #-}
refmemodeb :: IORef ProgGen
refmemodeb = unsafePerformIO (newIORef defaultMD)
defaultMD = mkPG [] :: ProgGen

trsToTCL :: [TypeRep] -> TyConLib -- ReadType.extractTyConLib :: [HsDecl] -> TyConLibを参考にできる． -- この2行と
trsToTCL trs
    = (Map.fromListWith (\new old -> old) [ tup | k <- [0..7], tup <- tcsByK ! k ], tcsByK)
    where tnsByK :: Array Kind [TypeName]
	  tnsByK = accumArray (flip (:)) [] (0,7) ( trsToTCstrs trs )   -- ここを変えた．
	  tcsByK :: Array Kind [(TypeName,Types.TyCon)]
	  tcsByK = listArray (0,7) [ tnsToTCs (tnsByK ! k) | k <- [0..7] ]
	  tnsToTCs :: [TypeName] -> [(TypeName,Types.TyCon)]
	  tnsToTCs tns = zipWith (\ i tn -> (tn, i)) [0..] tns
-- x 実際には(->)はTyCon扱いにはしないんだけど，ほんのちょっとだけ無駄になるだけなのでいいでしょ．

trsToTCstrs :: [TypeRep] -> [(Int, String)] -- Int is the arity of the TyCon. There can be duplicates.
trsToTCstrs [] = []
trsToTCstrs (tr:ts) = case splitTyConApp tr of (tc,trs) -> (length trs, tyConString tc) : trsToTCstrs (trs++ts)


-- MemoやgetEverything自体はIORefを使わずにIOなしで実装できる訳で，その意味では，IORefを使わない方がいいかも．
-- x ついでにいうと，1秒でのタイムアウトを表すPTO（のGLOBAL_VAR）もIOなしで用意できる．（unsafePerformIO使うけど）

-- | 'getEverything' uses the \'global\' values set with @set*@ functions. 'getEverythingF' is its filtered version
getEverything :: Typeable a => IO (Every a)
getEverything = do depth <- readIORef refdepth
                   memodeb <- readIORef refmemodeb
                   return (everything depth memodeb)
getEverythingF :: Typeable a => IO (Every a)
getEverythingF =do depth <- readIORef refdepth
                   memodeb <- readIORef refmemodeb
                   return (everythingF depth memodeb)
{-
getEverything = result
    where ty = typeOf $ snd $ head $ head $ unsafePerformIO result
          result = do memodeb@(trie,prims,depth,tcl) <- readIORef refmemodeb
                      return $ unMx $ toMx (fmap (\ e -> (exprToTHExp (error "unknown conlib") e, unsafeExecute e)) (matchingPrograms (trToType tcl ty) memodeb))
-}

-- | 'everything' generates all the expressions that fit the inferred type, and their representations in the 'TH.Exp' form.
--   It returns a stream of lists, which is equivalent to Spivey's @Matrix@ data type, i.e., that contains expressions consisted of n primitive components at the n-th element (n = 1,2,...).
--   'everythingF' is its filtered version
everything, everythingF :: (ProgramGenerator pg, Typeable a) =>
                     Int  -- ^ memoization depth. 
                  -> pg   -- ^ program generator
                  -> Every a
everything  memodepth memodeb = et undefined memodepth memodeb (mxExprToEvery   "MagicHaskeller.everything: type mismatch" memodeb)
everythingF memodepth memodeb = et undefined memodepth memodeb (mxExprFiltEvery "MagicHaskeller.everythingF: type mismatch" memodeb)
et :: (ProgramGenerator pg, Typeable a) =>
                     a    -- ^ dummy argument
                  -> Int  -- ^ memoization depth.
                  -> pg   -- ^ program generator
                  -> (Types.Type -> Matrix AnnExpr -> Matrix (Exp, a))
                  -> Every a
et dmy memodepth memodeb filt = unMx $ filt ty $ matchingPrograms ty (memodepth,memodeb)
    where ty = trToType (extractTCL memodeb) (typeOf dmy)
noFilter :: ProgramGenerator pg => pg -> Types.Type -> a -> a
noFilter _m _t = id

mxExprToEvery :: (Expression e, Search m, ProgramGenerator pg, Typeable a) => String -> pg -> Types.Type -> m e -> m (Exp, a)
mxExprToEvery   msg memodeb _  = fmap (unwrapAE msg memodeb . toAnnExpr (reducer memodeb))
mxExprFiltEvery :: (Expression e, FiltrableBF m, ProgramGenerator pg, Typeable a) => String -> pg -> Types.Type -> m e -> m (Exp, a)
mxExprFiltEvery msg memodeb ty = fmap (unwrapAE msg memodeb) . randomTestFilter memodeb ty . fmap (toAnnExpr (reducer memodeb))

unwrapAE :: (ProgramGenerator pg, Typeable a) => String -> pg -> AnnExpr -> (Exp, a)
unwrapAE msg memodeb (AE e dyn) = (exprToTHExp (extractVL memodeb) e, fromDyn tcl dyn (error msg))
    where tcl = extractTCL memodeb

{-
無限リストを使うなら，unsafeInterleaveIOが必要なはず．その場合IOに特化することになる．
-}
everythingM :: (ProgramGenerator pg, Typeable a, Monad m, Functor m) =>
                     Int  -- ^ memoization depth. 
                  -> pg   -- ^ program generator
                  -> Int  -- ^ query depth
                  -> m [(TH.Exp, a)]
everythingM = eM undefined
eM :: (ProgramGenerator pg, Typeable a, Monad m, Functor m) =>
                     a    -- ^ dummy argument
                  -> Int  -- ^ memoization depth. 
                  -> pg   -- ^ program generator
                  -> Int
                  -> m [(TH.Exp, a)]
eM dmy memodepth memodeb = result
    where tcl = extractTCL memodeb
          ty  = trToType tcl $ typeOf dmy
          result = unRcT $ mxExprToEvery "MagicHaskeller.everythingM: type mismatch" memodeb undefined $ matchingPrograms ty (memodepth,memodeb)

strip :: m (Every a) -> a
strip = undefined

unifyable, matching, unifyableF, matchingF :: ProgramGenerator pg =>
                                              Int -- ^ memoization depth
                                              -> pg  -- ^ program generator
                                              -> TH.Type -- ^ query type
                                              -> [[TH.Exp]]
-- ^ Those functions are like 'everything', but take 'TH.Type' as an argument, which may be polymorphic.
--   For example, @'printQ' ([t| forall a. a->a->a |] >>= return . 'unifyable' True 10 memo)@ will print all the expressions using @memo@ whose types unify with @forall a. a->a->a@.
--   (At first I (Susumu) could not find usefulness in finding unifyable expressions, but seemingly Hoogle does something alike, and these functions might enhance it.)
unifyable memodepth memodeb tht =  unMx $ genExps noFilter unifyingPrograms memodepth memodeb tht
matching  memodepth memodeb tht =  unMx $ genExps noFilter matchingPrograms memodepth memodeb tht
-- unifyablePos memodepth memodeb tht = unMx $ toMx $ fmap (\(es,subst,mx) -> (map (pprintUC . exprToTHExp (extractVL memodeb)) es, subst, mx)) $ unifyingPossibilities (thTypeToType (extractTCL memodeb) tht) (memodepth,memodeb)
unifyableF memodepth memodeb tht = unMx $ genExps randomTestFilter unifyingPrograms memodepth memodeb tht
matchingF  memodepth memodeb tht = unMx $ genExps randomTestFilter matchingPrograms memodepth memodeb tht
genExps filt rawGenProgs memodepth memodeb tht
    = case thTypeToType (extractTCL memodeb) tht of
        ty -> fmap (exprToTHExp (extractVL memodeb) . toCE) $
              filt memodeb ty $ fmap (toAnnExpr (reducer memodeb)) (rawGenProgs ty (memodepth,memodeb))
--   Another advantage of these functions is that you do not need to define @instance Typeable@ for user defined types.
--   と思ったけど，GHCではderiving Typeableで簡単に定義できるし，Typeableが定義できない型なんてなさそう（deriving Typeableし忘れたdata typeを含むdataがそう？）

-- specializedPossi memodepth memodeb tht =  unMx $ toMx $ fmap show (specializedPossibleTypes (thTypeToType (extractTCL memodeb) tht) (memodepth,memodeb))

{-
wrappit :: (Search m, Functor m, Typeable a) => m CoreExpr -> [[(TH.Exp,a)]]
wrappit = unMx . toMx . fmap (\ e -> (exprToTHExp e, unsafeExecute e))
-}

-- | @'findOne' pred@ finds an expression 'e' that satisfies @pred e == True@, and returns it in 'TH.Exp'. 
findOne :: Typeable a => (a->Bool) -> TH.Exp
findOne pred = unsafePerformIO $ findDo (\e _ -> return e) pred

{- x 念のためやってみたけど，やっぱダメやね．てゆーか，Recompのままやって各深さで見る手はあるかも．
findAny :: Typeable a => (a->Bool) -> [TH.Exp]
findAny pred = unsafePerformIO $ findDo (\e r -> r >>= \es -> return (e:es)) pred
-}
-- | 'printOne' prints the expression found first. 
printOne :: Typeable a => (a->Bool) -> IO ()
printOne pred = do expr <- findDo (\e _ -> return e) pred
                   putStrLn $ pprintUC expr
-- | 'printAny' prints all the expressions satisfying the given predicate.
printAny :: Typeable a => (a->Bool) -> IO ()
printAny = findDo (\e r -> putStrLn (pprintUC e) >> r)

findDo :: Typeable a => (TH.Exp -> IO b -> IO b) -> (a->Bool) -> IO b
findDo op pred =  do et <- getEverything
                     md <- readIORef refmemodeb
                     let mpto = timeout $ opt $ extractCommon md
                     fp mpto (concat et)
    where fp mpto ((e,a):ts) = do -- hPutStrLn stderr ("trying" ++ pprintUC e)
                                  result <- maybeWithPTO seq (return (pred a)) mpto
                                  case result of Just True  -> e `op` fp mpto ts
                                                 Just False -> fp mpto ts
                                                 Nothing    -> hPutStrLn stderr ("timeout on "++pprintUC e) >> fp mpto ts
-- x 本当はrecompのままでやった方が速いはず．

-- | 'filterFirst' is like 'printAny', but by itself it does not print anything. Instead, it creates a stream of expressions represented in tuples of 'TH.Exp' and the expressions themselves. 
filterFirst :: Typeable a => (a->Bool) -> IO (Every a)
filterFirst pred = do et <- getEverything
                      filterThen pred et
-- randomTestFilter should be applied after filterThen, because it's slower
filterFirstF :: (Typeable a, Filtrable a) => (a->Bool) -> IO (Every a)
filterFirstF pred = do et <- getEverything
                       filterThenF pred et
filterThenF pred et = do
                       fd <- filterThen pred et
		       memodeb <- readIORef refmemodeb
                       let mpto = timeout $ opt $ extractCommon memodeb
	               return $ everyF mpto fd
{- refmemodeb にあるものが実際に使われているものとは限らない．refmemodebを使わないという選択もあるので．
filterFirstF pred = do et <- getEverything
                       filterThenF pred et
filterThenF pred ts = do
                       fd <- filterThen pred ts
		       let x=undefined
			   _=pred x
		       memodeb <- readIORef refmemodeb
	               return $ unMx $ randomTestFilter memodeb (getType memodeb x) $ Mx et
getType :: Typeable a => a -> ProgGen -> Types.Type
getType ty memodeb = trToType (extractTCL memodeb) (typeOf ty)
-}
everyF :: (Typeable a, Filtrable a) =>
          Maybe Int -- ^ microsecs until timeout
              -> Every a -> Every a
everyF mto = unMx . unsafeRandomTestFilter mto . Mx 

-- | 'filterThen' may be used to further filter the results.
filterThen :: Typeable a => (a->Bool) -> Every a -> IO (Every a)
filterThen pred ts = do md <- readIORef refmemodeb
                        let mpto = timeout $ opt $ extractCommon md
                        return (map (fp mpto) ts)
    where fp _    []            = []
          fp mpto (ea@(e,a):ts) = case unsafePerformIO (maybeWithPTO seq (return (pred a)) mpto) of
                                    Just True -> ea : fp mpto ts
                                    _         -> fp mpto ts
{- if not doing timeout
filterThen pred ts = return (map fp ts)
    where fp []            = []
          fp (ea@(e,a):ts) = case pred a of
                                    True -> ea : fp ts
                                    _         -> fp ts
-}
{- x いろいろやってみたけど，やっぱ表示と代入を一度にやるのは無理．





... てゆーか，

System.IO.Unsafe.unsafeInterleaveIO :: IO a -> IO a
を使えばいいはず．




filterThen pred ts = do mpto <- readIORef refpto
                        return (fp mpto ts)
    where fp mpto (ea@(e,a):ts) = if unsafePerformIO (do mb <- maybeWithPTO (return (pred a)) mpto
                                                         case mb of Just True -> do putStrLn $ pprintUC e
                                                                                    return True
                                                                    _         -> return False)
                                  then ea : fp mpto ts
                                  else fp mpto ts
-}
{-
filterThen pred ts = do mpto <- readIORef refpto
                        fp mpto ts
    where fp mpto (ea@(e,a):ts) = do mb <- maybeWithPTO (return (pred a)) mpto
                                     case mb of Just True -> do putStrLn $ pprintUC e
                                                                rest <- fp mpto ts
                                                                return (ea:rest)
                                                _         -> fp mpto ts
-}
-- utility functions to pretty print the results
-- | 'pprs' pretty prints the results to the console, using 'pprintUC'
pprs :: Every a -> IO ()
pprs = mapM_ (putStrLn . pprintUC . fst) . concat
-- | 'pprintUC' is like 'Language.Haskell.TH.pprint', but unqualifies (:) before pprinting in order to avoid printing "GHC.Types.:" which GHCi does not accept and sometimes annoys when doing some demo.
pprintUC :: (Ppr a, Data a) => a -> String
pprintUC =  pprint . everywhere (mkT unqCons)
unqCons :: Name -> Name
unqCons n | show n == show '(:) = mkName ":" -- NB: n == '(:) would not work due to the definition of Eq Name.
          | otherwise           = n
printQ :: (Ppr a, Data a) => Q a -> IO ()
printQ q = runQ q >>= putStrLn . pprintUC

\end{code}
