-- 
-- (c) Susumu Katayama
--

\begin{code}

{-# LANGUAGE TemplateHaskell, CPP, MagicHash, Rank2Types #-}
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, ProgGenSFIORef,

       -- ** 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,

       -- | 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, 
       
       -- | 'mkPGX' and 'mkPGXOpt' can be used instead of 'mkPG' and 'mkPGOpt' if you want to prioritize the primitives. 
       --   They take a list of lists of primitives as an argument, whose first element is the list of primitives with the greatest priority, 
       --   second element the second greatest priority, and so on.
       mkPGX, mkPGXOpt,
       
       mkPGXOpts, mkPGXOptsExt, updatePGXOpts, updatePGXOptsFilt,
       Options, Opt(..), options, MemoType(..), dynamic,

       -- | These are versions for 'ProgramGeneratorIO'.
       mkPGIO, mkPGXOptIO,

#if defined HASKELLSRC || defined HASKELLSRCEXTS
       -- ***  Alternative way to create your program generator algorithm
       -- | 'load' and 'f' provides an alternative scheme to create program generator algorithms.
       load, f,
#endif

       -- ** Memoization depth
       -- | NB: 'setDepth' will be obsoleted. It is provided for backward compatibility, but
       --   not exactly compatible with the old one in that its result will not affect the behavior of 'everything', etc., which explicitly take a 'ProgramGenerator' as an argument.
       --   Also, in the current implementation, the result of 'setDepth' will be overwritten by setPrimitives.
       --   Use 'memodepth' option instead.
       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, EveryIO,

       -- * 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, printAll, printAllF, io2pred,

       -- ** 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, fp,

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

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

       -- ** Unility to get one value easily
       stripEvery,

       -- ** Pretty printers
       pprs, pprsIO, pprsIOn, lengths, lengthsIO, lengthsIOn, lengthsIOnLn, printQ,

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

#ifdef PAR
       fpartialParIO, mapParIO,
#endif
       -- other stuff which will not be documented by Haddock
       unsafeCoerce#, {- unifyablePos, -} exprToTHExp, trToTHType, printAny, p1, Filtrable, zipAppend, mapIO, fpIO, fIO, fpartial, fpartialIO, ftotalIO, etup, mkCurriedDecls, unJust, tup
      ) where

import Data.Generics(everywhere, mkT, Data)

import Data.Array.IArray
import MagicHaskeller.CoreLang
import Language.Haskell.TH as TH
#ifdef HASKELLSRC
import MagicHaskeller.ReadHsType(readHsTypeSigs)
#elif defined HASKELLSRCEXTS
import MagicHaskeller.ReadHsExtsType(readHsTypeSigs)
#endif
import MagicHaskeller.TyConLib
import qualified Data.Map as Map
import Data.Char
import Control.Monad(mplus)


import MagicHaskeller.Types as Types

import MagicHaskeller.T10(mergesortWithBy)

import MagicHaskeller.ProgGen(ProgGen(PG))
import MagicHaskeller.ProgGenSF(ProgGenSF, PGSF)
import MagicHaskeller.ProgGenSFIORef(ProgGenSFIORef, PGSFIOR)
-- import MagicHaskeller.ProgGenLF(ProgGenLF)
-- import MagicHaskeller.ProgGenXF(ProgGenXF)
import MagicHaskeller.ProgramGenerator
import MagicHaskeller.Options(Opt(..), options)
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 Data.Maybe(fromJust)
import System.IO
#ifdef TFRANDOM
import System.Random.TF(seedTFGen,TFGen)
#else
import System.Random(mkStdGen,StdGen)
#endif
import MagicHaskeller.MHTH
import MagicHaskeller.TimeOut

import MagicHaskeller.ReadTHType
import MagicHaskeller.ReadTypeRep(trToType, trToTHType)
import MagicHaskeller.MyDynamic
import qualified MagicHaskeller.PolyDynamic as PD
import MagicHaskeller.Expression
import MagicHaskeller.Classify
import MagicHaskeller.ClassifyDM(filterDM)
import MagicHaskeller.Classification(unsafeRandomTestFilter, Filtrable)
-- import MagicHaskeller.Instantiate(mkRandTrie)
import MagicHaskeller.MemoToFiles(MemoType(..))

import Data.List(genericLength, transpose)

-- import Control.Concurrent.ParallelIO(parallelInterleaved)
import MagicHaskeller.DebMT(interleaveActions)
#ifdef PAR
import Control.Monad.Par.IO
import Control.Monad.Par.Class
import Control.Monad.IO.Class(liftIO)
#endif

import Control.Concurrent.MVar
import Control.Concurrent

\end{code}

\begin{code}
#if __GLASGOW_HASKELL__ >= 810
tup :: [Exp] -> Exp
tup = [Maybe Exp] -> Exp
TupE ([Maybe Exp] -> Exp) -> ([Exp] -> [Maybe Exp]) -> [Exp] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp -> Maybe Exp) -> [Exp] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Maybe Exp
forall a. a -> Maybe a
Just
unJust :: Maybe a -> a
unJust = Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust
#else
tup = TupE
unJust = id
#endif

mkCurriedDecls :: String -> ExpQ -> ExpQ -> DecsQ
mkCurriedDecls :: String -> ExpQ -> ExpQ -> DecsQ
mkCurriedDecls String
tag ExpQ
funq ExpQ
eq = do Exp
e <- ExpQ
eq
                                Exp
fun <- ExpQ
funq
                                case Exp
e of TupE [Maybe Exp]
es -> ([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> DecsQ) -> Q [[Dec]] -> DecsQ
forall a b. (a -> b) -> a -> b
$ (Maybe Exp -> DecsQ) -> [Maybe Exp] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Exp -> Exp -> DecsQ
mcd Exp
fun(Exp -> DecsQ) -> (Maybe Exp -> Exp) -> Maybe Exp -> DecsQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Exp -> Exp
forall a. Maybe a -> a
unJust) [Maybe Exp]
es
                                          Exp
_       -> Exp -> Exp -> DecsQ
mcd Exp
fun Exp
e
   where mcd :: Exp -> Exp -> DecsQ
         mcd :: Exp -> Exp -> DecsQ
mcd Exp
fun v :: Exp
v@(VarE Name
name) = let nb :: String
nb = Name -> String
nameBase Name
name
                                 in [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return [Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP (Name -> Pat) -> Name -> Pat
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
nbString -> String -> String
forall a. [a] -> [a] -> [a]
++String
tag) (Exp -> Body
NormalB (Exp -> Exp -> Exp
AppE Exp
fun Exp
v)) []]
--   where mcd :: Exp -> DecsQ
--         mcd v@(VarE name) = let nb = nameBase name
--                             in [d| $(return $ VarP $ mkName $ nb++tag) = $(funq) $(return v) |]


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

-- | 'define' eases use of this library by automating some function definitions. For example, 
--
-- > $( define ''ProgGen "Foo" (p [| (1 :: Int, (+) :: Int -> Int -> Int) |]) )
--
-- is equivalent to 
--
-- > memoFoo :: ProgGen
-- > memoFoo = mkPG (p [| (1 :: Int, (+) :: Int -> Int -> Int) |])
-- > everyFoo :: Everything
-- > everyFoo = everything 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 -> TH.ExpQ -> TH.Q [TH.Dec]
define :: Name -> String -> ExpQ -> DecsQ
define Name
mn String
name ExpQ
pq = ExpQ
pq ExpQ -> (Exp -> DecsQ) -> DecsQ
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Exp
prims ->
                              [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return [ Name -> Type -> Dec
SigD (String -> Name
mkName (String
"memo"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
name)) (Name -> Type
ConT Name
mn),
                                       Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP (String -> Name
mkName (String
"memo"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
name))) (Exp -> Body
NormalB (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (String -> Name
mkName String
"mkPG")) Exp
prims -- (VarE (mkName "prims"))
                                                                                                                   )) [],
                                       Name -> Type -> Dec
SigD (String -> Name
mkName (String
"every"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
name)) (Name -> Type
ConT (String -> Name
mkName String
"Everything")),
                                       Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP (String -> Name
mkName (String
"every"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
name))) (Exp -> Body
NormalB (Name -> Exp
VarE (String -> Name
mkName String
"everything") Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE (String -> Name
mkName (String
"memo"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
name)))) [],
                                       Name -> Type -> Dec
SigD (String -> Name
mkName (String
"filter"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
name)) (Name -> Type
ConT (String -> Name
mkName String
"Filter")),
                                       Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP (String -> Name
mkName (String
"filter"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
name))) (Exp -> Body
NormalB ((Name -> Exp
VarE (String -> Name
mkName String
"flip")  Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE (String -> Name
mkName String
"filterThen")) Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE (String -> Name
mkName (String
"every"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
name)))) [] ]
type Every a    = [[(TH.Exp,a)]]
type EveryIO a  = Int  -- query depth
                  -> IO [(TH.Exp, a)]
type Everything = forall a. Typeable a => Every a
type Filter     = forall a. 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 -- ^ Quote a tuple of primitive components here.
     -> TH.ExpQ -- ^ This becomes @[Primitive]@ when spliced.
p :: ExpQ -> ExpQ
p ExpQ
eq = ExpQ
eq ExpQ -> (Exp -> ExpQ) -> ExpQ
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Exp
e -> case Exp
e of TupE [Maybe Exp]
es -> (Exp -> ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> ExpQ) -> ([Exp] -> Exp) -> [Exp] -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Exp] -> Exp
ListE) ([Exp] -> ExpQ) -> Q [Exp] -> ExpQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Maybe Exp -> ExpQ) -> [Maybe Exp] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Exp -> ExpQ
p1(Exp -> ExpQ) -> (Maybe Exp -> Exp) -> Maybe Exp -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Maybe Exp -> Exp
forall a. Maybe a -> a
unJust) [Maybe Exp]
es
                              Exp
_       -> (Exp -> ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> ExpQ) -> (Exp -> Exp) -> Exp -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Exp] -> Exp
ListE ([Exp] -> Exp) -> (Exp -> [Exp]) -> Exp -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> [Exp]
forall (m :: * -> *) a. Monad m => a -> m a
return) (Exp -> ExpQ) -> ExpQ -> ExpQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Exp -> ExpQ
p1 Exp
e      -- This default pattern should also be defined, because it takes two (or more) to tuple!
p1 :: TH.Exp -> TH.ExpQ
p1 :: Exp -> ExpQ
p1 (SigE Exp
e Type
ty) = Exp -> Exp -> Type -> ExpQ
p1' (Exp -> Type -> Exp
SigE Exp
e (Type -> Exp) -> Type -> Exp
forall a b. (a -> b) -> a -> b
$ Type -> Type
useArrowT Type
ty) Exp
e Type
ty
p1 e :: Exp
e@(ConE Name
name)  = do
#if __GLASGOW_HASKELL__ < 800
                       DataConI _ ty _ _ <- reify name
#else                                            
                       DataConI Name
_ Type
ty Name
_   <- Name -> Q Info
reify Name
name
#endif                                            
                       Exp -> Exp -> Type -> ExpQ
p1' Exp
e Exp
e Type
ty
p1 e :: Exp
e@(VarE Name
name)  = do
#if __GLASGOW_HASKELL__ < 800
                       VarI _ ty _ _ <- reify name
#else
                       VarI Name
_ Type
ty Maybe Dec
_   <- Name -> Q Info
reify Name
name
#endif
                       Exp -> Exp -> Type -> ExpQ
p1' Exp
e Exp
e Type
ty
p1 Exp
e              = [| (HV (unsafeCoerce# $(return e)), $(expToExpExp e), trToTHType (typeOf $(return e))) |]

p1' :: Exp -> Exp -> Type -> ExpQ
p1' Exp
se Exp
e Type
ty = [| (HV (unsafeCoerce# $(return se)), $(expToExpExp e), $(typeToExpType ty)) |]

useArrowT :: TH.Type -> TH.Type
useArrowT :: Type -> Type
useArrowT = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((Type -> Type) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT Type -> Type
uAT)
uAT :: Type -> Type
uAT (ConT Name
name) | Name -> String
nameBase Name
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"(->)" = Type
ArrowT
uAT Type
t = Type
t
{- 
  Strangely enough, GHC-7.10 (at least, GHCi, version 7.10.2.20150906) rejects (ConT GHC.Prim.(->)), while reading "(->)" to (ConT GHC.Prim.(->))

Prelude> :m +Language.Haskell.TH
Prelude Language.Haskell.TH> runQ [t| (->) Int Bool |] >>= print
AppT (AppT (ConT GHC.Prim.(->)) (ConT GHC.Types.Int)) (ConT GHC.Types.Bool)
Prelude Language.Haskell.TH> ((/=0) :: $([t| (->) Int Bool |])) 3

<interactive>:5:13:
    Illegal type constructor or class name: ‘(->)’
    When splicing a TH type: GHC.Prim.(->) GHC.Types.Int GHC.Types.Bool
    In the splice: $([t| (->) Int Bool |])
Prelude Language.Haskell.TH> ((/=0) :: $([t| (->) Int|]) Bool) 3

<interactive>:7:13:
    Illegal type constructor or class name: ‘(->)’
    When splicing a TH type: GHC.Prim.(->) GHC.Types.Int
    In the splice: $([t| (->) Int |])
Prelude Language.Haskell.TH> ((/=0) :: $([t| Int -> Bool |])) 3
True

  This is as opposed to the description in 
     https://downloads.haskell.org/~ghc/latest/docs/html/libraries/template-haskell-2.10.0.0/src/Language-Haskell-TH-Syntax.html#line-1414
  saying
     But if the original HsSyn used prefix application, we won't use
     these special TH constructors.  For example
       [] t              ConT "[]" `AppT` t
       (->) t            ConT "->" `AppT` t
     In this way we can faithfully represent in TH whether the original
     HsType used concrete syntax or not.
  So this may be a bug, introduced when making TH more pedantic.

  Reading "(->)" to (ConT GHC.Prim.(->)) is a good news for MagicHaskeller which abuses (->) to indicate constructor consumption.
  In the case that the distinction between prefixed (->) and the infixed -> is obsoleted, we can still use   
     type (:-->) = (->) 
  but then, we need to change more code.
-}

-- 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 :: TyConLib -> [[Primitive]] -> [[Typed [CoreExpr]]]
primitivesp TyConLib
tcl [[Primitive]]
pss = [[Dynamic]] -> [[Typed [CoreExpr]]]
dynamicsp (([Primitive] -> [Dynamic]) -> [[Primitive]] -> [[Dynamic]]
forall a b. (a -> b) -> [a] -> [b]
map ((Primitive -> Dynamic) -> [Primitive] -> [Dynamic]
forall a b. (a -> b) -> [a] -> [b]
map (TyConLib -> Primitive -> Dynamic
primitiveToDynamic TyConLib
tcl)) [[Primitive]]
pss)
dynamicsp :: [[PD.Dynamic]] -> [[Typed [CoreExpr]]]
dynamicsp :: [[Dynamic]] -> [[Typed [CoreExpr]]]
dynamicsp [[Dynamic]]
pss
    = let ixs :: [Var]
ixs = (Var -> Var -> Var) -> Var -> [Var] -> [Var]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Var -> Var -> Var
forall a. Num a => a -> a -> a
(+) Var
0 ([Var] -> [Var]) -> [Var] -> [Var]
forall a b. (a -> b) -> a -> b
$ ([Dynamic] -> Var) -> [[Dynamic]] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map [Dynamic] -> Var
forall i a. Num i => [a] -> i
genericLength [[Dynamic]]
pss
      in (Var -> [Dynamic] -> [Typed [CoreExpr]])
-> [Var] -> [[Dynamic]] -> [[Typed [CoreExpr]]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Var
ix -> (Typed [CoreExpr] -> Typed [CoreExpr] -> Typed [CoreExpr])
-> (Typed [CoreExpr] -> Typed [CoreExpr] -> Ordering)
-> [Typed [CoreExpr]]
-> [Typed [CoreExpr]]
forall k. (k -> k -> k) -> (k -> k -> Ordering) -> [k] -> [k]
mergesortWithBy (\([CoreExpr]
x:::Type
t) ([CoreExpr]
y:::Type
_) -> ([CoreExpr]
x[CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++[CoreExpr]
y)[CoreExpr] -> Type -> Typed [CoreExpr]
forall a. a -> Type -> Typed a
:::Type
t) (\([CoreExpr]
_:::Type
t) ([CoreExpr]
_:::Type
u) -> Type -> Type -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Type
t Type
u) ([Typed [CoreExpr]] -> [Typed [CoreExpr]])
-> ([Dynamic] -> [Typed [CoreExpr]])
-> [Dynamic]
-> [Typed [CoreExpr]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                         (Var -> Dynamic -> Typed [CoreExpr])
-> [Var] -> [Dynamic] -> [Typed [CoreExpr]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ Var
n Dynamic
d -> [if Exp -> Bool
expIsAConstr (Exp -> Bool) -> Exp -> Bool
forall a b. (a -> b) -> a -> b
$ Dynamic -> Exp
PD.dynExp Dynamic
d then Var -> CoreExpr
PrimCon Var
n else Var -> CoreExpr
Primitive Var
n] [CoreExpr] -> Type -> Typed [CoreExpr]
forall a. a -> Type -> Typed a
::: Int -> Type -> Type
forall t. (Eq t, Num t) => t -> Type -> Type
toCxt (Exp -> Int
numCxts (Exp -> Int) -> Exp -> Int
forall a b. (a -> b) -> a -> b
$ Dynamic -> Exp
PD.dynExp Dynamic
d) (Dynamic -> Type
PD.dynType Dynamic
d)) [Var
ix..]) [Var]
ixs [[Dynamic]]
pss






-- うまくいかん場合は map (filtTMxAEs cmn) . の部分を取り除いてやってみるべし．


filtTCEsss :: Common -> Int -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]]
filtTCEsss :: Common -> Int -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]]
filtTCEsss Common
cmn Int
depth = Int -> [Typed (Matrix AnnExpr)] -> [[Typed [CoreExpr]]]
forall e.
Expression e =>
Int -> [Typed (Matrix e)] -> [[Typed [CoreExpr]]]
tMxAEsToTCEsss Int
depth ([Typed (Matrix AnnExpr)] -> [[Typed [CoreExpr]]])
-> ([[Typed [CoreExpr]]] -> [Typed (Matrix AnnExpr)])
-> [[Typed [CoreExpr]]]
-> [[Typed [CoreExpr]]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Typed (Matrix AnnExpr) -> Typed (Matrix AnnExpr))
-> [Typed (Matrix AnnExpr)] -> [Typed (Matrix AnnExpr)]
forall a b. (a -> b) -> [a] -> [b]
map (Common -> Typed (Matrix AnnExpr) -> Typed (Matrix AnnExpr)
filtTMxAEs Common
cmn) ([Typed (Matrix AnnExpr)] -> [Typed (Matrix AnnExpr)])
-> ([[Typed [CoreExpr]]] -> [Typed (Matrix AnnExpr)])
-> [[Typed [CoreExpr]]]
-> [Typed (Matrix AnnExpr)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoreExpr -> Dynamic)
-> [Typed (Matrix CoreExpr)] -> [Typed (Matrix AnnExpr)]
tMxCEsToTMxAEs (Common -> CoreExpr -> Dynamic
reducer Common
cmn) ([Typed (Matrix CoreExpr)] -> [Typed (Matrix AnnExpr)])
-> ([[Typed [CoreExpr]]] -> [Typed (Matrix CoreExpr)])
-> [[Typed [CoreExpr]]]
-> [Typed (Matrix AnnExpr)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Typed [CoreExpr]]] -> [Typed (Matrix CoreExpr)]
tCEsssToTMxCEs  -- ProgramGenerator.reducer :: Common -> CoreExpr -> Dynamic はVarLibの情報をCommonから抽出する．
-- filtTCEsss cmn depth = tMxAEsToTCEsss depth . {- map (filtTMxAEs cmn) . -} tMxCEsToTMxAEs (reducer cmn) . tCEsssToTMxCEs  -- ProgramGenerator.reducer :: Common -> CoreExpr -> Dynamic はVarLibの情報をCommonから抽出する．
-- filtTCEsss cmn depth = id -- これはさすがにうまく行く．
-- filtTCEsss cmn depth = tMxAEsToTCEsss depth . tCEsssToTMxCEs -- depthが十分ならうまく行く．
tCEsssToTMxCEs :: [[Typed [CoreExpr]]] -> [Typed (Matrix CoreExpr)]
tCEsssToTMxCEs :: [[Typed [CoreExpr]]] -> [Typed (Matrix CoreExpr)]
tCEsssToTMxCEs = (Typed (Matrix CoreExpr)
 -> Typed (Matrix CoreExpr) -> Typed (Matrix CoreExpr))
-> (Typed (Matrix CoreExpr) -> Typed (Matrix CoreExpr) -> Ordering)
-> [Typed (Matrix CoreExpr)]
-> [Typed (Matrix CoreExpr)]
forall k. (k -> k -> k) -> (k -> k -> Ordering) -> [k] -> [k]
mergesortWithBy (\(Matrix CoreExpr
x:::Type
t) (Matrix CoreExpr
y:::Type
_) -> (Matrix CoreExpr
x Matrix CoreExpr -> Matrix CoreExpr -> Matrix CoreExpr
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Matrix CoreExpr
y)Matrix CoreExpr -> Type -> Typed (Matrix CoreExpr)
forall a. a -> Type -> Typed a
:::Type
t) (\(Matrix CoreExpr
_:::Type
t) (Matrix CoreExpr
_:::Type
u) -> Type -> Type -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Type
t Type
u) ([Typed (Matrix CoreExpr)] -> [Typed (Matrix CoreExpr)])
-> ([[Typed [CoreExpr]]] -> [Typed (Matrix CoreExpr)])
-> [[Typed [CoreExpr]]]
-> [Typed (Matrix CoreExpr)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. -- dynamicspにも同じ部分があるので名前をつけるべき．
                 [[Typed (Matrix CoreExpr)]] -> [Typed (Matrix CoreExpr)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Typed (Matrix CoreExpr)]] -> [Typed (Matrix CoreExpr)])
-> ([[Typed [CoreExpr]]] -> [[Typed (Matrix CoreExpr)]])
-> [[Typed [CoreExpr]]]
-> [Typed (Matrix CoreExpr)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                 (Int -> [Typed [CoreExpr]] -> [Typed (Matrix CoreExpr)])
-> [Int] -> [[Typed [CoreExpr]]] -> [[Typed (Matrix CoreExpr)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
d [Typed [CoreExpr]]
ts -> (Typed [CoreExpr] -> Typed (Matrix CoreExpr))
-> [Typed [CoreExpr]] -> [Typed (Matrix CoreExpr)]
forall a b. (a -> b) -> [a] -> [b]
map (([CoreExpr] -> Matrix CoreExpr)
-> Typed [CoreExpr] -> Typed (Matrix CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[CoreExpr]
ces -> Stream [CoreExpr] -> Matrix CoreExpr
forall a. Stream (Bag a) -> Matrix a
Mx (Stream [CoreExpr] -> Matrix CoreExpr)
-> Stream [CoreExpr] -> Matrix CoreExpr
forall a b. (a -> b) -> a -> b
$ Int -> [CoreExpr] -> Stream [CoreExpr]
forall a. Int -> a -> [a]
replicate Int
d [] Stream [CoreExpr] -> Stream [CoreExpr] -> Stream [CoreExpr]
forall a. [a] -> [a] -> [a]
++ [CoreExpr]
ces [CoreExpr] -> Stream [CoreExpr] -> Stream [CoreExpr]
forall a. a -> [a] -> [a]
: [CoreExpr] -> Stream [CoreExpr]
forall a. a -> [a]
repeat [])) [Typed [CoreExpr]]
ts) [Int
0..]
tMxCEsToTMxAEs :: (CoreExpr->Dynamic) -> [Typed (Matrix CoreExpr)] -> [Typed (Matrix AnnExpr)]
tMxCEsToTMxAEs :: (CoreExpr -> Dynamic)
-> [Typed (Matrix CoreExpr)] -> [Typed (Matrix AnnExpr)]
tMxCEsToTMxAEs CoreExpr -> Dynamic
reduce = (Typed (Matrix CoreExpr) -> Typed (Matrix AnnExpr))
-> [Typed (Matrix CoreExpr)] -> [Typed (Matrix AnnExpr)]
forall a b. (a -> b) -> [a] -> [b]
map ((Matrix CoreExpr -> Matrix AnnExpr)
-> Typed (Matrix CoreExpr) -> Typed (Matrix AnnExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CoreExpr -> AnnExpr) -> Matrix CoreExpr -> Matrix AnnExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CoreExpr -> Dynamic) -> CoreExpr -> AnnExpr
forall e. Expression e => (CoreExpr -> Dynamic) -> e -> AnnExpr
toAnnExpr CoreExpr -> Dynamic
reduce)))
filtTMxAEs :: Common -> Typed (Matrix AnnExpr) -> Typed (Matrix AnnExpr)
filtTMxAEs :: Common -> Typed (Matrix AnnExpr) -> Typed (Matrix AnnExpr)
filtTMxAEs Common
cmn (Matrix AnnExpr
m ::: Type
ty) = DBound AnnExpr -> Matrix AnnExpr
forall (m :: * -> *) a. Search m => DBound a -> m a
fromDB (Common -> Type -> DBound AnnExpr -> DBound AnnExpr
forall (m :: * -> *).
DB m =>
Common -> Type -> m AnnExpr -> m AnnExpr
MagicHaskeller.ClassifyDM.filterDM Common
cmn Type
ty (Matrix AnnExpr -> DBound AnnExpr
forall (m :: * -> *) a. Search m => Matrix a -> m a
fromMx Matrix AnnExpr
m)) Matrix AnnExpr -> Type -> Typed (Matrix AnnExpr)
forall a. a -> Type -> Typed a
::: Type
ty
tMxAEsToTCEsss :: Expression e => Int -> [Typed (Matrix e)] -> [[Typed [CoreExpr]]]
tMxAEsToTCEsss :: Int -> [Typed (Matrix e)] -> [[Typed [CoreExpr]]]
tMxAEsToTCEsss Int
dep [Typed (Matrix e)]
tmxaes = ([Typed [CoreExpr]] -> [Typed [CoreExpr]])
-> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]]
forall a b. (a -> b) -> [a] -> [b]
map ((Typed [CoreExpr] -> Bool)
-> [Typed [CoreExpr]] -> [Typed [CoreExpr]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (Typed [CoreExpr] -> Bool) -> Typed [CoreExpr] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CoreExpr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([CoreExpr] -> Bool)
-> (Typed [CoreExpr] -> [CoreExpr]) -> Typed [CoreExpr] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Typed [CoreExpr] -> [CoreExpr]
forall a. Typed a -> a
typee)) ([[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]])
-> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]]
forall a b. (a -> b) -> a -> b
$ [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]]
forall a. [[a]] -> [[a]]
transpose [ [ (e -> CoreExpr) -> [e] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map e -> CoreExpr
forall e. Expression e => e -> CoreExpr
toCE [e]
aes [CoreExpr] -> Type -> Typed [CoreExpr]
forall a. a -> Type -> Typed a
::: Type
ty | [e]
aes <- Int -> [[e]] -> [[e]]
forall a. Int -> [a] -> [a]
take Int
dep [[e]]
aess ] | Mx [[e]]
aess ::: Type
ty <- [Typed (Matrix e)]
tmxaes ]



-- See if the argument is a constructor expression.
expIsAConstr :: Exp -> Bool
expIsAConstr (ConE Name
_)  = Bool
True
expIsAConstr (LitE Lit
_)  = Bool
True
expIsAConstr (ListE [Exp]
_) = Bool
True
expIsAConstr (TupE  [Maybe Exp]
_) = Bool
True
expIsAConstr (AppE Exp
e Exp
_) = Exp -> Bool
expIsAConstr Exp
e
expIsAConstr (InfixE Maybe Exp
_ (ConE Name
_) Maybe Exp
_) = Bool
True
expIsAConstr Exp
_ = Bool
False

numCxts :: Exp -> Int
numCxts (VarE Name
nm) = case Name -> String
nameBase Name
nm of Char
'b':Char
'y':Char
d:Char
'_':String
_    | Char -> Bool
isDigit Char
d -> Char -> Int
digitToInt Char
d
                                        Char
'-':Char
'-':xs :: String
xs@(Char
'#':String
_)             -> String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'#') String
xs
                                        String
_                              -> Int
0
numCxts Exp
_         = Int
0
toCxt :: t -> Type -> Type
toCxt t
0 Type
t = Type
t
toCxt t
n (Type
t :-> Type
u) = Type
t Type -> Type -> Type
:=> t -> Type -> Type
toCxt (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) Type
u

primitivesc :: TyConLib -> [Primitive] -> [Typed [CoreExpr]]
primitivesc :: TyConLib -> [Primitive] -> [Typed [CoreExpr]]
primitivesc TyConLib
tcl [Primitive]
ps = [Dynamic] -> [Typed [CoreExpr]]
dynamicsc ((Primitive -> Dynamic) -> [Primitive] -> [Dynamic]
forall a b. (a -> b) -> [a] -> [b]
map (TyConLib -> Primitive -> Dynamic
primitiveToDynamic TyConLib
tcl) [Primitive]
ps)
dynamicsc :: [PD.Dynamic] -> [Typed [CoreExpr]]
dynamicsc :: [Dynamic] -> [Typed [CoreExpr]]
dynamicsc [Dynamic]
ps = (Typed [CoreExpr] -> Typed [CoreExpr] -> Typed [CoreExpr])
-> (Typed [CoreExpr] -> Typed [CoreExpr] -> Ordering)
-> [Typed [CoreExpr]]
-> [Typed [CoreExpr]]
forall k. (k -> k -> k) -> (k -> k -> Ordering) -> [k] -> [k]
mergesortWithBy (\([CoreExpr]
x:::Type
t) ([CoreExpr]
y:::Type
_) -> ([CoreExpr]
x[CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++[CoreExpr]
y)[CoreExpr] -> Type -> Typed [CoreExpr]
forall a. a -> Type -> Typed a
:::Type
t) (\([CoreExpr]
_:::Type
t) ([CoreExpr]
_:::Type
u) -> Type -> Type -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Type
t Type
u) ([Typed [CoreExpr]] -> [Typed [CoreExpr]])
-> [Typed [CoreExpr]] -> [Typed [CoreExpr]]
forall a b. (a -> b) -> a -> b
$
                           (Dynamic -> Typed [CoreExpr]) -> [Dynamic] -> [Typed [CoreExpr]]
forall a b. (a -> b) -> [a] -> [b]
map (\ Dynamic
dyn -> [Dictionary -> CoreExpr
Context (Dictionary -> CoreExpr) -> Dictionary -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Dynamic -> Dictionary
Dict Dynamic
dyn] [CoreExpr] -> Type -> Typed [CoreExpr]
forall a. a -> Type -> Typed a
::: {- toCxt (numCxts e) -} Dynamic -> Type
PD.dynType Dynamic
dyn) [Dynamic]
ps

mkPG :: ProgramGenerator pg => [Primitive] -> pg
mkPG :: [Primitive] -> pg
mkPG   = [Primitive] -> [[Primitive]] -> pg
forall pg.
ProgramGenerator pg =>
[Primitive] -> [[Primitive]] -> pg
mkPGX [] ([[Primitive]] -> pg)
-> ([Primitive] -> [[Primitive]]) -> [Primitive] -> pg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Primitive] -> [[Primitive]] -> [[Primitive]]
forall a. a -> [a] -> [a]
:[])
mkPGX :: ProgramGenerator pg => [Primitive] -> [[Primitive]] -> pg
mkPGX :: [Primitive] -> [[Primitive]] -> pg
mkPGX   = Bool -> [Primitive] -> [[Primitive]] -> pg
forall pg.
ProgramGenerator pg =>
Bool -> [Primitive] -> [[Primitive]] -> pg
mkPG' Bool
True
-- ^ 'mkPG' is defined as:
--
-- > mkPG prims = mkPGSF (mkStdGen 123456) (repeat 5) prims prims

mkMemo :: ProgramGenerator pg => [Primitive] -> pg
mkMemo :: [Primitive] -> pg
mkMemo = Bool -> [Primitive] -> [[Primitive]] -> pg
forall pg.
ProgramGenerator pg =>
Bool -> [Primitive] -> [[Primitive]] -> pg
mkPG' Bool
False [] ([[Primitive]] -> pg)
-> ([Primitive] -> [[Primitive]]) -> [Primitive] -> pg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Primitive] -> [[Primitive]] -> [[Primitive]]
forall a. a -> [a] -> [a]
:[])
mkPG' :: ProgramGenerator pg => Bool -> [Primitive] -> [[Primitive]] -> pg
mkPG' :: Bool -> [Primitive] -> [[Primitive]] -> pg
mkPG' Bool
cont [Primitive]
classes [[Primitive]]
tups = case Options -> [Primitive] -> [Primitive] -> [Int] -> Common
mkCommon Options
forall a. Opt a
options{contain :: Bool
contain=Bool
cont} [Primitive]
totals [Primitive]
totals [Int]
depths of Common
cmn -> Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> pg
forall a.
ProgramGenerator a =>
Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> a
mkTrie Common
cmn (TyConLib -> [Primitive] -> [Typed [CoreExpr]]
primitivesc (Common -> TyConLib
tcl Common
cmn) [Primitive]
classes) (TyConLib -> [[Primitive]] -> [[Typed [CoreExpr]]]
primitivesp (Common -> TyConLib
tcl Common
cmn) [[Primitive]]
tups)
        where totals :: [Primitive]
totals = [[Primitive]] -> [Primitive]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Primitive]]
tups [Primitive] -> [Primitive] -> [Primitive]
forall a. [a] -> [a] -> [a]
++ [Primitive]
classes
              depths :: [Int]
depths = [[Primitive]] -> [Int]
forall a. [[a]] -> [Int]
mkDepths [[Primitive]]
tups [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ (Primitive -> Int) -> [Primitive] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Primitive -> Int
forall a b. a -> b -> a
const Int
0) [Primitive]
classes

-- | '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 =>
#ifdef TFRANDOM
           TFGen
#else
           StdGen
#endif
        -> [Int] -- ^ number of random samples at each depth, for each type.
        -> [Primitive] 
        -> [Primitive] 
        -> [Primitive] -> pg
mkPGSF :: StdGen -> [Int] -> [Primitive] -> [Primitive] -> [Primitive] -> pg
mkPGSF   = Bool
-> StdGen
-> [Int]
-> [Primitive]
-> [Primitive]
-> [Primitive]
-> pg
forall pg.
ProgramGenerator pg =>
Bool
-> StdGen
-> [Int]
-> [Primitive]
-> [Primitive]
-> [Primitive]
-> pg
mkPGSF' Bool
True
mkMemoSF :: StdGen -> [Int] -> [Primitive] -> [Primitive] -> [Primitive] -> pg
mkMemoSF = Bool
-> StdGen
-> [Int]
-> [Primitive]
-> [Primitive]
-> [Primitive]
-> pg
forall pg.
ProgramGenerator pg =>
Bool
-> StdGen
-> [Int]
-> [Primitive]
-> [Primitive]
-> [Primitive]
-> pg
mkPGSF' Bool
False
mkPGSF' :: Bool
-> StdGen
-> [Int]
-> [Primitive]
-> [Primitive]
-> [Primitive]
-> pg
mkPGSF' Bool
cont StdGen
gen [Int]
nrnds [Primitive]
classes [Primitive]
optups [Primitive]
tups = Options -> [Primitive] -> [Primitive] -> pg
forall pg.
ProgramGenerator pg =>
Options -> [Primitive] -> [Primitive] -> pg
mkPGOpt (Opt Any
forall a. Opt a
options{primopt :: Maybe [[Primitive]]
primopt = [[Primitive]] -> Maybe [[Primitive]]
forall a. a -> Maybe a
Just [[Primitive]
optups], contain :: Bool
contain = Bool
cont, stdgen :: StdGen
stdgen = StdGen
gen, nrands :: [Int]
nrands = [Int]
nrnds}) [Primitive]
classes [Primitive]
tups
--   Currently only the pg==ConstrLSF case makes sense. ってのは，optupsのみに関する話で，rndsは関係ない．

mkPG075 :: ProgramGenerator pg => [Primitive] -> [Primitive] -> pg
mkPG075 :: [Primitive] -> [Primitive] -> pg
mkPG075 = Options -> [Primitive] -> [Primitive] -> pg
forall pg.
ProgramGenerator pg =>
Options -> [Primitive] -> [Primitive] -> pg
mkPGOpt (Opt Any
forall a. Opt a
options{primopt :: Maybe [[Primitive]]
primopt = Maybe [[Primitive]]
forall a. Maybe a
Nothing, contain :: Bool
contain = Bool
True, guess :: Bool
guess = Bool
True})
mkMemo075 :: ProgramGenerator pg => [Primitive] -> [Primitive] -> pg
mkMemo075 :: [Primitive] -> [Primitive] -> pg
mkMemo075 = Options -> [Primitive] -> [Primitive] -> pg
forall pg.
ProgramGenerator pg =>
Options -> [Primitive] -> [Primitive] -> pg
mkPGOpt (Opt Any
forall a. Opt a
options{primopt :: Maybe [[Primitive]]
primopt = Maybe [[Primitive]]
forall a. Maybe a
Nothing, contain :: Bool
contain = Bool
False, guess :: Bool
guess = Bool
True})

mkPGOpt :: ProgramGenerator pg => Options -> [Primitive] -> [Primitive] -> pg
mkPGOpt :: Options -> [Primitive] -> [Primitive] -> pg
mkPGOpt Options
opt [Primitive]
classes [Primitive]
prims = Options
-> [Primitive]
-> [(Primitive, Primitive)]
-> [[Primitive]]
-> [[(Primitive, Primitive)]]
-> pg
forall pg.
ProgramGenerator pg =>
Options
-> [Primitive]
-> [(Primitive, Primitive)]
-> [[Primitive]]
-> [[(Primitive, Primitive)]]
-> pg
mkPGXOpt Options
opt [Primitive]
classes [] [[Primitive]
prims] []
mkPGXOpt :: ProgramGenerator pg => Options -> [Primitive] -> [(Primitive,Primitive)] -> [[Primitive]] -> [[(Primitive,Primitive)]] -> pg
mkPGXOpt :: Options
-> [Primitive]
-> [(Primitive, Primitive)]
-> [[Primitive]]
-> [[(Primitive, Primitive)]]
-> pg
mkPGXOpt  = (Common
 -> [Typed [CoreExpr]]
 -> [[Typed [CoreExpr]]]
 -> [[Typed [CoreExpr]]]
 -> pg)
-> Options
-> [Primitive]
-> [(Primitive, Primitive)]
-> [[Primitive]]
-> [[(Primitive, Primitive)]]
-> pg
forall a.
(Common
 -> [Typed [CoreExpr]]
 -> [[Typed [CoreExpr]]]
 -> [[Typed [CoreExpr]]]
 -> a)
-> Options
-> [Primitive]
-> [(Primitive, Primitive)]
-> [[Primitive]]
-> [[(Primitive, Primitive)]]
-> a
mkPGXOpts Common
-> [Typed [CoreExpr]]
-> [[Typed [CoreExpr]]]
-> [[Typed [CoreExpr]]]
-> pg
forall a.
ProgramGenerator a =>
Common
-> [Typed [CoreExpr]]
-> [[Typed [CoreExpr]]]
-> [[Typed [CoreExpr]]]
-> a
mkTrieOpt
mkPGIO    :: ProgramGeneratorIO pg => [Primitive] -> [Primitive] -> IO pg
mkPGIO :: [Primitive] -> [Primitive] -> IO pg
mkPGIO [Primitive]
classes [Primitive]
prims = Options
-> [Primitive]
-> [(Primitive, Primitive)]
-> [[Primitive]]
-> [[(Primitive, Primitive)]]
-> IO pg
forall pg.
ProgramGeneratorIO pg =>
Options
-> [Primitive]
-> [(Primitive, Primitive)]
-> [[Primitive]]
-> [[(Primitive, Primitive)]]
-> IO pg
mkPGXOptIO Options
forall a. Opt a
options [Primitive]
classes [] [[Primitive]
prims] []
mkPGXOptIO :: ProgramGeneratorIO pg => Options -> [Primitive] -> [(Primitive,Primitive)] -> [[Primitive]] -> [[(Primitive,Primitive)]] -> IO pg
mkPGXOptIO :: Options
-> [Primitive]
-> [(Primitive, Primitive)]
-> [[Primitive]]
-> [[(Primitive, Primitive)]]
-> IO pg
mkPGXOptIO = (Common
 -> [Typed [CoreExpr]]
 -> [[Typed [CoreExpr]]]
 -> [[Typed [CoreExpr]]]
 -> IO pg)
-> Options
-> [Primitive]
-> [(Primitive, Primitive)]
-> [[Primitive]]
-> [[(Primitive, Primitive)]]
-> IO pg
forall a.
(Common
 -> [Typed [CoreExpr]]
 -> [[Typed [CoreExpr]]]
 -> [[Typed [CoreExpr]]]
 -> a)
-> Options
-> [Primitive]
-> [(Primitive, Primitive)]
-> [[Primitive]]
-> [[(Primitive, Primitive)]]
-> a
mkPGXOpts Common
-> [Typed [CoreExpr]]
-> [[Typed [CoreExpr]]]
-> [[Typed [CoreExpr]]]
-> IO pg
forall a.
ProgramGeneratorIO a =>
Common
-> [Typed [CoreExpr]]
-> [[Typed [CoreExpr]]]
-> [[Typed [CoreExpr]]]
-> IO a
mkTrieOptIO

mkPGXOpts :: (Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]] -> a)
          -> Options -> [Primitive] -> [(Primitive,Primitive)] -> [[Primitive]] -> [[(Primitive,Primitive)]] -> a
mkPGXOpts :: (Common
 -> [Typed [CoreExpr]]
 -> [[Typed [CoreExpr]]]
 -> [[Typed [CoreExpr]]]
 -> a)
-> Options
-> [Primitive]
-> [(Primitive, Primitive)]
-> [[Primitive]]
-> [[(Primitive, Primitive)]]
-> a
mkPGXOpts = (TyConLib -> [[(String, Dynamic)]])
-> (TyConLib -> [[(String, Dynamic)]])
-> (TyConLib -> [[(String, Dynamic)]])
-> (Common
    -> [Typed [CoreExpr]]
    -> [[Typed [CoreExpr]]]
    -> [[Typed [CoreExpr]]]
    -> a)
-> Options
-> [Primitive]
-> [(Primitive, Primitive)]
-> [[Primitive]]
-> [[(Primitive, Primitive)]]
-> a
forall a.
(TyConLib -> [[(String, Dynamic)]])
-> (TyConLib -> [[(String, Dynamic)]])
-> (TyConLib -> [[(String, Dynamic)]])
-> (Common
    -> [Typed [CoreExpr]]
    -> [[Typed [CoreExpr]]]
    -> [[Typed [CoreExpr]]]
    -> a)
-> Options
-> [Primitive]
-> [(Primitive, Primitive)]
-> [[Primitive]]
-> [[(Primitive, Primitive)]]
-> a
mkPGXOptsExt (\TyConLib
_ -> [(String, Dynamic)] -> [[(String, Dynamic)]]
forall a. a -> [a]
repeat []) (\TyConLib
_ -> [(String, Dynamic)] -> [[(String, Dynamic)]]
forall a. a -> [a]
repeat []) (\TyConLib
_ -> [(String, Dynamic)] -> [[(String, Dynamic)]]
forall a. a -> [a]
repeat [])
mkPGXOptsExt :: (TyConLib -> [[(String,Dynamic)]]) -> (TyConLib -> [[(String,Dynamic)]]) -> (TyConLib -> [[(String,Dynamic)]])
          -> (Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]] -> a)
          -> Options -> [Primitive] -> [(Primitive,Primitive)] -> [[Primitive]] -> [[(Primitive,Primitive)]] -> a
mkPGXOptsExt :: (TyConLib -> [[(String, Dynamic)]])
-> (TyConLib -> [[(String, Dynamic)]])
-> (TyConLib -> [[(String, Dynamic)]])
-> (Common
    -> [Typed [CoreExpr]]
    -> [[Typed [CoreExpr]]]
    -> [[Typed [CoreExpr]]]
    -> a)
-> Options
-> [Primitive]
-> [(Primitive, Primitive)]
-> [[Primitive]]
-> [[(Primitive, Primitive)]]
-> a
mkPGXOptsExt TyConLib -> [[(String, Dynamic)]]
cmpExt TyConLib -> [[(String, Dynamic)]]
arbExt TyConLib -> [[(String, Dynamic)]]
coarbExt Common
-> [Typed [CoreExpr]]
-> [[Typed [CoreExpr]]]
-> [[Typed [CoreExpr]]]
-> a
mkt Options
opt [Primitive]
classes [(Primitive, Primitive)]
partclasses [[Primitive]]
prims [[(Primitive, Primitive)]]
partprims
    = let cmn :: Common
cmn = (TyConLib -> [[(String, Dynamic)]])
-> (TyConLib -> [[(String, Dynamic)]])
-> (TyConLib -> [[(String, Dynamic)]])
-> Options
-> [Primitive]
-> Common
initCommonExt TyConLib -> [[(String, Dynamic)]]
cmpExt TyConLib -> [[(String, Dynamic)]]
arbExt TyConLib -> [[(String, Dynamic)]]
coarbExt Options
opt ([Primitive]
classes [Primitive] -> [Primitive] -> [Primitive]
forall a. [a] -> [a] -> [a]
++ [[Primitive]] -> [Primitive]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Primitive]]
prims [Primitive] -> [Primitive] -> [Primitive]
forall a. [a] -> [a] -> [a]
++ ((Primitive, Primitive) -> Primitive)
-> [(Primitive, Primitive)] -> [Primitive]
forall a b. (a -> b) -> [a] -> [b]
map (Primitive, Primitive) -> Primitive
forall a b. (a, b) -> a
fst ([(Primitive, Primitive)]
partclasses [(Primitive, Primitive)]
-> [(Primitive, Primitive)] -> [(Primitive, Primitive)]
forall a. [a] -> [a] -> [a]
++ [[(Primitive, Primitive)]] -> [(Primitive, Primitive)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Primitive, Primitive)]]
partprims))
          ptd :: Primitive -> Dynamic
ptd = TyConLib -> Primitive -> Dynamic
primitiveToDynamic (Common -> TyConLib
tcl Common
cmn)
      in (Common
 -> [Typed [CoreExpr]]
 -> [[Typed [CoreExpr]]]
 -> [[Typed [CoreExpr]]]
 -> a)
-> Maybe [[Primitive]]
-> [Dynamic]
-> [(Dynamic, Dynamic)]
-> [[Dynamic]]
-> [[(Dynamic, Dynamic)]]
-> Common
-> a
forall a.
(Common
 -> [Typed [CoreExpr]]
 -> [[Typed [CoreExpr]]]
 -> [[Typed [CoreExpr]]]
 -> a)
-> Maybe [[Primitive]]
-> [Dynamic]
-> [(Dynamic, Dynamic)]
-> [[Dynamic]]
-> [[(Dynamic, Dynamic)]]
-> Common
-> a
updatePGXOpts Common
-> [Typed [CoreExpr]]
-> [[Typed [CoreExpr]]]
-> [[Typed [CoreExpr]]]
-> a
mkt (Options -> Maybe [[Primitive]]
forall a. Opt a -> Maybe a
primopt Options
opt)
                           [ Primitive -> Dynamic
ptd Primitive
cl | Primitive
cl <- [Primitive]
classes ]
                           [ (Primitive -> Dynamic
ptd Primitive
tot, Primitive -> Dynamic
ptd Primitive
part) | (Primitive
tot, Primitive
part) <- [(Primitive, Primitive)]
partclasses ]
                           [ [ Primitive -> Dynamic
ptd Primitive
p | Primitive
p <- [Primitive]
ps ] | [Primitive]
ps <- [[Primitive]]
prims ]
                           [ [ (Primitive -> Dynamic
ptd Primitive
tot, Primitive -> Dynamic
ptd Primitive
part) | (Primitive
tot, Primitive
part) <- [(Primitive, Primitive)]
pps ] | [(Primitive, Primitive)]
pps <- [[(Primitive, Primitive)]]
partprims ]
                           Common
cmn
{-
mkPGXOpts mkt opt classes partclasses prims partprims = case mkCommon opt (concat totalss ++ totalclss) (concat partialss ++ partialclss) (mkDepths totalss ++ map (const 0) totalclss) of cmn -> mkt cmn (primitivesc (tcl cmn) totalclss) (primitivesp (tcl cmn) primsOpt) (primitivesp (tcl cmn) totalss)
    where primsOpt   = case primopt opt of Nothing -> prims
                                           Just po -> po
          (tot, part) = unzip $ map unzip partprims
          totalss     = zipAppend prims tot
          partialss   = zipAppend prims part
          (totc,partc)= unzip partclasses
          totalclss   = classes ++ totc
          partialclss = classes ++ partc
-}
updatePGXOpts :: (Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]] -> a)
              -> Maybe [[Primitive]] -> [PD.Dynamic] -> [(PD.Dynamic,PD.Dynamic)] -> [[PD.Dynamic]] -> [[(PD.Dynamic,PD.Dynamic)]] -> Common -> a
updatePGXOpts :: (Common
 -> [Typed [CoreExpr]]
 -> [[Typed [CoreExpr]]]
 -> [[Typed [CoreExpr]]]
 -> a)
-> Maybe [[Primitive]]
-> [Dynamic]
-> [(Dynamic, Dynamic)]
-> [[Dynamic]]
-> [[(Dynamic, Dynamic)]]
-> Common
-> a
updatePGXOpts = (Common -> [[Dynamic]] -> [[Typed [CoreExpr]]])
-> (Common
    -> [Typed [CoreExpr]]
    -> [[Typed [CoreExpr]]]
    -> [[Typed [CoreExpr]]]
    -> a)
-> Maybe [[Primitive]]
-> [Dynamic]
-> [(Dynamic, Dynamic)]
-> [[Dynamic]]
-> [[(Dynamic, Dynamic)]]
-> Common
-> a
forall a.
(Common -> [[Dynamic]] -> [[Typed [CoreExpr]]])
-> (Common
    -> [Typed [CoreExpr]]
    -> [[Typed [CoreExpr]]]
    -> [[Typed [CoreExpr]]]
    -> a)
-> Maybe [[Primitive]]
-> [Dynamic]
-> [(Dynamic, Dynamic)]
-> [[Dynamic]]
-> [[(Dynamic, Dynamic)]]
-> Common
-> a
uPGXO (([[Dynamic]] -> [[Typed [CoreExpr]]])
-> Common -> [[Dynamic]] -> [[Typed [CoreExpr]]]
forall a b. a -> b -> a
const [[Dynamic]] -> [[Typed [CoreExpr]]]
dynamicsp)
updatePGXOptsFilt :: Int -> (Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]] -> a)
              -> Maybe [[Primitive]] -> [PD.Dynamic] -> [(PD.Dynamic,PD.Dynamic)] -> [[PD.Dynamic]] -> [[(PD.Dynamic,PD.Dynamic)]] -> Common -> a
updatePGXOptsFilt :: Int
-> (Common
    -> [Typed [CoreExpr]]
    -> [[Typed [CoreExpr]]]
    -> [[Typed [CoreExpr]]]
    -> a)
-> Maybe [[Primitive]]
-> [Dynamic]
-> [(Dynamic, Dynamic)]
-> [[Dynamic]]
-> [[(Dynamic, Dynamic)]]
-> Common
-> a
updatePGXOptsFilt Int
dep = (Common -> [[Dynamic]] -> [[Typed [CoreExpr]]])
-> (Common
    -> [Typed [CoreExpr]]
    -> [[Typed [CoreExpr]]]
    -> [[Typed [CoreExpr]]]
    -> a)
-> Maybe [[Primitive]]
-> [Dynamic]
-> [(Dynamic, Dynamic)]
-> [[Dynamic]]
-> [[(Dynamic, Dynamic)]]
-> Common
-> a
forall a.
(Common -> [[Dynamic]] -> [[Typed [CoreExpr]]])
-> (Common
    -> [Typed [CoreExpr]]
    -> [[Typed [CoreExpr]]]
    -> [[Typed [CoreExpr]]]
    -> a)
-> Maybe [[Primitive]]
-> [Dynamic]
-> [(Dynamic, Dynamic)]
-> [[Dynamic]]
-> [[(Dynamic, Dynamic)]]
-> Common
-> a
uPGXO (\Common
cmn [[Dynamic]]
dynss -> -- trace ("dynamicsp dynss = "++show (dynamicsp dynss) ++ "\nand the result is "++show (filtTCEsss cmn dep $ dynamicsp dynss)) $
                                             Common -> Int -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]]
filtTCEsss Common
cmn Int
dep ([[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]])
-> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]]
forall a b. (a -> b) -> a -> b
$ [[Dynamic]] -> [[Typed [CoreExpr]]]
dynamicsp [[Dynamic]]
dynss)
uPGXO :: (Common -> [[PD.Dynamic]] -> [[Typed [CoreExpr]]]) ->
               (Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]] -> a)
              -> Maybe [[Primitive]] -> [PD.Dynamic] -> [(PD.Dynamic,PD.Dynamic)] -> [[PD.Dynamic]] -> [[(PD.Dynamic,PD.Dynamic)]] -> Common -> a
uPGXO :: (Common -> [[Dynamic]] -> [[Typed [CoreExpr]]])
-> (Common
    -> [Typed [CoreExpr]]
    -> [[Typed [CoreExpr]]]
    -> [[Typed [CoreExpr]]]
    -> a)
-> Maybe [[Primitive]]
-> [Dynamic]
-> [(Dynamic, Dynamic)]
-> [[Dynamic]]
-> [[(Dynamic, Dynamic)]]
-> Common
-> a
uPGXO Common -> [[Dynamic]] -> [[Typed [CoreExpr]]]
dyp Common
-> [Typed [CoreExpr]]
-> [[Typed [CoreExpr]]]
-> [[Typed [CoreExpr]]]
-> a
mkt Maybe [[Primitive]]
mbpo [Dynamic]
classes [(Dynamic, Dynamic)]
partclasses [[Dynamic]]
prims [[(Dynamic, Dynamic)]]
partprims Common
c = case [Dynamic] -> [Dynamic] -> [Int] -> Common -> Common
updateCommon ([[Dynamic]] -> [Dynamic]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dynamic]]
totalss [Dynamic] -> [Dynamic] -> [Dynamic]
forall a. [a] -> [a] -> [a]
++ [Dynamic]
totalclss) ([[Dynamic]] -> [Dynamic]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dynamic]]
partialss [Dynamic] -> [Dynamic] -> [Dynamic]
forall a. [a] -> [a] -> [a]
++ [Dynamic]
partialclss) ([[Dynamic]] -> [Int]
forall a. [[a]] -> [Int]
mkDepths [[Dynamic]]
totalss [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ (Dynamic -> Int) -> [Dynamic] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Dynamic -> Int
forall a b. a -> b -> a
const Int
0) [Dynamic]
totalclss) Common
c of Common
cmn -> Common
-> [Typed [CoreExpr]]
-> [[Typed [CoreExpr]]]
-> [[Typed [CoreExpr]]]
-> a
mkt Common
cmn ([Dynamic] -> [Typed [CoreExpr]]
dynamicsc [Dynamic]
totalclss) (Common -> [[Typed [CoreExpr]]]
alt Common
cmn) (Common -> [[Dynamic]] -> [[Typed [CoreExpr]]]
dyp Common
cmn [[Dynamic]]
totalss) -- dyp c? vlをうまく同期させねば．
    where alt :: Common -> [[Typed [CoreExpr]]]
alt Common
cmn = case Maybe [[Primitive]]
mbpo of Maybe [[Primitive]]
Nothing -> Common -> [[Dynamic]] -> [[Typed [CoreExpr]]]
dyp Common
cmn [[Dynamic]]
totalss -- dyp c?
                                 Just [[Primitive]]
po -> TyConLib -> [[Primitive]] -> [[Typed [CoreExpr]]]
primitivesp (Common -> TyConLib
tcl Common
c) [[Primitive]]
po
          ([[Dynamic]]
tot, [[Dynamic]]
part) = [([Dynamic], [Dynamic])] -> ([[Dynamic]], [[Dynamic]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([Dynamic], [Dynamic])] -> ([[Dynamic]], [[Dynamic]]))
-> [([Dynamic], [Dynamic])] -> ([[Dynamic]], [[Dynamic]])
forall a b. (a -> b) -> a -> b
$ ([(Dynamic, Dynamic)] -> ([Dynamic], [Dynamic]))
-> [[(Dynamic, Dynamic)]] -> [([Dynamic], [Dynamic])]
forall a b. (a -> b) -> [a] -> [b]
map [(Dynamic, Dynamic)] -> ([Dynamic], [Dynamic])
forall a b. [(a, b)] -> ([a], [b])
unzip [[(Dynamic, Dynamic)]]
partprims
          totalss :: [[Dynamic]]
totalss     = [[Dynamic]] -> [[Dynamic]] -> [[Dynamic]]
forall a. [[a]] -> [[a]] -> [[a]]
zipAppend [[Dynamic]]
prims [[Dynamic]]
tot
          partialss :: [[Dynamic]]
partialss   = [[Dynamic]] -> [[Dynamic]] -> [[Dynamic]]
forall a. [[a]] -> [[a]] -> [[a]]
zipAppend [[Dynamic]]
prims [[Dynamic]]
part
          ([Dynamic]
totc,[Dynamic]
partc)= [(Dynamic, Dynamic)] -> ([Dynamic], [Dynamic])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Dynamic, Dynamic)]
partclasses
          totalclss :: [Dynamic]
totalclss   = [Dynamic]
classes [Dynamic] -> [Dynamic] -> [Dynamic]
forall a. [a] -> [a] -> [a]
++ [Dynamic]
totc
          partialclss :: [Dynamic]
partialclss = [Dynamic]
classes [Dynamic] -> [Dynamic] -> [Dynamic]
forall a. [a] -> [a] -> [a]
++ [Dynamic]
partc

mkDepths :: [[a]] -> [Int]
mkDepths :: [[a]] -> [Int]
mkDepths = [[Int]] -> [Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Int]] -> [Int]) -> ([[a]] -> [[Int]]) -> [[a]] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> [a] -> [Int]) -> [Int] -> [[a]] -> [[Int]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
i [a]
xs -> (a -> Int) -> [a] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> a -> Int
forall a b. a -> b -> a
const Int
i) [a]
xs) [Int
0..]

setPG :: ProgGen -> IO ()
setPG :: ProgGen -> IO ()
setPG = IORef ProgGen -> ProgGen -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef ProgGen
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] -> [Primitive] -> IO ()
setPrimitives :: [Primitive] -> [Primitive] -> IO ()
setPrimitives [Primitive]
classes [Primitive]
tups = do PG (ClassLib CoreExpr
_,MemoTrie CoreExpr
_,([[Prim]], [[Prim]])
_,Common
cmn) <- IORef ProgGen -> IO ProgGen
forall a. IORef a -> IO a
readIORef IORef ProgGen
refmemodeb
                                ProgGen -> IO ()
setPG (ProgGen -> IO ()) -> ProgGen -> IO ()
forall a b. (a -> b) -> a -> b
$ Options -> [Primitive] -> [Primitive] -> ProgGen
forall pg.
ProgramGenerator pg =>
Options -> [Primitive] -> [Primitive] -> pg
mkPGOpt ((Common -> Opt ()
opt Common
cmn){primopt :: Maybe [[Primitive]]
primopt=Maybe [[Primitive]]
forall a. Maybe a
Nothing}) [Primitive]
classes [Primitive]
tups
-- setPrimitives tups = writeIORef refmemodeb (mkPG tups) -- This definition overwrites the old configuration.

-- zipAppend is like zipWith (++), but the length of the resulting list is the same as that of the longer of the two list arguments.
zipAppend :: [[a]] -> [[a]] -> [[a]]
zipAppend :: [[a]] -> [[a]] -> [[a]]
zipAppend []       [[a]]
yss      = [[a]]
yss
zipAppend [[a]]
xss      []       = [[a]]
xss
zipAppend ([a]
xs:[[a]]
xss) ([a]
ys:[[a]]
yss) = ([a]
xs[a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++[a]
ys) [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]] -> [[a]] -> [[a]]
forall a. [[a]] -> [[a]] -> [[a]]
zipAppend [[a]]
xss [[a]]
yss

#if defined HASKELLSRC || defined HASKELLSRCEXTS
-- | 'load' loads a component library file.
load :: FilePath
     -> TH.ExpQ     -- ^ This becomes @[Primitive]@ when spliced.
load :: String -> ExpQ
load String
fp = do String
str <- IO String -> Q String
forall a. IO a -> Q a
runIO (IO String -> Q String) -> IO String -> Q String
forall a b. (a -> b) -> a -> b
$ String -> IO String
readFile String
fp
             String -> ExpQ
f String
str
-- | f is supposed to be used by load, but not hidden.
f :: String -> TH.ExpQ
f :: String -> ExpQ
f = ExpQ -> ExpQ
p (ExpQ -> ExpQ) -> (String -> ExpQ) -> String -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> ExpQ) -> (String -> Exp) -> String -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Exp
readHsTypeSigs
#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 :: Int -> IO ()
setTimeout Int
n = do Int
pto <- Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
newPTO Int
n
                  PG (ClassLib CoreExpr
x,MemoTrie CoreExpr
y,([[Prim]], [[Prim]])
z,Common
cmn) <- IORef ProgGen -> IO ProgGen
forall a. IORef a -> IO a
readIORef IORef ProgGen
refmemodeb
                  IORef ProgGen -> ProgGen -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef ProgGen
refmemodeb (ProgGen -> IO ()) -> ProgGen -> IO ()
forall a b. (a -> b) -> a -> b
$ (ClassLib CoreExpr, MemoTrie CoreExpr, ([[Prim]], [[Prim]]),
 Common)
-> ProgGen
PG (ClassLib CoreExpr
x,MemoTrie CoreExpr
y,([[Prim]], [[Prim]])
z,Common
cmn{opt :: Opt ()
opt = (Common -> Opt ()
opt Common
cmn){timeout :: Maybe Int
timeout=Int -> Maybe Int
forall a. a -> Maybe a
Just Int
pto}})
-- | 'unsetTimeout' disables timeout. This is the safe choice.
unsetTimeout :: IO ()
unsetTimeout :: IO ()
unsetTimeout = do PG (ClassLib CoreExpr
x,MemoTrie CoreExpr
y,([[Prim]], [[Prim]])
z,Common
cmn) <- IORef ProgGen -> IO ProgGen
forall a. IORef a -> IO a
readIORef IORef ProgGen
refmemodeb
                  IORef ProgGen -> ProgGen -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef ProgGen
refmemodeb (ProgGen -> IO ()) -> ProgGen -> IO ()
forall a b. (a -> b) -> a -> b
$ (ClassLib CoreExpr, MemoTrie CoreExpr, ([[Prim]], [[Prim]]),
 Common)
-> ProgGen
PG (ClassLib CoreExpr
x,MemoTrie CoreExpr
y,([[Prim]], [[Prim]])
z,Common
cmn{opt :: Opt ()
opt = (Common -> Opt ()
opt Common
cmn){timeout :: Maybe Int
timeout=Maybe Int
forall a. Maybe a
Nothing}})

setDepth :: Int -- ^ memoization depth. (Sub)expressions within this size are memoized, while greater expressions will be recomputed (to save the heap space).
         -> IO ()
setDepth :: Int -> IO ()
setDepth Int
d = do PG (ClassLib CoreExpr
x,MemoTrie CoreExpr
y,([[Prim]], [[Prim]])
z,Common
cmn) <- IORef ProgGen -> IO ProgGen
forall a. IORef a -> IO a
readIORef IORef ProgGen
refmemodeb
                IORef ProgGen -> ProgGen -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef ProgGen
refmemodeb (ProgGen -> IO ()) -> ProgGen -> IO ()
forall a b. (a -> b) -> a -> b
$ (ClassLib CoreExpr, MemoTrie CoreExpr, ([[Prim]], [[Prim]]),
 Common)
-> ProgGen
PG (ClassLib CoreExpr
x,MemoTrie CoreExpr
y,([[Prim]], [[Prim]])
z,Common
cmn{opt :: Opt ()
opt = (Common -> Opt ()
opt Common
cmn){memodepth :: Int
memodepth=Int
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 :: IORef ProgGen
refmemodeb = IO (IORef ProgGen) -> IORef ProgGen
forall a. IO a -> a
unsafePerformIO (ProgGen -> IO (IORef ProgGen)
forall a. a -> IO (IORef a)
newIORef ProgGen
defaultMD)
defaultMD :: ProgGen
defaultMD = [Primitive] -> ProgGen
forall pg. ProgramGenerator pg => [Primitive] -> pg
mkPG [] :: ProgGen

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

trsToTCstrs :: [TypeRep] -> [(Int, String)] -- Int is the arity of the TyCon. There can be duplicates.
trsToTCstrs :: [TypeRep] -> [(Int, String)]
trsToTCstrs [] = []
trsToTCstrs (TypeRep
tr:[TypeRep]
ts) = case TypeRep -> (TyCon, [TypeRep])
splitTyConApp TypeRep
tr of (TyCon
tc,[TypeRep]
trs) -> ([TypeRep] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeRep]
trs, TyCon -> String
tyConName TyCon
tc) (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
: [TypeRep] -> [(Int, String)]
trsToTCstrs ([TypeRep]
trs[TypeRep] -> [TypeRep] -> [TypeRep]
forall a. [a] -> [a] -> [a]
++[TypeRep]
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 => 
                 Bool -- ^ whether to include functions with unused arguments
                  -> IO (Every a)
getEverything :: Bool -> IO (Every a)
getEverything Bool
withAbsents = do 
                   ProgGen
memodeb <- IORef ProgGen -> IO ProgGen
forall a. IORef a -> IO a
readIORef IORef ProgGen
refmemodeb
                   Every a -> IO (Every a)
forall (m :: * -> *) a. Monad m => a -> m a
return (ProgGen -> Bool -> Every a
forall pg a.
(ProgramGenerator pg, Typeable a) =>
pg -> Bool -> Every a
everything ProgGen
memodeb Bool
withAbsents)
getEverythingF :: Typeable a => 
                  Bool -- ^ whether to include functions with unused arguments
                  -> IO (Every a)
getEverythingF :: Bool -> IO (Every a)
getEverythingF Bool
withAbsents = do 
                   ProgGen
memodeb <- IORef ProgGen -> IO ProgGen
forall a. IORef a -> IO a
readIORef IORef ProgGen
refmemodeb
                   Every a -> IO (Every a)
forall (m :: * -> *) a. Monad m => a -> m a
return (ProgGen -> Bool -> Every a
forall pg a.
(ProgramGenerator pg, Typeable a) =>
pg -> Bool -> Every a
everythingF ProgGen
memodeb Bool
withAbsents)
{-
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) =>
                     pg   -- ^ program generator
                  -> Bool -- ^ whether to include functions with unused arguments
                  -> Every a
everything :: pg -> Bool -> Every a
everything  pg
memodeb = a
-> pg
-> (Type -> Matrix AnnExpr -> Matrix (Exp, a))
-> Bool
-> Every a
forall pg a e.
(ProgramGenerator pg, Typeable a) =>
a
-> pg
-> (Type -> Matrix AnnExpr -> Matrix (e, a))
-> Bool
-> [[(e, a)]]
et a
forall a. HasCallStack => a
undefined  pg
memodeb (String -> pg -> Type -> Matrix AnnExpr -> Matrix (Exp, a)
forall e (m :: * -> *) pg a.
(Expression e, Search m, WithCommon pg, Typeable a) =>
String -> pg -> Type -> m e -> m (Exp, a)
mxExprToEvery   String
"MagicHaskeller.everything: type mismatch" pg
memodeb)
everythingF :: pg -> Bool -> Every a
everythingF pg
memodeb = a
-> pg
-> (Type -> Matrix AnnExpr -> Matrix (Exp, a))
-> Bool
-> Every a
forall pg a e.
(ProgramGenerator pg, Typeable a) =>
a
-> pg
-> (Type -> Matrix AnnExpr -> Matrix (e, a))
-> Bool
-> [[(e, a)]]
et a
forall a. HasCallStack => a
undefined  pg
memodeb (String -> pg -> Type -> Matrix AnnExpr -> Matrix (Exp, a)
forall e (m :: * -> *) pg a.
(Expression e, FiltrableBF m, WithCommon pg, Typeable a) =>
String -> pg -> Type -> m e -> m (Exp, a)
mxExprFiltEvery String
"MagicHaskeller.everythingF: type mismatch" pg
memodeb)
everyACE :: (ProgramGenerator pg, Typeable a) =>
                     pg   -- ^ program generator
                  -> Bool -- ^ whether to include functions with unused arguments
                  -> [[(CoreExpr,a)]]
everyACE :: pg -> Bool -> [[(CoreExpr, a)]]
everyACE  pg
memodeb = a
-> pg
-> (Type -> Matrix AnnExpr -> Matrix (CoreExpr, a))
-> Bool
-> [[(CoreExpr, a)]]
forall pg a e.
(ProgramGenerator pg, Typeable a) =>
a
-> pg
-> (Type -> Matrix AnnExpr -> Matrix (e, a))
-> Bool
-> [[(e, a)]]
et a
forall a. HasCallStack => a
undefined  pg
memodeb (String -> pg -> Type -> Matrix AnnExpr -> Matrix (CoreExpr, a)
forall e (m :: * -> *) pg a.
(Expression e, Search m, WithCommon pg, Typeable a) =>
String -> pg -> Type -> m e -> m (CoreExpr, a)
mxExprToACE   String
"MagicHaskeller.everyACE: type mismatch" pg
memodeb)
et :: (ProgramGenerator pg, Typeable a) =>
                     a    -- ^ dummy argument
                  -> pg   -- ^ program generator
                  -> (Types.Type -> Matrix AnnExpr -> Matrix (e,a))
                  -> Bool -- ^ whether to include functions with unused arguments
                  -> [[(e,a)]]
et :: a
-> pg
-> (Type -> Matrix AnnExpr -> Matrix (e, a))
-> Bool
-> [[(e, a)]]
et a
dmy pg
memodeb Type -> Matrix AnnExpr -> Matrix (e, a)
filt Bool
withAbsents = Matrix (e, a) -> [[(e, a)]]
forall a. Matrix a -> Stream (Bag a)
unMx (Matrix (e, a) -> [[(e, a)]]) -> Matrix (e, a) -> [[(e, a)]]
forall a b. (a -> b) -> a -> b
$ Type -> Matrix AnnExpr -> Matrix (e, a)
filt Type
ty (Matrix AnnExpr -> Matrix (e, a))
-> Matrix AnnExpr -> Matrix (e, a)
forall a b. (a -> b) -> a -> b
$ Bool -> Type -> pg -> Matrix AnnExpr
forall a (m :: * -> *).
(ProgramGenerator a, Search m) =>
Bool -> Type -> a -> m AnnExpr
matchPs Bool
withAbsents Type
ty pg
memodeb
    where ty :: Type
ty = TyConLib -> TypeRep -> Type
trToType (pg -> TyConLib
forall a. WithCommon a => a -> TyConLib
extractTCL pg
memodeb) (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
dmy)
noFilter :: ProgramGenerator pg => pg -> Types.Type -> a -> a
noFilter :: pg -> Type -> a -> a
noFilter pg
_m Type
_t = a -> a
forall a. a -> a
id

matchPs :: Bool -> Type -> a -> m AnnExpr
matchPs Bool
True  = Type -> a -> m AnnExpr
forall a (m :: * -> *).
(ProgramGenerator a, Search m) =>
Type -> a -> m AnnExpr
matchingPrograms
matchPs Bool
False = Type -> a -> m AnnExpr
forall a (m :: * -> *).
(ProgramGenerator a, Search m) =>
Type -> a -> m AnnExpr
matchingProgramsWOAbsents 

mxExprToEvery :: (Expression e, Search m, WithCommon pg, Typeable a) => String -> pg -> Types.Type -> m e -> m (Exp, a)
mxExprToEvery :: String -> pg -> Type -> m e -> m (Exp, a)
mxExprToEvery   String
msg pg
memodeb Type
_  = (e -> (Exp, a)) -> m e -> m (Exp, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (VarLib -> String -> pg -> AnnExpr -> (Exp, a)
forall pg a.
(WithCommon pg, Typeable a) =>
VarLib -> String -> pg -> AnnExpr -> (Exp, a)
unwrapAE (pg -> VarLib
forall a. WithCommon a => a -> VarLib
extractVL pg
memodeb) String
msg pg
memodeb (AnnExpr -> (Exp, a)) -> (e -> AnnExpr) -> e -> (Exp, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoreExpr -> Dynamic) -> e -> AnnExpr
forall e. Expression e => (CoreExpr -> Dynamic) -> e -> AnnExpr
toAnnExpr (Common -> CoreExpr -> Dynamic
reducer (Common -> CoreExpr -> Dynamic) -> Common -> CoreExpr -> Dynamic
forall a b. (a -> b) -> a -> b
$ pg -> Common
forall a. WithCommon a => a -> Common
extractCommon pg
memodeb))
mxExprFiltEvery :: (Expression e, FiltrableBF m, WithCommon pg, Typeable a) => String -> pg -> Types.Type -> m e -> m (Exp, a)
mxExprFiltEvery :: String -> pg -> Type -> m e -> m (Exp, a)
mxExprFiltEvery String
msg pg
memodeb Type
ty = (AnnExpr -> (Exp, a)) -> m AnnExpr -> m (Exp, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (VarLib -> String -> pg -> AnnExpr -> (Exp, a)
forall pg a.
(WithCommon pg, Typeable a) =>
VarLib -> String -> pg -> AnnExpr -> (Exp, a)
unwrapAE (pg -> VarLib
forall a. WithCommon a => a -> VarLib
extractVL pg
memodeb) String
msg pg
memodeb) (m AnnExpr -> m (Exp, a))
-> (m e -> m AnnExpr) -> m e -> m (Exp, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. pg -> Type -> m AnnExpr -> m AnnExpr
forall (m :: * -> *) a.
(FiltrableBF m, WithCommon a) =>
a -> Type -> m AnnExpr -> m AnnExpr
randomTestFilter pg
memodeb Type
ty (m AnnExpr -> m AnnExpr) -> (m e -> m AnnExpr) -> m e -> m AnnExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. pg -> m e -> m AnnExpr
forall (f :: * -> *) e a.
(Functor f, Expression e, WithCommon a) =>
a -> f e -> f AnnExpr
mxExpr pg
memodeb
mxExpr :: a -> f e -> f AnnExpr
mxExpr a
memodeb = (e -> AnnExpr) -> f e -> f AnnExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CoreExpr -> Dynamic) -> e -> AnnExpr
forall e. Expression e => (CoreExpr -> Dynamic) -> e -> AnnExpr
toAnnExpr (Common -> CoreExpr -> Dynamic
reducer (Common -> CoreExpr -> Dynamic) -> Common -> CoreExpr -> Dynamic
forall a b. (a -> b) -> a -> b
$ a -> Common
forall a. WithCommon a => a -> Common
extractCommon a
memodeb))
mxExprToACE :: (Expression e, Search m, WithCommon pg, Typeable a) => String -> pg -> Types.Type -> m e -> m (CoreExpr, a)
mxExprToACE :: String -> pg -> Type -> m e -> m (CoreExpr, a)
mxExprToACE   String
msg pg
memodeb Type
_  = (e -> (CoreExpr, a)) -> m e -> m (CoreExpr, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> pg -> AnnExpr -> (CoreExpr, a)
forall pg a.
(WithCommon pg, Typeable a) =>
String -> pg -> AnnExpr -> (CoreExpr, a)
unwrapToCE String
msg pg
memodeb (AnnExpr -> (CoreExpr, a)) -> (e -> AnnExpr) -> e -> (CoreExpr, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoreExpr -> Dynamic) -> e -> AnnExpr
forall e. Expression e => (CoreExpr -> Dynamic) -> e -> AnnExpr
toAnnExpr (Common -> CoreExpr -> Dynamic
reducer (Common -> CoreExpr -> Dynamic) -> Common -> CoreExpr -> Dynamic
forall a b. (a -> b) -> a -> b
$ pg -> Common
forall a. WithCommon a => a -> Common
extractCommon pg
memodeb))

unwrapAE :: (WithCommon pg, Typeable a) => VarLib -> String -> pg -> AnnExpr -> (Exp, a)
unwrapAE :: VarLib -> String -> pg -> AnnExpr -> (Exp, a)
unwrapAE VarLib
vl String
msg pg
memodeb (AE CoreExpr
e Dynamic
dyn) = (VarLib -> CoreExpr -> Exp
exprToTHExp VarLib
vl CoreExpr
e, TyConLib -> Dynamic -> a -> a
forall a. Typeable a => TyConLib -> Dynamic -> a -> a
fromDyn TyConLib
tcl Dynamic
dyn (String -> a
forall a. HasCallStack => String -> a
error String
msg))
    where tcl :: TyConLib
tcl = pg -> TyConLib
forall a. WithCommon a => a -> TyConLib
extractTCL pg
memodeb
unwrapToCE :: (WithCommon pg, Typeable a) => String -> pg -> AnnExpr -> (CoreExpr, a)
unwrapToCE :: String -> pg -> AnnExpr -> (CoreExpr, a)
unwrapToCE String
msg pg
memodeb ae :: AnnExpr
ae@(AE CoreExpr
e Dynamic
dyn) = (CoreExpr
e, TyConLib -> Dynamic -> a -> a
forall a. Typeable a => TyConLib -> Dynamic -> a -> a
fromDyn TyConLib
tcl Dynamic
dyn (String -> a
forall a. HasCallStack => String -> a
error String
msg))
    where tcl :: TyConLib
tcl = pg -> TyConLib
forall a. WithCommon a => a -> TyConLib
extractTCL pg
memodeb


etup :: (ProgramGenerator pg, Typeable a) =>
                     a    -- ^ dummy argument
                  -> pg   -- ^ program generator
                  -> Bool -- ^ whether to include functions with unused arguments
                  -> [[((Exp,a), (Exp,a))]]
etup :: a -> pg -> Bool -> [[((Exp, a), (Exp, a))]]
etup a
dmy pg
memodeb Bool
withAbsents 
  = Matrix ((Exp, a), (Exp, a)) -> [[((Exp, a), (Exp, a))]]
forall a. Matrix a -> Stream (Bag a)
unMx 
    (Matrix ((Exp, a), (Exp, a)) -> [[((Exp, a), (Exp, a))]])
-> Matrix ((Exp, a), (Exp, a)) -> [[((Exp, a), (Exp, a))]]
forall a b. (a -> b) -> a -> b
$ (AnnExpr -> ((Exp, a), (Exp, a)))
-> Matrix AnnExpr -> Matrix ((Exp, a), (Exp, a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\AnnExpr
e -> (VarLib -> String -> pg -> AnnExpr -> (Exp, a)
forall pg a.
(WithCommon pg, Typeable a) =>
VarLib -> String -> pg -> AnnExpr -> (Exp, a)
unwrapAE (Common -> VarLib
vl Common
cmn) String
"MagicHaskeller.etup: type mismatch" pg
memodeb (AnnExpr -> (Exp, a)) -> AnnExpr -> (Exp, a)
forall a b. (a -> b) -> a -> b
$ (CoreExpr -> Dynamic) -> AnnExpr -> AnnExpr
forall e. Expression e => (CoreExpr -> Dynamic) -> e -> AnnExpr
toAnnExpr (Opt () -> VarLib -> CoreExpr -> Dynamic
forall a. Opt a -> VarLib -> CoreExpr -> Dynamic
execute (Common -> Opt ()
opt Common
cmn) (Common -> VarLib
vl Common
cmn)) AnnExpr
e, 
                   VarLib -> String -> pg -> AnnExpr -> (Exp, a)
forall pg a.
(WithCommon pg, Typeable a) =>
VarLib -> String -> pg -> AnnExpr -> (Exp, a)
unwrapAE (Common -> VarLib
pvl Common
cmn) String
"MagicHaskeller.etup: type mismatch" pg
memodeb (AnnExpr -> (Exp, a)) -> AnnExpr -> (Exp, a)
forall a b. (a -> b) -> a -> b
$ (CoreExpr -> Dynamic) -> CoreExpr -> AnnExpr
forall e. Expression e => (CoreExpr -> Dynamic) -> e -> AnnExpr
toAnnExpr (Opt () -> VarLib -> CoreExpr -> Dynamic
forall a. Opt a -> VarLib -> CoreExpr -> Dynamic
execute (Common -> Opt ()
opt Common
cmn) (Common -> VarLib
pvl Common
cmn)) (CoreExpr -> AnnExpr) -> CoreExpr -> AnnExpr
forall a b. (a -> b) -> a -> b
$ AnnExpr -> CoreExpr
forall e. Expression e => e -> CoreExpr
toCE AnnExpr
e))
    (Matrix AnnExpr -> Matrix ((Exp, a), (Exp, a)))
-> Matrix AnnExpr -> Matrix ((Exp, a), (Exp, a))
forall a b. (a -> b) -> a -> b
$  Bool -> Type -> pg -> Matrix AnnExpr
forall a (m :: * -> *).
(ProgramGenerator a, Search m) =>
Bool -> Type -> a -> m AnnExpr
matchPs Bool
withAbsents Type
ty pg
memodeb
    where ty :: Type
ty  = TyConLib -> TypeRep -> Type
trToType (pg -> TyConLib
forall a. WithCommon a => a -> TyConLib
extractTCL pg
memodeb) (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
dmy)
          cmn :: Common
cmn = pg -> Common
forall a. WithCommon a => a -> Common
extractCommon pg
memodeb
{-
無限リストを使うなら，unsafeInterleaveIOが必要なはず．その場合IOに特化することになる．
-}
everythingM :: (ProgramGenerator pg, Typeable a, Monad m, Functor m) =>
                     pg   -- ^ program generator
                  -> Bool -- ^ whether to include functions with unused arguments
                  -> Int  -- ^ query depth
                  -> m [(TH.Exp, a)]
everythingM :: pg -> Bool -> Int -> m [(Exp, a)]
everythingM = a -> pg -> Bool -> Int -> m [(Exp, a)]
forall pg a (m :: * -> *).
(ProgramGenerator pg, Typeable a, Monad m, Functor m) =>
a -> pg -> Bool -> Int -> m [(Exp, a)]
eM a
forall a. HasCallStack => a
undefined
eM :: (ProgramGenerator pg, Typeable a, Monad m, Functor m) =>
                     a    -- ^ dummy argument
                  -> pg   -- ^ program generator
                  -> Bool -- ^ whether to include functions with unused arguments
                  -> Int
                  -> m [(TH.Exp, a)]
eM :: a -> pg -> Bool -> Int -> m [(Exp, a)]
eM a
dmy pg
memodeb Bool
withAbsents = Int -> m [(Exp, a)]
result
    where tcl :: TyConLib
tcl = pg -> TyConLib
forall a. WithCommon a => a -> TyConLib
extractTCL pg
memodeb
          ty :: Type
ty  = TyConLib -> TypeRep -> Type
trToType TyConLib
tcl (TypeRep -> Type) -> TypeRep -> Type
forall a b. (a -> b) -> a -> b
$ a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
dmy
          result :: Int -> m [(Exp, a)]
result = RecompT m (Exp, a) -> Int -> m [(Exp, a)]
forall (m :: * -> *) a. RecompT m a -> Int -> m (Bag a)
unRcT (RecompT m (Exp, a) -> Int -> m [(Exp, a)])
-> RecompT m (Exp, a) -> Int -> m [(Exp, a)]
forall a b. (a -> b) -> a -> b
$ String -> pg -> Type -> RecompT m AnnExpr -> RecompT m (Exp, a)
forall e (m :: * -> *) pg a.
(Expression e, Search m, WithCommon pg, Typeable a) =>
String -> pg -> Type -> m e -> m (Exp, a)
mxExprToEvery String
"MagicHaskeller.everythingM: type mismatch" pg
memodeb Type
forall a. HasCallStack => a
undefined (RecompT m AnnExpr -> RecompT m (Exp, a))
-> RecompT m AnnExpr -> RecompT m (Exp, a)
forall a b. (a -> b) -> a -> b
$ Bool -> Type -> pg -> RecompT m AnnExpr
forall a (m :: * -> *).
(ProgramGenerator a, Search m) =>
Bool -> Type -> a -> m AnnExpr
matchPs Bool
withAbsents Type
ty pg
memodeb
everythingIO :: (ProgramGeneratorIO pg, Typeable a) =>
                     pg   -- ^ program generator
                  -> EveryIO a
everythingIO :: pg -> EveryIO a
everythingIO = a -> pg -> EveryIO a
forall pg a.
(ProgramGeneratorIO pg, Typeable a) =>
a -> pg -> EveryIO a
eIO a
forall a. HasCallStack => a
undefined
eIO :: (ProgramGeneratorIO pg, Typeable a) =>
                     a    -- ^ dummy argument
                  -> pg   -- ^ program generator
                  -> EveryIO a
eIO :: a -> pg -> EveryIO a
eIO a
dmy pg
memodeb = EveryIO a
result
    where tcl :: TyConLib
tcl = pg -> TyConLib
forall a. WithCommon a => a -> TyConLib
extractTCL pg
memodeb
          ty :: Type
ty  = TyConLib -> TypeRep -> Type
trToType TyConLib
tcl (TypeRep -> Type) -> TypeRep -> Type
forall a b. (a -> b) -> a -> b
$ a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
dmy
          result :: EveryIO a
result = RecompT IO (Exp, a) -> EveryIO a
forall (m :: * -> *) a. RecompT m a -> Int -> m (Bag a)
unRcT (RecompT IO (Exp, a) -> EveryIO a)
-> RecompT IO (Exp, a) -> EveryIO a
forall a b. (a -> b) -> a -> b
$ String -> pg -> Type -> RecompT IO AnnExpr -> RecompT IO (Exp, a)
forall e (m :: * -> *) pg a.
(Expression e, Search m, WithCommon pg, Typeable a) =>
String -> pg -> Type -> m e -> m (Exp, a)
mxExprToEvery String
"MagicHaskeller.everythingIO: type mismatch" pg
memodeb Type
forall a. HasCallStack => a
undefined (RecompT IO AnnExpr -> RecompT IO (Exp, a))
-> RecompT IO AnnExpr -> RecompT IO (Exp, a)
forall a b. (a -> b) -> a -> b
$ Type -> pg -> RecompT IO AnnExpr
forall a. ProgramGeneratorIO a => Type -> a -> RecompT IO AnnExpr
matchingProgramsIO Type
ty pg
memodeb

strip :: m (Every a) -> a
strip :: m (Every a) -> a
strip = m (Every a) -> a
forall a. HasCallStack => a
undefined

stripEvery :: Every a -> a
stripEvery :: Every a -> a
stripEvery = [a] -> a
forall a. [a] -> a
head ([a] -> a) -> (Every a -> [a]) -> Every a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Exp, a) -> a) -> [(Exp, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Exp, a) -> a
forall a b. (a, b) -> b
snd ([(Exp, a)] -> [a]) -> (Every a -> [(Exp, a)]) -> Every a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Every a -> [(Exp, a)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat

unifyable, matching, unifyableF, matchingF :: ProgramGenerator pg =>
                                              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 :: pg -> Type -> [[Exp]]
unifyable pg
memodeb Type
tht =  Matrix Exp -> [[Exp]]
forall a. Matrix a -> Stream (Bag a)
unMx (Matrix Exp -> [[Exp]]) -> Matrix Exp -> [[Exp]]
forall a b. (a -> b) -> a -> b
$ (pg -> Type -> Matrix AnnExpr -> Matrix AnnExpr)
-> (Type -> pg -> Matrix AnnExpr) -> pg -> Type -> Matrix Exp
forall t (f :: * -> *) (f :: * -> *) e e.
(WithCommon t, Functor f, Functor f, Expression e, Expression e) =>
(t -> Type -> f AnnExpr -> f e)
-> (Type -> t -> f e) -> t -> Type -> f Exp
genExps pg -> Type -> Matrix AnnExpr -> Matrix AnnExpr
forall pg a. ProgramGenerator pg => pg -> Type -> a -> a
noFilter Type -> pg -> Matrix AnnExpr
forall a (m :: * -> *).
(ProgramGenerator a, Search m) =>
Type -> a -> m AnnExpr
unifyingPrograms  pg
memodeb Type
tht
matching :: pg -> Type -> [[Exp]]
matching   pg
memodeb Type
tht =  Matrix Exp -> [[Exp]]
forall a. Matrix a -> Stream (Bag a)
unMx (Matrix Exp -> [[Exp]]) -> Matrix Exp -> [[Exp]]
forall a b. (a -> b) -> a -> b
$ (pg -> Type -> Matrix AnnExpr -> Matrix AnnExpr)
-> (Type -> pg -> Matrix AnnExpr) -> pg -> Type -> Matrix Exp
forall t (f :: * -> *) (f :: * -> *) e e.
(WithCommon t, Functor f, Functor f, Expression e, Expression e) =>
(t -> Type -> f AnnExpr -> f e)
-> (Type -> t -> f e) -> t -> Type -> f Exp
genExps pg -> Type -> Matrix AnnExpr -> Matrix AnnExpr
forall pg a. ProgramGenerator pg => pg -> Type -> a -> a
noFilter Type -> pg -> Matrix AnnExpr
forall a (m :: * -> *).
(ProgramGenerator a, Search m) =>
Type -> a -> m AnnExpr
matchingPrograms  pg
memodeb Type
tht
-- unifyablePos  memodeb tht = unMx $ toMx $ fmap (\(es,subst,mx) -> (map (pprintUC . exprToTHExp (extractVL memodeb)) es, subst, mx)) $ unifyingPossibilities (thTypeToType (extractTCL memodeb) tht) memodeb
unifyableF :: pg -> Type -> [[Exp]]
unifyableF  pg
memodeb Type
tht = Matrix Exp -> [[Exp]]
forall a. Matrix a -> Stream (Bag a)
unMx (Matrix Exp -> [[Exp]]) -> Matrix Exp -> [[Exp]]
forall a b. (a -> b) -> a -> b
$ (pg -> Type -> Matrix AnnExpr -> Matrix AnnExpr)
-> (Type -> pg -> Matrix AnnExpr) -> pg -> Type -> Matrix Exp
forall t (f :: * -> *) (f :: * -> *) e e.
(WithCommon t, Functor f, Functor f, Expression e, Expression e) =>
(t -> Type -> f AnnExpr -> f e)
-> (Type -> t -> f e) -> t -> Type -> f Exp
genExps pg -> Type -> Matrix AnnExpr -> Matrix AnnExpr
forall (m :: * -> *) a.
(FiltrableBF m, WithCommon a) =>
a -> Type -> m AnnExpr -> m AnnExpr
randomTestFilter Type -> pg -> Matrix AnnExpr
forall a (m :: * -> *).
(ProgramGenerator a, Search m) =>
Type -> a -> m AnnExpr
unifyingPrograms  pg
memodeb Type
tht
matchingF :: pg -> Type -> [[Exp]]
matchingF   pg
memodeb Type
tht = Matrix Exp -> [[Exp]]
forall a. Matrix a -> Stream (Bag a)
unMx (Matrix Exp -> [[Exp]]) -> Matrix Exp -> [[Exp]]
forall a b. (a -> b) -> a -> b
$ (pg -> Type -> Matrix AnnExpr -> Matrix AnnExpr)
-> (Type -> pg -> Matrix AnnExpr) -> pg -> Type -> Matrix Exp
forall t (f :: * -> *) (f :: * -> *) e e.
(WithCommon t, Functor f, Functor f, Expression e, Expression e) =>
(t -> Type -> f AnnExpr -> f e)
-> (Type -> t -> f e) -> t -> Type -> f Exp
genExps pg -> Type -> Matrix AnnExpr -> Matrix AnnExpr
forall (m :: * -> *) a.
(FiltrableBF m, WithCommon a) =>
a -> Type -> m AnnExpr -> m AnnExpr
randomTestFilter Type -> pg -> Matrix AnnExpr
forall a (m :: * -> *).
(ProgramGenerator a, Search m) =>
Type -> a -> m AnnExpr
matchingPrograms  pg
memodeb Type
tht
genExps :: (t -> Type -> f AnnExpr -> f e)
-> (Type -> t -> f e) -> t -> Type -> f Exp
genExps t -> Type -> f AnnExpr -> f e
filt Type -> t -> f e
rawGenProgs  t
memodeb Type
tht
    = case TyConLib -> Type -> Type
thTypeToType (t -> TyConLib
forall a. WithCommon a => a -> TyConLib
extractTCL t
memodeb) Type
tht of
        Type
ty -> (e -> Exp) -> f e -> f Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (VarLib -> CoreExpr -> Exp
exprToTHExp (t -> VarLib
forall a. WithCommon a => a -> VarLib
extractVL t
memodeb) (CoreExpr -> Exp) -> (e -> CoreExpr) -> e -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> CoreExpr
forall e. Expression e => e -> CoreExpr
toCE) (f e -> f Exp) -> f e -> f Exp
forall a b. (a -> b) -> a -> b
$
              t -> Type -> f AnnExpr -> f e
filt t
memodeb Type
ty (f AnnExpr -> f e) -> f AnnExpr -> f e
forall a b. (a -> b) -> a -> b
$ (e -> AnnExpr) -> f e -> f AnnExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CoreExpr -> Dynamic) -> e -> AnnExpr
forall e. Expression e => (CoreExpr -> Dynamic) -> e -> AnnExpr
toAnnExpr (Common -> CoreExpr -> Dynamic
reducer (Common -> CoreExpr -> Dynamic) -> Common -> CoreExpr -> Dynamic
forall a b. (a -> b) -> a -> b
$ t -> Common
forall a. WithCommon a => a -> Common
extractCommon t
memodeb)) (Type -> t -> f e
rawGenProgs Type
ty t
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  memodeb tht =  unMx $ toMx $ fmap show (specializedPossibleTypes (thTypeToType (extractTCL memodeb) tht) 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 => 
           Bool -- ^ whether to include functions with unused arguments
           -> (a->Bool) -> TH.Exp
findOne :: Bool -> (a -> Bool) -> Exp
findOne Bool
withAbsents a -> Bool
pred = IO Exp -> Exp
forall a. IO a -> a
unsafePerformIO (IO Exp -> Exp) -> IO Exp -> Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> IO Exp -> IO Exp) -> Bool -> (a -> Bool) -> IO Exp
forall a b.
Typeable a =>
(Exp -> IO b -> IO b) -> Bool -> (a -> Bool) -> IO b
findDo (\Exp
e IO Exp
_ -> Exp -> IO Exp
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
e) Bool
withAbsents a -> Bool
pred

-- | 'printOne' prints the expression found first. 
printOne :: Typeable a => 
            Bool -- ^ whether to include functions with unused arguments
            -> (a->Bool) -> IO TH.Exp
printOne :: Bool -> (a -> Bool) -> IO Exp
printOne Bool
withAbsents a -> Bool
pred = do 
                   Exp
expr <- (Exp -> IO Exp -> IO Exp) -> Bool -> (a -> Bool) -> IO Exp
forall a b.
Typeable a =>
(Exp -> IO b -> IO b) -> Bool -> (a -> Bool) -> IO b
findDo (\Exp
e IO Exp
_ -> Exp -> IO Exp
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
e) Bool
withAbsents a -> Bool
pred
                   String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Exp -> String
forall a. (Ppr a, Data a) => a -> String
pprintUC Exp
expr
                   Exp -> IO Exp
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
expr
-- | 'printAll' prints all the expressions satisfying the given predicate.
printAll, printAny :: Typeable a =>
                      Bool -- ^ whether to include functions with unused arguments
                      ->  (a->Bool) -> IO ()
printAny :: Bool -> (a -> Bool) -> IO ()
printAny = Bool -> (a -> Bool) -> IO ()
forall a. Typeable a => Bool -> (a -> Bool) -> IO ()
printAll -- provided just for backward compatibility
printAll :: Bool -> (a -> Bool) -> IO ()
printAll = (Exp -> IO () -> IO ()) -> Bool -> (a -> Bool) -> IO ()
forall a b.
Typeable a =>
(Exp -> IO b -> IO b) -> Bool -> (a -> Bool) -> IO b
findDo (\Exp
e IO ()
r -> String -> IO ()
putStrLn (Exp -> String
forall a. (Ppr a, Data a) => a -> String
pprintUC Exp
e) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
r)

printAllF :: (Typeable a, Filtrable a) =>
             Bool -- ^ whether to include functions with unused arguments
             ->  (a->Bool) -> IO ()
printAllF :: Bool -> (a -> Bool) -> IO ()
printAllF Bool
withAbsents a -> Bool
pred = do 
                    Every a
et  <- Bool -> IO (Every a)
forall a. Typeable a => Bool -> IO (Every a)
getEverything Bool
withAbsents
                    Every a
fet <- (a -> Bool) -> Every a -> IO (Every a)
forall a.
(Typeable a, Filtrable a) =>
(a -> Bool) -> Every a -> IO (Every a)
filterThenF a -> Bool
pred Every a
et
                    Every a -> IO ()
forall a. Every a -> IO ()
pprs Every a
fet

findDo :: Typeable a => 
          (TH.Exp -> IO b -> IO b) 
          -> Bool -- ^ whether to include functions with unused arguments
          -> (a->Bool) -> IO b
findDo :: (Exp -> IO b -> IO b) -> Bool -> (a -> Bool) -> IO b
findDo Exp -> IO b -> IO b
op Bool
withAbsents a -> Bool
pred = do 
                     Every a
et <- Bool -> IO (Every a)
forall a. Typeable a => Bool -> IO (Every a)
getEverything Bool
withAbsents
                     ProgGen
md <- IORef ProgGen -> IO ProgGen
forall a. IORef a -> IO a
readIORef IORef ProgGen
refmemodeb
                     let mpto :: Maybe Int
mpto = Opt () -> Maybe Int
forall a. Opt a -> Maybe Int
timeout (Opt () -> Maybe Int) -> Opt () -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Common -> Opt ()
opt (Common -> Opt ()) -> Common -> Opt ()
forall a b. (a -> b) -> a -> b
$ ProgGen -> Common
forall a. WithCommon a => a -> Common
extractCommon ProgGen
md
                     Maybe Int -> [(Exp, a)] -> IO b
fp Maybe Int
mpto (Every a -> [(Exp, a)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat Every a
et)
    where fp :: Maybe Int -> [(Exp, a)] -> IO b
fp Maybe Int
mpto ((Exp
e,a
a):[(Exp, a)]
ts) = do -- hPutStrLn stderr ("trying" ++ pprintUC e)
                                  Maybe Bool
result <- (Bool -> IO () -> IO ()) -> Maybe Int -> IO Bool -> IO (Maybe Bool)
forall a.
(a -> IO () -> IO ()) -> Maybe Int -> IO a -> IO (Maybe a)
maybeWithTO Bool -> IO () -> IO ()
seq Maybe Int
mpto (Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Bool
pred a
a))
                                  case Maybe Bool
result of Just Bool
True  -> Exp
e Exp -> IO b -> IO b
`op` Maybe Int -> [(Exp, a)] -> IO b
fp Maybe Int
mpto [(Exp, a)]
ts
                                                 Just Bool
False -> Maybe Int -> [(Exp, a)] -> IO b
fp Maybe Int
mpto [(Exp, a)]
ts
                                                 Maybe Bool
Nothing    -> Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"timeout on "String -> String -> String
forall a. [a] -> [a] -> [a]
++Exp -> String
forall a. (Ppr a, Data a) => a -> String
pprintUC Exp
e) IO () -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Int -> [(Exp, a)] -> IO b
fp Maybe Int
mpto [(Exp, a)]
ts
-- x 本当はrecompのままでやった方が速いはず．

-- | 'filterFirst' is like 'printAll', 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 =>
               Bool -- ^ whether to include functions with unused arguments
               ->  (a->Bool) -> IO (Every a)
filterFirst :: Bool -> (a -> Bool) -> IO (Every a)
filterFirst Bool
withAbsents a -> Bool
pred = do 
                      Every a
et <- Bool -> IO (Every a)
forall a. Typeable a => Bool -> IO (Every a)
getEverything Bool
withAbsents
                      (a -> Bool) -> Every a -> IO (Every a)
forall a. Typeable a => (a -> Bool) -> Every a -> IO (Every a)
filterThen a -> Bool
pred Every a
et
-- randomTestFilter should be applied after filterThen, because it's slower
filterFirstF :: (Typeable a, Filtrable a) => 
                Bool -- ^ whether to include functions with unused arguments
                -> (a->Bool) -> IO (Every a)
filterFirstF :: Bool -> (a -> Bool) -> IO (Every a)
filterFirstF Bool
withAbsents a -> Bool
pred = do 
                       Every a
et <- Bool -> IO (Every a)
forall a. Typeable a => Bool -> IO (Every a)
getEverything Bool
withAbsents
                       (a -> Bool) -> Every a -> IO (Every a)
forall a.
(Typeable a, Filtrable a) =>
(a -> Bool) -> Every a -> IO (Every a)
filterThenF a -> Bool
pred Every a
et
filterThenF :: (a -> Bool) -> Every a -> IO (Every a)
filterThenF a -> Bool
pred Every a
et = do
                       Every a
fd <- (a -> Bool) -> Every a -> IO (Every a)
forall a. Typeable a => (a -> Bool) -> Every a -> IO (Every a)
filterThen a -> Bool
pred Every a
et
                       ProgGen
memodeb <- IORef ProgGen -> IO ProgGen
forall a. IORef a -> IO a
readIORef IORef ProgGen
refmemodeb
                       let o :: Opt ()
o = Common -> Opt ()
opt (Common -> Opt ()) -> Common -> Opt ()
forall a b. (a -> b) -> a -> b
$ ProgGen -> Common
forall a. WithCommon a => a -> Common
extractCommon ProgGen
memodeb
                       Every a -> IO (Every a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Every a -> IO (Every a)) -> Every a -> IO (Every a)
forall a b. (a -> b) -> a -> b
$ Opt () -> Every a -> Every a
forall a b e.
(Typeable a, Filtrable a) =>
Opt b -> [[(e, a)]] -> [[(e, a)]]
everyF Opt ()
o Every a
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) =>
          Opt b
              -> [[(e,a)]] -> [[(e,a)]]
everyF :: Opt b -> [[(e, a)]] -> [[(e, a)]]
everyF Opt b
o = Matrix (e, a) -> [[(e, a)]]
forall a. Matrix a -> Stream (Bag a)
unMx (Matrix (e, a) -> [[(e, a)]])
-> ([[(e, a)]] -> Matrix (e, a)) -> [[(e, a)]] -> [[(e, a)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> (Int -> Int) -> Matrix (e, a) -> Matrix (e, a)
forall (m :: * -> *) a e.
(SStrategy m, Filtrable a) =>
Maybe Int -> (Int -> Int) -> m (e, a) -> m (e, a)
unsafeRandomTestFilter (Opt b -> Maybe Int
forall a. Opt a -> Maybe Int
timeout Opt b
o) (Opt b -> Int -> Int
forall a. Opt a -> Int -> Int
fcnrand Opt b
o) (Matrix (e, a) -> Matrix (e, a))
-> ([[(e, a)]] -> Matrix (e, a)) -> [[(e, a)]] -> Matrix (e, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(e, a)]] -> Matrix (e, a)
forall a. Stream (Bag a) -> Matrix a
Mx 

-- | 'filterThen' may be used to further filter the results.
filterThen :: Typeable a => (a->Bool) -> Every a -> IO (Every a)
filterThen :: (a -> Bool) -> Every a -> IO (Every a)
filterThen a -> Bool
pred Every a
ts = do ProgGen
md <- IORef ProgGen -> IO ProgGen
forall a. IORef a -> IO a
readIORef IORef ProgGen
refmemodeb
                        let mpto :: Maybe Int
mpto = Opt () -> Maybe Int
forall a. Opt a -> Maybe Int
timeout (Opt () -> Maybe Int) -> Opt () -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Common -> Opt ()
opt (Common -> Opt ()) -> Common -> Opt ()
forall a b. (a -> b) -> a -> b
$ ProgGen -> Common
forall a. WithCommon a => a -> Common
extractCommon ProgGen
md
                        Every a -> IO (Every a)
forall (m :: * -> *) a. Monad m => a -> m a
return (([(Exp, a)] -> [(Exp, a)]) -> Every a -> Every a
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Int -> (a -> Bool) -> [(Exp, a)] -> [(Exp, a)]
forall a.
Typeable a =>
Maybe Int -> (a -> Bool) -> [(Exp, a)] -> [(Exp, a)]
fp Maybe Int
mpto a -> Bool
pred) Every a
ts)
fp :: Typeable a => Maybe Int -> (a->Bool) -> [(Exp, a)] -> [(Exp, a)]
fp :: Maybe Int -> (a -> Bool) -> [(Exp, a)] -> [(Exp, a)]
fp Maybe Int
mpto a -> Bool
pred = ((Exp, a) -> Bool) -> [(Exp, a)] -> [(Exp, a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ (Exp
_,a
a) -> IO (Maybe Bool) -> Maybe Bool
forall a. IO a -> a
unsafePerformIO ((Bool -> IO () -> IO ()) -> Maybe Int -> IO Bool -> IO (Maybe Bool)
forall a.
(a -> IO () -> IO ()) -> Maybe Int -> IO a -> IO (Maybe a)
maybeWithTO Bool -> IO () -> IO ()
seq Maybe Int
mpto (Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Bool
pred a
a))) Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)
{-
fp _    pred []            = []
fp mpto pred (ea@(e,a):ts) = case unsafePerformIO (maybeWithTO seq mpto (return (pred a))) of
                                    Just True -> ea : fp mpto pred ts
                                    _         -> fp mpto pred ts
-}
-- fpartial :: Typeable a => Maybe Int -> (a->Bool) -> [((Exp, a),(Exp,a))] -> [(Exp, a)]
-- fpartial mpto pred tups = fp mpto pred $ map snd tups
-- The following tries the total version if the partial version fails. Not good when using the Partial class, because when using the Partial class the total and partial versions look the same. Now the Partial class is not used, so I recover this
fpartial :: Typeable a => Maybe Int -> (a->Bool) -> [((Exp, a),(Exp,a))] -> [(Exp, a)]
fpartial :: Maybe Int -> (a -> Bool) -> [((Exp, a), (Exp, a))] -> [(Exp, a)]
fpartial Maybe Int
mpto a -> Bool
pred [((Exp, a), (Exp, a))]
ts = [ (Exp, a)
t | Just (Exp, a)
t <- (((Exp, a), (Exp, a)) -> Maybe (Exp, a))
-> [((Exp, a), (Exp, a))] -> [Maybe (Exp, a)]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Int -> (a -> Bool) -> ((Exp, a), (Exp, a)) -> Maybe (Exp, a)
forall t a.
Maybe Int -> (t -> Bool) -> ((a, t), (a, t)) -> Maybe (a, t)
fpart Maybe Int
mpto a -> Bool
pred) [((Exp, a), (Exp, a))]
ts ]
fpart :: Maybe Int -> (t -> Bool) -> ((a, t), (a, t)) -> Maybe (a, t)
fpart Maybe Int
mpto t -> Bool
pred (ea :: (a, t)
ea@(a
_,t
a),eap :: (a, t)
eap@(a
_,t
ap))
  = case IO (Maybe Bool) -> Maybe Bool
forall a. IO a -> a
unsafePerformIO ((Bool -> IO () -> IO ()) -> Maybe Int -> IO Bool -> IO (Maybe Bool)
forall a.
(a -> IO () -> IO ()) -> Maybe Int -> IO a -> IO (Maybe a)
maybeWithTO Bool -> IO () -> IO ()
seq Maybe Int
mpto (Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$! (t -> Bool
pred t
ap))) of
                                    Just Bool
True  -> (a, t) -> Maybe (a, t)
forall a. a -> Maybe a
Just (a, t)
eap
                                    Just Bool
False -> Maybe (a, t)
forall a. Maybe a
Nothing
                                    Maybe Bool
Nothing -> case IO (Maybe Bool) -> Maybe Bool
forall a. IO a -> a
unsafePerformIO ((Bool -> IO () -> IO ()) -> Maybe Int -> IO Bool -> IO (Maybe Bool)
forall a.
(a -> IO () -> IO ()) -> Maybe Int -> IO a -> IO (Maybe a)
maybeWithTO Bool -> IO () -> IO ()
seq Maybe Int
mpto (Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return  (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$!(t -> Bool
pred t
a))) of 
                                      Just Bool
True -> (a, t) -> Maybe (a, t)
forall a. a -> Maybe a
Just (a, t)
ea
                                      Maybe Bool
_         -> Maybe (a, t)
forall a. Maybe a
Nothing

{-
fpartial _    pred []            = []
fpartial mpto pred ((ea@(_,a),eap@(_,ap)):ts) 
  = case unsafePerformIO (maybeWithTO seq mpto (return (pred ap))) of
                                    Just True  -> eap : fpartial mpto pred ts
                                    Just False -> fpartial mpto pred ts
                                    Nothing    -> case unsafePerformIO (maybeWithTO seq mpto (return (pred a))) of
                                                     Just True  -> ea : fpartial mpto pred ts
                                                     _          -> fpartial mpto pred ts
-}
fpartialIO :: Typeable a => Maybe Int -> (a->Bool) -> [((e, a),(e,a))] -> IO [(e, a)]
fpartialIO :: Maybe Int -> (a -> Bool) -> [((e, a), (e, a))] -> IO [(e, a)]
fpartialIO Maybe Int
mpto a -> Bool
pred [((e, a), (e, a))]
ts = (((e, a), (e, a)) -> IO (Maybe (e, a)))
-> [((e, a), (e, a))] -> IO [(e, a)]
forall a t e.
Typeable a =>
(t -> IO (Maybe (e, a))) -> [t] -> IO [(e, a)]
filterIO (Maybe Int -> (a -> Bool) -> ((e, a), (e, a)) -> IO (Maybe (e, a))
forall a e.
Typeable a =>
Maybe Int -> (a -> Bool) -> ((e, a), (e, a)) -> IO (Maybe (e, a))
fpartIO Maybe Int
mpto a -> Bool
pred) [((e, a), (e, a))]
ts
filterIO :: Typeable a => (t -> IO (Maybe (e,a))) -> [t] -> IO [(e,a)]
filterIO :: (t -> IO (Maybe (e, a))) -> [t] -> IO [(e, a)]
filterIO t -> IO (Maybe (e, a))
filt [t]
ts = do [Maybe (e, a)]
mbs <- [IO (Maybe (e, a))] -> IO [Maybe (e, a)]
forall a. [IO a] -> IO [a]
interleaveActions {- parallelInterleaved -} ([IO (Maybe (e, a))] -> IO [Maybe (e, a)])
-> [IO (Maybe (e, a))] -> IO [Maybe (e, a)]
forall a b. (a -> b) -> a -> b
$ (t -> IO (Maybe (e, a))) -> [t] -> [IO (Maybe (e, a))]
forall a b. (a -> b) -> [a] -> [b]
map t -> IO (Maybe (e, a))
filt [t]
ts
--filterIO filt ts = do mbs <- mapIO filt ts
                      [(e, a)] -> IO [(e, a)]
forall (m :: * -> *) a. Monad m => a -> m a
return [ (e, a)
tup | Just (e, a)
tup <- [Maybe (e, a)]
mbs ]
#ifdef PAR
fpartialParIO :: Typeable a => Maybe Int -> (a->Bool) -> [((e, a),(e,a))] -> ParIO [(e, a)]
fpartialParIO mpto pred ts = do mbs <- mapParIO (liftIO . fpartIO mpto pred) ts
                                return [ tup | Just tup <- mbs ]
#endif
fpartIO :: Typeable a => Maybe Int -> (a->Bool) -> ((e, a),(e,a)) -> IO (Maybe (e, a))
fpartIO :: Maybe Int -> (a -> Bool) -> ((e, a), (e, a)) -> IO (Maybe (e, a))
fpartIO Maybe Int
mpto a -> Bool
pred ((e, a)
ea, eap :: (e, a)
eap@(e
_,a
ap))
  = do Maybe Bool
mbb <- (Bool -> IO () -> IO ()) -> Maybe Int -> IO Bool -> IO (Maybe Bool)
forall a.
(a -> IO () -> IO ()) -> Maybe Int -> IO a -> IO (Maybe a)
maybeWithTO Bool -> IO () -> IO ()
seq Maybe Int
mpto (IO Bool -> IO (Maybe Bool)) -> IO Bool -> IO (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$! a -> Bool
pred a
ap 
       case Maybe Bool
mbb of
         Just Bool
True  -> Maybe (e, a) -> IO (Maybe (e, a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (e, a) -> IO (Maybe (e, a)))
-> Maybe (e, a) -> IO (Maybe (e, a))
forall a b. (a -> b) -> a -> b
$ (e, a) -> Maybe (e, a)
forall a. a -> Maybe a
Just (e, a)
eap
         Just Bool
False -> Maybe (e, a) -> IO (Maybe (e, a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (e, a)
forall a. Maybe a
Nothing
         Maybe Bool
Nothing    -> Maybe Int -> (a -> Bool) -> (e, a) -> IO (Maybe (e, a))
forall a e.
Typeable a =>
Maybe Int -> (a -> Bool) -> (e, a) -> IO (Maybe (e, a))
ftotIO Maybe Int
mpto a -> Bool
pred (e, a)
ea
{- これだとinterleaveできない．
fpartialIO _    pred []            = return []
fpartialIO mpto pred ((ea@(_,a),eap@(_,ap)):ts) 
  = do mbb <- (maybeWithTO seq mpto (return $! pred ap)) 
       case mbb of
         Just True  -> fmap (eap :) $ fpartialIO mpto pred ts
         Just False -> fpartialIO mpto pred ts
         Nothing    -> do mbb2 <- maybeWithTO seq mpto (return (pred a)) 
                          case mbb2 of
                                                     Just True  -> fmap (ea :) $ fpartialIO mpto pred ts
                                                     _          -> fpartialIO mpto pred ts

-}



ftotalIO :: Typeable a => Maybe Int -> (a->Bool) -> [(e, a)] -> IO [(e, a)]
ftotalIO :: Maybe Int -> (a -> Bool) -> [(e, a)] -> IO [(e, a)]
ftotalIO Maybe Int
mpto a -> Bool
pred [(e, a)]
ts = ((e, a) -> IO (Maybe (e, a))) -> [(e, a)] -> IO [(e, a)]
forall a t e.
Typeable a =>
(t -> IO (Maybe (e, a))) -> [t] -> IO [(e, a)]
filterIO (Maybe Int -> (a -> Bool) -> (e, a) -> IO (Maybe (e, a))
forall a e.
Typeable a =>
Maybe Int -> (a -> Bool) -> (e, a) -> IO (Maybe (e, a))
ftotIO Maybe Int
mpto a -> Bool
pred) [(e, a)]
ts
ftotIO :: Typeable a => Maybe Int -> (a->Bool) -> (e,a) -> IO (Maybe (e, a))
ftotIO :: Maybe Int -> (a -> Bool) -> (e, a) -> IO (Maybe (e, a))
ftotIO Maybe Int
mpto a -> Bool
pred (ea :: (e, a)
ea@(e
_,a
a))
  = do Maybe Bool
mbb <- (Bool -> IO () -> IO ()) -> Maybe Int -> IO Bool -> IO (Maybe Bool)
forall a.
(a -> IO () -> IO ()) -> Maybe Int -> IO a -> IO (Maybe a)
maybeWithTO Bool -> IO () -> IO ()
seq Maybe Int
mpto (IO Bool -> IO (Maybe Bool)) -> IO Bool -> IO (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$! a -> Bool
pred a
a 
       case Maybe Bool
mbb of
         Just Bool
True  -> Maybe (e, a) -> IO (Maybe (e, a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (e, a) -> IO (Maybe (e, a)))
-> Maybe (e, a) -> IO (Maybe (e, a))
forall a b. (a -> b) -> a -> b
$ (e, a) -> Maybe (e, a)
forall a. a -> Maybe a
Just (e, a)
ea
         Maybe Bool
_          -> Maybe (e, a) -> IO (Maybe (e, a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (e, a)
forall a. Maybe a
Nothing





fpIO :: Typeable a => Maybe Int -> (a->Bool) -> [((Exp, a),(Exp,a))] -> IO [(Exp, a)]
fpIO :: Maybe Int -> (a -> Bool) -> [((Exp, a), (Exp, a))] -> IO [(Exp, a)]
fpIO Maybe Int
mpto a -> Bool
pred [((Exp, a), (Exp, a))]
ts = do [Maybe (Exp, a)]
mbs <- {-interleaveActions -}[IO (Maybe (Exp, a))] -> IO [Maybe (Exp, a)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence {- parallelInterleaved -} ([IO (Maybe (Exp, a))] -> IO [Maybe (Exp, a)])
-> [IO (Maybe (Exp, a))] -> IO [Maybe (Exp, a)]
forall a b. (a -> b) -> a -> b
$ {- take 19 $ drop 6550 $ -} (((Exp, a), (Exp, a)) -> Int -> IO (Maybe (Exp, a)))
-> [((Exp, a), (Exp, a))] -> [Int] -> [IO (Maybe (Exp, a))]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Maybe Int
-> (a -> Bool)
-> ((Exp, a), (Exp, a))
-> Int
-> IO (Maybe (Exp, a))
forall a.
Typeable a =>
Maybe Int
-> (a -> Bool)
-> ((Exp, a), (Exp, a))
-> Int
-> IO (Maybe (Exp, a))
fIO Maybe Int
mpto a -> Bool
pred) [((Exp, a), (Exp, a))]
ts [Int
0..]
--fpIO mpto pred ts = do mbs <- runParIO $ mapParIO (liftIO $ fIO mpto pred) $ zip ts [0..]
                       [(Exp, a)] -> IO [(Exp, a)]
forall (m :: * -> *) a. Monad m => a -> m a
return [ (Exp, a)
tup | Just (Exp, a)
tup <- [Maybe (Exp, a)]
mbs ]
fIO :: Typeable a => Maybe Int -> (a->Bool) -> ((Exp, a),(Exp,a)) -> Int -> IO (Maybe (Exp, a))
fIO :: Maybe Int
-> (a -> Bool)
-> ((Exp, a), (Exp, a))
-> Int
-> IO (Maybe (Exp, a))
fIO Maybe Int
mpto a -> Bool
pred (ea :: (Exp, a)
ea@(Exp
e,a
a),eap :: (Exp, a)
eap@(Exp
_,a
ap)) Int
i
  = do Handle -> String -> IO ()
hPutStrLn Handle
stderr (Int -> String -> String
forall a. Show a => a -> String -> String
shows Int
i String
" trying "String -> String -> String
forall a. [a] -> [a] -> [a]
++Exp -> String
forall a. Ppr a => a -> String
pprint Exp
e) 
       Maybe Bool
mbb <- (Bool -> IO () -> IO ()) -> Maybe Int -> IO Bool -> IO (Maybe Bool)
forall a.
(a -> IO () -> IO ()) -> Maybe Int -> IO a -> IO (Maybe a)
maybeWithTO Bool -> IO () -> IO ()
seq Maybe Int
mpto (IO Bool -> IO (Maybe Bool)) -> IO Bool -> IO (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$! a -> Bool
pred a
a
       case Maybe Bool
mbb of
         Just Bool
True  -> Maybe (Exp, a) -> IO (Maybe (Exp, a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Exp, a) -> IO (Maybe (Exp, a)))
-> Maybe (Exp, a) -> IO (Maybe (Exp, a))
forall a b. (a -> b) -> a -> b
$ (Exp, a) -> Maybe (Exp, a)
forall a. a -> Maybe a
Just (Exp, a)
ea
         Maybe Bool
_          -> Maybe (Exp, a) -> IO (Maybe (Exp, a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Exp, a)
forall a. Maybe a
Nothing


mapIO :: (a -> IO b) -> [a] -> IO [b]
mapIO :: (a -> IO b) -> [a] -> IO [b]
mapIO a -> IO b
f [a]
xs = (a -> IO (MVar b)) -> [a] -> IO [MVar b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (IO b -> IO (MVar b)
forall a. IO a -> IO (MVar a)
spawnIO (IO b -> IO (MVar b)) -> (a -> IO b) -> a -> IO (MVar b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO b
f) [a]
xs IO [MVar b] -> ([MVar b] -> IO [b]) -> IO [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (MVar b -> IO b) -> [MVar b] -> IO [b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM MVar b -> IO b
forall a. MVar a -> IO a
takeMVar
spawnIO :: IO a -> IO (MVar a)
spawnIO :: IO a -> IO (MVar a)
spawnIO IO a
a = do
      MVar a
mv <- IO (MVar a)
forall a. IO (MVar a)
newEmptyMVar
      IO () -> IO ThreadId
forkIO (IO a
a IO a -> (a -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
v -> a
v a -> IO () -> IO ()
`seq` MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
mv a
v)
      MVar a -> IO (MVar a)
forall (m :: * -> *) a. Monad m => a -> m a
return MVar a
mv

#ifdef PAR
-- ホントはspawnを使ったほうが良さそうだが，NFData定義するのが面倒なので．
mapParIO :: (a -> ParIO b) -> [a] -> ParIO [b]
mapParIO f as = mapM (spawn_ . f) as >>= mapM get
#endif

-- | @io2pred@ converts a specification given as a set of I/O pairs to the predicate form which other functions accept.
io2pred :: Eq b => [(a,b)] -> ((a->b)->Bool)
io2pred :: [(a, b)] -> (a -> b) -> Bool
io2pred [(a, b)]
ios a -> b
f = ((a, b) -> Bool) -> [(a, b)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(a
a,b
b) -> a -> b
f a
a b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
b) [(a, b)]
ios

-- utility functions to pretty print the results
-- | 'pprs' pretty prints the results to the console, using 'pprintUC'
pprs :: Every a -> IO ()
pprs :: Every a -> IO ()
pprs = ((Exp, a) -> IO ()) -> [(Exp, a)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
putStrLn (String -> IO ()) -> ((Exp, a) -> String) -> (Exp, a) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> String
forall a. (Ppr a, Data a) => a -> String
pprintUC (Exp -> String) -> ((Exp, a) -> Exp) -> (Exp, a) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp, a) -> Exp
forall a b. (a, b) -> a
fst) ([(Exp, a)] -> IO ())
-> (Every a -> [(Exp, a)]) -> Every a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Every a -> [(Exp, a)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
-- | 'pprsIO' is the 'EveryIO' version of pprs
pprsIO  ::        EveryIO a -> IO ()
pprsIO :: EveryIO a -> IO ()
pprsIO        EveryIO a
eio = (Int -> IO ()) -> [Int] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Int
d -> EveryIO a
eio Int
d IO [(Exp, a)] -> ([(Exp, a)] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Exp, a) -> IO ()) -> [(Exp, a)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
putStrLn (String -> IO ()) -> ((Exp, a) -> String) -> (Exp, a) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> String
forall a. (Ppr a, Data a) => a -> String
pprintUC (Exp -> String) -> ((Exp, a) -> Exp) -> (Exp, a) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp, a) -> Exp
forall a b. (a, b) -> a
fst)) [Int
0..]
-- | @pprsIOn depth eio@ is the counterpart of @pprs (take depth eio)@, while @pprsIO eio@ is the counterpart of @pprs eio@. 
--   Example: @pprsIOn 5 (everythingIO (mlist::ProgGen) :: EveryIO ([Char]->[Char]))@
pprsIOn :: Int -> EveryIO a -> IO ()
pprsIOn :: Int -> EveryIO a -> IO ()
pprsIOn Int
depth EveryIO a
eio = (Int -> IO ()) -> [Int] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Int
d -> EveryIO a
eio Int
d IO [(Exp, a)] -> ([(Exp, a)] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Exp, a) -> IO ()) -> [(Exp, a)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
putStrLn (String -> IO ()) -> ((Exp, a) -> String) -> (Exp, a) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> String
forall a. (Ppr a, Data a) => a -> String
pprintUC (Exp -> String) -> ((Exp, a) -> Exp) -> (Exp, a) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp, a) -> Exp
forall a b. (a, b) -> a
fst)) [Int
0..Int
depthInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
-- | '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 :: a -> String
pprintUC =  a -> String
forall a. Ppr a => a -> String
pprint (a -> String) -> (a -> a) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((Name -> Name) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT Name -> Name
unqCons)
unqCons :: Name -> Name
unqCons :: Name -> Name
unqCons Name
n | Name -> String
forall a. Show a => a -> String
show Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> String
forall a. Show a => a -> String
show '(:) = String -> Name
mkName String
":" -- NB: n == '(:) would not work due to the definition of Eq Name.
          | Bool
otherwise           = Name
n

lengths   :: Every   a -> IO ()
lengths :: Every a -> IO ()
lengths   = [Int] -> IO ()
forall a. Show a => a -> IO ()
print ([Int] -> IO ()) -> (Every a -> [Int]) -> Every a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Exp, a)] -> Int) -> Every a -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [(Exp, a)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
lengthsIO :: EveryIO a -> IO ()
lengthsIO :: EveryIO a -> IO ()
lengthsIO EveryIO a
eio = (Int -> IO ()) -> [Int] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Int
d -> EveryIO a
eio Int
d IO [(Exp, a)] -> ([(Exp, a)] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO ()
putStr (String -> IO ()) -> ([(Exp, a)] -> String) -> [(Exp, a)] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String)
-> ([(Exp, a)] -> String) -> [(Exp, a)] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String) -> ([(Exp, a)] -> Int) -> [(Exp, a)] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Exp, a)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) [Int
0..]
lengthsIOn, lengthsIOnLn :: Int -> EveryIO a -> IO ()
lengthsIOn :: Int -> EveryIO a -> IO ()
lengthsIOn Int
depth EveryIO a
eio = (Int -> IO ()) -> [Int] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Int
d -> EveryIO a
eio Int
d IO [(Exp, a)] -> ([(Exp, a)] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO ()
putStr (String -> IO ()) -> ([(Exp, a)] -> String) -> [(Exp, a)] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String)
-> ([(Exp, a)] -> String) -> [(Exp, a)] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String) -> ([(Exp, a)] -> Int) -> [(Exp, a)] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Exp, a)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) [Int
0..Int
depthInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
lengthsIOnLn :: Int -> EveryIO a -> IO ()
lengthsIOnLn Int
depth EveryIO a
eio = Int -> EveryIO a -> IO ()
forall a. Int -> EveryIO a -> IO ()
lengthsIOn Int
depth EveryIO a
eio IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
putStrLn String
""

printQ :: (Ppr a, Data a) => Q a -> IO ()
printQ :: Q a -> IO ()
printQ Q a
q = Q a -> IO a
forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ Q a
q IO a -> (a -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO ()
putStrLn (String -> IO ()) -> (a -> String) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. (Ppr a, Data a) => a -> String
pprintUC

\end{code}