--
-- (c) Susumu Katayama
--
\begin{code}
{-# OPTIONS -fglasgow-exts -XTemplateHaskell -cpp #-}
module MagicHaskeller(
-- * Re-exported modules
-- | This library implicitly re-exports the entities from
-- @module Language.Haskell.TH as TH@ and @module Data.Typeable@ from the Standard Hierarchical Library of Haskell.
-- Please refer to their documentations on types from them --- in this documentation, types from TH are all qualified and the only type used from @module Typeable@ is Typeable.Typeable. Other types you had never seen should be our internal representation.
module TH, module Typeable,
{- x ²¼¤ÎÊý¤ËThe program generators¤Ã¤Æ¤Î¤¬¤¢¤ë¤¿¤á¡¤confusing¤Ê¤Î¤Ç¡¥
-- * Program generators
ProgramGenerator, ProgGen, ProgGenSF, {- ProgGenSFIF, -} CutFree, CutFreeSF, ConstrL, ConstrLSF,
-}
-- * Setting up your synthesis
-- | Before synthesis, you have to define at least one program generator algorithm (or you may define one once and reuse it for later syntheses).
-- Other parameters are memoization depth and time out interval, which have default values.
-- You may elect either to set those values to the \'global variables\' using \'@set@*\' functions (i.e. functions whose names are prefixed by @set@), or hand them explicitly as parameters.
-- ** Class for program generator algorithms
-- | Please note that @ConstrL@ and @ConstrLSF@ are obsoleted and users are expected to use the 'constrL' option in 'Option'.
ProgramGenerator,
ProgGen, ProgGenSF, ProgGenXF,
-- ** Functions for creating your program generator algorithm
-- | You can set your primitives like, e.g., @'setPrimitives' $('p' [| ( (+) :: Int->Int->Int, 0 :: Int, \'A\', [] :: [a] ) |])@,
-- where the primitive set is consisted of @(+)@ specialized to type @Int->Int->Int@, @0@ specialized to type @Int@,
-- @ \'A\' @ which has monomorphic type @Char@, and @[]@ with polymorphic type @[a]@.
-- As primitive components one can include any variables and constructors within the scope.
-- However, because currently ad hoc polymorphism is not supported by this library, you may not write
-- @'setPrimitives' $('p' [| (+) :: Num a => a->a->a |])@.
-- Also, you have to specify the type unless you are using a primitive component whose type is monomorphic and instance of 'Data.Typeable.Typeable'
-- (just like when using the dynamic expression of Concurrent Clean), and thus
-- you may write @'setPrimitives' $('p' [| \'A\' |])@,
-- while you have to write @'setPrimitives' $('p' [| [] :: [a] |])@ instead of @'setPrimitives' $('p' [| [] |])@.
p, setPrimitives, mkPG, mkPGSF, setPG,
-- 'mkPG' and 'setPG' used to be called @mkMemo@ and @setMemo@ respectively (because the main ingredient of a program generator is a memoization table). ¤È¤¤¤¦¥³¥á¥ó¥È¤Ï¤½¤°¤ï¤Ê¤¯¤Ê¤Ã¤Æ¤¤¿¤Î¤Ç»ß¤á¤ë¡¥
-- | Older versions prohibited data types holding functions such as @[a->b]@, @(Int->Char, Bool)@, etc. just for efficiency reasons.
-- They are still available if you use 'mkMemo' and 'mkMemoSF' instead of 'mkPG' and 'mkPGSF' respectively, though actually this limitation does not affect the efficiency a lot.
-- (NB: recently I noticed that use of 'mkMemo' or 'mkMemoSF' might not improve the efficiency of generating lambda terms at all, though when I generated combinatory expressions it WAS necessary.
-- In fact, I mistakenly turned this limitation off, and 'mkMemo' and 'mkMemoSF' were equivalent to 'mkPG' and 'mkPGSF', but I did not notice that....)
mkMemo, mkMemoSF,
-- | @mkMemo075@ enables some more old good optimization options used until Version 0.7.5, including guess on the primitive functions.
-- It is for you if you prefer speed, but the result can be non-exhaustive if you use it with your own LibTH.hs.
-- Also, you need to use the prefixed |(->)| in order for the options to take effect. See LibTH.hs for examples.
mkPG075, mkMemo075,
-- | 'mkPGOpt' can be used along with its friends instead of 'mkPG' when the search should be fine-tuned.
mkPGOpt, Options, Opt(..), options, MemoType(..),
#ifdef HASKELLSRC
-- *** 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,
-- ** Expression generators
-- | These functions generate all the expressions that have the type you provide.
getEverything, everything, everythingM, everythingIO, unifyable, matching, getEverythingF, everythingF, unifyableF, matchingF,
-- ** Utility to filter out equivalent expressions
everyF,
-- ** Unility to get one value easily
stripEvery,
-- ** Pretty printers
pprs, pprsIO, pprsIOn, lengths, lengthsIO, lengthsIOn, printQ,
-- * Internal data representation
-- | The following types are assigned to our internal data representations.
Primitive, HValue(HV),
-- other stuff which will not be documented by Haddock
unsafeCoerce#, {- unifyablePos, -} exprToTHExp, trToTHType, printAny, p1, Filtrable
) 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)
#endif
import MagicHaskeller.TyConLib
import qualified Data.Map as Map
import Data.Char
import MagicHaskeller.Types as Types
import MagicHaskeller.ProgGen(ProgGen(PG))
import MagicHaskeller.ProgGenSF(ProgGenSF, PGSF)
-- import MagicHaskeller.ProgGenLF(ProgGenLF)
import MagicHaskeller.ProgGenXF(ProgGenXF)
import MagicHaskeller.ProgramGenerator
import 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 Maybe(fromJust)
import System.IO
import System.Random(mkStdGen,StdGen)
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.Classification(unsafeRandomTestFilter, Filtrable)
import MagicHaskeller.Instantiate(mkRandTrie)
import MagicHaskeller.MemoToFiles(MemoType(..))
\end{code}
\begin{code}
-- "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 mn name pq = pq >>= \prims ->
return [ SigD (mkName ("memo"++name)) (ConT mn),
ValD (VarP (mkName ("memo"++name))) (NormalB (AppE (VarE (mkName "mkPG")) prims -- (VarE (mkName "prims"))
)) [],
SigD (mkName ("every"++name)) (ConT (mkName "Everything")),
ValD (VarP (mkName ("every"++name))) (NormalB (VarE (mkName "everything") `AppE` VarE (mkName ("memo"++name)))) [],
SigD (mkName ("filter"++name)) (ConT (mkName "Filter")),
ValD (VarP (mkName ("filter"++name))) (NormalB ((VarE (mkName "flip") `AppE` VarE (mkName "filterThen")) `AppE` VarE (mkName ("every"++name)))) [] ]
type Every a = [[(TH.Exp,a)]]
type EveryIO a = Int -- query depth
-> IO [(TH.Exp, a)]
type Everything = Typeable a => Every a
type Filter = Typeable a => (a->Bool) -> IO (Every a)
{- Because the left hand side is not TH.Exp, we cannot splice directly there.
initialize name depth prims = [d| { $(return (VarE (mkName ("memo"++name)))) = mkPG $prims;
$(return (VarE (mkName ("every"++name)))) :: Everything;
$(return (VarE (mkName ("every"++name)))) = everything $(return (LitE (NumL depth))) $(return (VarE (mkName ("memo"++name)))); } |]
-}
{- It is unlikely that mkMTH will ever be used, and seemingly my version of haddock dislikes TH.
-- One could write, for example, $(mkMTH $15 [| ( 0::Int, succ, nat_para, [] ) |] ),
-- but I am not sure if this style using mkMTH will ever be used.
mkMTH :: TH.ExpQ -> TH.ExpQ -> TH.ExpQ
mkMTH n leq = [| mkMD $n $(m leq) |]
-}
-- Rather, one could write, e.g.,
-- mkMD 15 $(p [| ( 0::Int, succ::Int->Int, nat_para, [] :: [a]) |] )
-- | 'p' is used to convert your primitive component set into the internal form.
p :: TH.ExpQ -- ^ Quote a tuple of primitive components here.
-> TH.ExpQ -- ^ This becomes @[Primitive]@ when spliced.
p eq = eq >>= \e -> case e of TupE es -> (return . ListE) =<< (mapM p1 es)
_ -> (return . ListE . return) =<< p1 e -- This default pattern should also be defined, because it takes two (or more) to tuple!
p1 :: TH.Exp -> TH.ExpQ
p1 se@(SigE e ty) = p1' se e ty
p1 e@(ConE name) = do DataConI _ ty _ _ <- reify name
p1' e e ty
p1 e@(VarE name) = do VarI _ ty _ _ <- reify name
p1' e e ty
p1 e = do ee <- expToExpExp e
return $ TupE [ AppE (ConE (mkName "HV")) (AppE (VarE (mkName "unsafeCoerce#")) e), ee, AppE (VarE (mkName "trToTHType")) (AppE (VarE (mkName "typeOf")) e)]
p1' se e ty = do ee <- expToExpExp e
et <- typeToExpType ty
return $ TupE [ AppE (ConE (mkName "HV")) (AppE (VarE (mkName "unsafeCoerce#")) se), ee, et]
-- nameToExpName :: TH.Name -> TH.Exp
-- nameToExpName = strToExpName . showName
-- strToExpName str = AppE (VarE (mkName "mkName")) (LitE (StringL str))
{- not used any longer
{- This should work in theory, but Language.Haskell.TH.pprint has a bug and it does not print parentheses....
pprintType (ForallT _ _ ty) = pprint ty
pprintType ty = pprint ty
-}
-- 'pprintType' is a workaround for the problem that @Language.Haskell.TH.pprint :: Type -> String@ does not print parentheses correctly.
-- (try @Language.Haskell.TH.runQ [t| (Int->Int)->Int |] >>= \e -> putStrLn (pprint e)@ in your copy of GHCi.)
-- The implementation here is not so pretty, but that's OK for my purposes. Also note that 'pprintType' ignores foralls.
pprintType (ForallT _ [] ty) = pprintType ty
pprintType (ForallT _ _ ty) = error "Type classes are not supported yet. Sorry...."
pprintType (VarT name) = pprint name
pprintType (ConT name) = pprint name
pprintType (TupleT n) = tuplename n
pprintType ArrowT = "(->)"
pprintType ListT = "[]"
pprintType (AppT t u) = '(' : pprintType t ++ ' ' : pprintType u ++ ")"
-- The problem of @Language.Haskell.TH.pprint :: Type -> String@ is now fixed at the darcs HEAD.
-}
primitivesp :: TyConLib -> [Primitive] -> [Typed [CoreExpr]]
primitivesp tcl ps
= zipWith (\ n (_,_,ty) -> [Primitive n] ::: thTypeToType tcl ty) [0..] ps
mkPG :: ProgramGenerator pg => [Primitive] -> pg
mkPG = mkPG' True
-- ^ 'mkPG' is defined as:
--
-- > mkPG prims = mkPGSF (mkStdGen 123456) (repeat 5) prims prims
mkMemo :: ProgramGenerator pg => [Primitive] -> pg
mkMemo = mkPG' False
mkPG' cont tups = case mkCommon options{contain=cont} tups of cmn -> mkTrie cmn (primitivesp (tcl cmn) tups)
-- | 'mkPGSF' and 'mkMemoSF' are provided mainly for backward compatibility. These functions are defined only for the 'ProgramGenerator's whose names end with @SF@ (i.e., generators with synergetic filtration).
-- For such generators, they are defined as:
--
-- > mkPGSF gen nrnds optups tups = mkPGOpt (options{primopt = Just optups, contain = True, stdgen = gen, nrands = nrnds}) tups
-- > mkMemoSF gen nrnds optups tups = mkPGOpt (options{primopt = Just optups, contain = False, stdgen = gen, nrands = nrnds}) tups
mkPGSF,mkMemoSF :: ProgramGenerator pg =>
StdGen
-> [Int] -- ^ number of random samples at each depth, for each type.
-> [Primitive]
-> [Primitive] -> pg
mkPGSF = mkPGSF' True
mkMemoSF = mkPGSF' False
mkPGSF' cont gen nrnds optups tups = mkPGOpt (options{primopt = Just optups, contain = cont, stdgen = gen, nrands = nrnds}) tups
-- Currently only the pg==ConstrLSF case makes sense. ¤Ã¤Æ¤Î¤Ï¡¤optups¤Î¤ß¤Ë´Ø¤¹¤ëÏäǡ¤rnds¤Ï´Ø·¸¤Ê¤¤¡¥
mkPG075 :: ProgramGenerator pg => [Primitive] -> pg
mkPG075 = mkPGOpt (options{primopt = Nothing, contain = True, guess = True})
mkMemo075 :: ProgramGenerator pg => [Primitive] -> pg
mkMemo075 = mkPGOpt (options{primopt = Nothing, contain = False, guess = True})
mkPGOpt :: ProgramGenerator pg => Options -> [Primitive] -> pg
mkPGOpt opt prims = case mkCommon opt prims of cmn -> mkTrieOpt cmn (primitivesp (tcl cmn) primsOpt) (primitivesp (tcl cmn) prims)
where primsOpt = case primopt opt of Nothing -> prims
Just po -> po
-- this can be moved to somewhere near Common is defined (currently ProgramGenerator.lhs), when 'Primitive' is moved to some more adequate place.
-- ¼ÂºÝProgramGenerator.lhs¤ÇPrimitive¤ò°·¤¨¤ì¤Ð¤â¤Ã¤Èñ½ã²½¤Ç¤¤ë¤Ï¤º¡¥
mkCommon :: Options -> [Primitive] -> Common
mkCommon opts prims = let
tyconlib = primitivesToTCL prims
optunit = forget opts
in Cmn {opt = optunit, tcl = tyconlib, vl = primitivesToVL tyconlib prims, rt = mkRandTrie (nrands opts) tyconlib (stdgen opts)}
-- | options for limiting the hypothesis space.
type Options = Opt [Primitive]
forget :: Opt a -> Opt ()
forget opt = case primopt opt of Nothing -> opt{primopt = Nothing}
Just _ -> opt{primopt = Just ()}
setPG :: ProgGen -> IO ()
setPG = writeIORef refmemodeb
-- | @setPrimitives@ creates a @ProgGen@ from the given set of primitives using the current set of options, and sets it as the current program generator.
-- It used to be equivalent to @setPG . mkPG@ which overwrites the options with the default, but it is not now.
setPrimitives :: [Primitive] -> IO ()
setPrimitives tups = do PG (x,y,cmn) <- readIORef refmemodeb
setPG $ mkPGOpt ((opt cmn){primopt=Nothing}) tups
-- setPrimitives tups = writeIORef refmemodeb (mkPG tups) -- This definition overwrites the old configuration.
#ifdef HASKELLSRC
-- | 'load' loads a component library file.
load :: FilePath
-> TH.ExpQ -- ^ This becomes @[Primitive]@ when spliced.
load fp = do str <- runIO $ readFile fp
f str
-- | f is supposed to be used by load, but not hidden.
f :: String -> TH.ExpQ
f = p . return . 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 n = do pto <- newPTO n
PG (x,y,cmn) <- readIORef refmemodeb
writeIORef refmemodeb $ PG (x,y,cmn{opt = (opt cmn){timeout=Just pto}})
-- | 'unsetTimeout' disables timeout. This is the safe choice.
unsetTimeout :: IO ()
unsetTimeout = do PG (x,y,cmn) <- readIORef refmemodeb
writeIORef refmemodeb $ PG (x,y,cmn{opt = (opt cmn){timeout=Nothing}})
setDepth :: Int -- ^ memoization depth. (Sub)expressions within this size are memoized, while greater expressions will be recomputed (to save the heap space).
-> IO ()
setDepth d = do PG (x,y,cmn) <- readIORef refmemodeb
writeIORef refmemodeb $ PG (x,y,cmn{opt = (opt cmn){memodepth=d}})
-- ^ Currently the default depth is 10. You may want to lower the value if your computer often swaps, or increase it if you have a lot of memory.
{-# NOINLINE refmemodeb #-}
refmemodeb :: IORef ProgGen
refmemodeb = unsafePerformIO (newIORef defaultMD)
defaultMD = mkPG [] :: ProgGen
trsToTCL :: [TypeRep] -> TyConLib -- ReadType.extractTyConLib :: [HsDecl] -> TyConLib¤ò»²¹Í¤Ë¤Ç¤¤ë¡¥ -- ¤³¤Î2¹Ô¤È
trsToTCL trs
= (Map.fromListWith (\new old -> old) [ tup | k <- [0..7], tup <- tcsByK ! k ], tcsByK)
where tnsByK :: Array Types.Kind [TypeName]
tnsByK = accumArray (flip (:)) [] (0,7) ( trsToTCstrs trs ) -- ¤³¤³¤òÊѤ¨¤¿¡¥
tcsByK :: Array Types.Kind [(TypeName,Types.TyCon)]
tcsByK = listArray (0,7) [ tnsToTCs (tnsByK ! k) | k <- [0..7] ]
tnsToTCs :: [TypeName] -> [(TypeName,Types.TyCon)]
tnsToTCs tns = zipWith (\ i tn -> (tn, i)) [0..] tns
-- x ¼ÂºÝ¤Ë¤Ï(->)¤ÏTyCon°·¤¤¤Ë¤Ï¤·¤Ê¤¤¤ó¤À¤±¤É¡¤¤Û¤ó¤Î¤Á¤ç¤Ã¤È¤À¤±ÌµÂ̤ˤʤë¤À¤±¤Ê¤Î¤Ç¤¤¤¤¤Ç¤·¤ç¡¥
trsToTCstrs :: [TypeRep] -> [(Int, String)] -- Int is the arity of the TyCon. There can be duplicates.
trsToTCstrs [] = []
trsToTCstrs (tr:ts) = case splitTyConApp tr of (tc,trs) -> (length trs, tyConString tc) : trsToTCstrs (trs++ts)
-- Memo¤ägetEverything¼«ÂΤÏIORef¤ò»È¤ï¤º¤ËIO¤Ê¤·¤Ç¼ÂÁõ¤Ç¤¤ëÌõ¤Ç¡¤¤½¤Î°ÕÌ£¤Ç¤Ï¡¤IORef¤ò»È¤ï¤Ê¤¤Êý¤¬¤¤¤¤¤«¤â¡¥
-- x ¤Ä¤¤¤Ç¤Ë¤¤¤¦¤È¡¤1ÉäǤΥ¿¥¤¥à¥¢¥¦¥È¤òɽ¤¹PTO¡Ê¤ÎGLOBAL_VAR¡Ë¤âIO¤Ê¤·¤ÇÍѰդǤ¤ë¡¥¡ÊunsafePerformIO»È¤¦¤±¤É¡Ë
-- | 'getEverything' uses the \'global\' values set with @set*@ functions. 'getEverythingF' is its filtered version
getEverything :: Typeable a => IO (Every a)
getEverything = do memodeb <- readIORef refmemodeb
return (everything memodeb)
getEverythingF :: Typeable a => IO (Every a)
getEverythingF =do memodeb <- readIORef refmemodeb
return (everythingF memodeb)
{-
getEverything = result
where ty = typeOf $ snd $ head $ head $ unsafePerformIO result
result = do memodeb@(trie,prims,depth,tcl) <- readIORef refmemodeb
return $ unMx $ toMx (fmap (\ e -> (exprToTHExp (error "unknown conlib") e, unsafeExecute e)) (matchingPrograms (trToType tcl ty) memodeb))
-}
-- | 'everything' generates all the expressions that fit the inferred type, and their representations in the 'TH.Exp' form.
-- It returns a stream of lists, which is equivalent to Spivey's @Matrix@ data type, i.e., that contains expressions consisted of n primitive components at the n-th element (n = 1,2,...).
-- 'everythingF' is its filtered version
everything, everythingF :: (ProgramGenerator pg, Typeable a) =>
pg -- ^ program generator
-> Every a
everything memodeb = et undefined memodeb (mxExprToEvery "MagicHaskeller.everything: type mismatch" memodeb)
everythingF memodeb = et undefined memodeb (mxExprFiltEvery "MagicHaskeller.everythingF: type mismatch" memodeb)
et :: (ProgramGenerator pg, Typeable a) =>
a -- ^ dummy argument
-> pg -- ^ program generator
-> (Types.Type -> Matrix AnnExpr -> Matrix (Exp, a))
-> Every a
et dmy memodeb filt = unMx $ filt ty $ matchingPrograms ty memodeb
where ty = trToType (extractTCL memodeb) (typeOf dmy)
noFilter :: ProgramGenerator pg => pg -> Types.Type -> a -> a
noFilter _m _t = id
mxExprToEvery :: (Expression e, Search m, ProgramGenerator pg, Typeable a) => String -> pg -> Types.Type -> m e -> m (Exp, a)
mxExprToEvery msg memodeb _ = fmap (unwrapAE msg memodeb . toAnnExpr (reducer memodeb))
mxExprFiltEvery :: (Expression e, FiltrableBF m, ProgramGenerator pg, Typeable a) => String -> pg -> Types.Type -> m e -> m (Exp, a)
mxExprFiltEvery msg memodeb ty = fmap (unwrapAE msg memodeb) . randomTestFilter memodeb ty . fmap (toAnnExpr (reducer memodeb))
unwrapAE :: (ProgramGenerator pg, Typeable a) => String -> pg -> AnnExpr -> (Exp, a)
unwrapAE msg memodeb (AE e dyn) = (exprToTHExp (extractVL memodeb) e, fromDyn tcl dyn (error msg))
where tcl = extractTCL memodeb
{-
̵¸Â¥ê¥¹¥È¤ò»È¤¦¤Ê¤é¡¤unsafeInterleaveIO¤¬É¬ÍפʤϤº¡¥¤½¤Î¾ì¹çIO¤ËÆò½¤¹¤ë¤³¤È¤Ë¤Ê¤ë¡¥
-}
everythingM :: (ProgramGenerator pg, Typeable a, Monad m, Functor m) =>
pg -- ^ program generator
-> Int -- ^ query depth
-> m [(TH.Exp, a)]
everythingM = eM undefined
eM :: (ProgramGenerator pg, Typeable a, Monad m, Functor m) =>
a -- ^ dummy argument
-> pg -- ^ program generator
-> Int
-> m [(TH.Exp, a)]
eM dmy memodeb = result
where tcl = extractTCL memodeb
ty = trToType tcl $ typeOf dmy
result = unRcT $ mxExprToEvery "MagicHaskeller.everythingM: type mismatch" memodeb undefined $ matchingPrograms ty memodeb
everythingIO :: (ProgramGenerator pg, Typeable a) =>
pg -- ^ program generator
-> EveryIO a
everythingIO = eIO undefined
eIO :: (ProgramGenerator pg, Typeable a) =>
a -- ^ dummy argument
-> pg -- ^ program generator
-> EveryIO a
eIO dmy memodeb = result
where tcl = extractTCL memodeb
ty = trToType tcl $ typeOf dmy
result = unRcT $ mxExprToEvery "MagicHaskeller.everythingIO: type mismatch" memodeb undefined $ matchingProgramsIO ty memodeb
strip :: m (Every a) -> a
strip = undefined
stripEvery :: Every a -> a
stripEvery = head . map snd . 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 memodeb tht = unMx $ genExps noFilter unifyingPrograms memodeb tht
matching memodeb tht = unMx $ genExps noFilter matchingPrograms memodeb 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 memodeb tht = unMx $ genExps randomTestFilter unifyingPrograms memodeb tht
matchingF memodeb tht = unMx $ genExps randomTestFilter matchingPrograms memodeb tht
genExps filt rawGenProgs memodeb tht
= case thTypeToType (extractTCL memodeb) tht of
ty -> fmap (exprToTHExp (extractVL memodeb) . toCE) $
filt memodeb ty $ fmap (toAnnExpr (reducer memodeb)) (rawGenProgs ty 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 => (a->Bool) -> TH.Exp
findOne pred = unsafePerformIO $ findDo (\e _ -> return e) pred
{- x Ç°¤Î¤¿¤á¤ä¤Ã¤Æ¤ß¤¿¤±¤É¡¤¤ä¤Ã¤Ñ¥À¥á¤ä¤Í¡¥¤Æ¤æ¡¼¤«¡¤Recomp¤Î¤Þ¤Þ¤ä¤Ã¤Æ³Æ¿¼¤µ¤Ç¸«¤ë¼ê¤Ï¤¢¤ë¤«¤â¡¥
findAny :: Typeable a => (a->Bool) -> [TH.Exp]
findAny pred = unsafePerformIO $ findDo (\e r -> r >>= \es -> return (e:es)) pred
-}
-- | 'printOne' prints the expression found first.
printOne :: Typeable a => (a->Bool) -> IO TH.Exp
printOne pred = do expr <- findDo (\e _ -> return e) pred
putStrLn $ pprintUC expr
return expr
-- | 'printAll' prints all the expressions satisfying the given predicate.
printAll, printAny :: Typeable a => (a->Bool) -> IO ()
printAny = printAll -- provided just for backward compatibility
printAll = findDo (\e r -> putStrLn (pprintUC e) >> r)
printAllF :: (Typeable a, Filtrable a) => (a->Bool) -> IO ()
printAllF pred = do et <- getEverything
fet <- filterThenF pred et
pprs fet
findDo :: Typeable a => (TH.Exp -> IO b -> IO b) -> (a->Bool) -> IO b
findDo op pred = do et <- getEverything
md <- readIORef refmemodeb
let mpto = timeout $ opt $ extractCommon md
fp mpto (concat et)
where fp mpto ((e,a):ts) = do -- hPutStrLn stderr ("trying" ++ pprintUC e)
result <- maybeWithTO seq mpto (return (pred a))
case result of Just True -> e `op` fp mpto ts
Just False -> fp mpto ts
Nothing -> hPutStrLn stderr ("timeout on "++pprintUC e) >> fp mpto ts
-- x ËÜÅö¤Ïrecomp¤Î¤Þ¤Þ¤Ç¤ä¤Ã¤¿Êý¤¬Â®¤¤¤Ï¤º¡¥
-- | 'filterFirst' is like '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 => (a->Bool) -> IO (Every a)
filterFirst pred = do et <- getEverything
filterThen pred et
-- randomTestFilter should be applied after filterThen, because it's slower
filterFirstF :: (Typeable a, Filtrable a) => (a->Bool) -> IO (Every a)
filterFirstF pred = do et <- getEverything
filterThenF pred et
filterThenF pred et = do
fd <- filterThen pred et
memodeb <- readIORef refmemodeb
let mpto = timeout $ opt $ extractCommon memodeb
return $ everyF mpto fd
{- refmemodeb ¤Ë¤¢¤ë¤â¤Î¤¬¼ÂºÝ¤Ë»È¤ï¤ì¤Æ¤¤¤ë¤â¤Î¤È¤Ï¸Â¤é¤Ê¤¤¡¥refmemodeb¤ò»È¤ï¤Ê¤¤¤È¤¤¤¦ÁªÂò¤â¤¢¤ë¤Î¤Ç¡¥
filterFirstF pred = do et <- getEverything
filterThenF pred et
filterThenF pred ts = do
fd <- filterThen pred ts
let x=undefined
_=pred x
memodeb <- readIORef refmemodeb
return $ unMx $ randomTestFilter memodeb (getType memodeb x) $ Mx et
getType :: Typeable a => a -> ProgGen -> Types.Type
getType ty memodeb = trToType (extractTCL memodeb) (typeOf ty)
-}
everyF :: (Typeable a, Filtrable a) =>
Maybe Int -- ^ microsecs until timeout
-> Every a -> Every a
everyF mto = unMx . unsafeRandomTestFilter mto . Mx
-- | 'filterThen' may be used to further filter the results.
filterThen :: Typeable a => (a->Bool) -> Every a -> IO (Every a)
filterThen pred ts = do md <- readIORef refmemodeb
let mpto = timeout $ opt $ extractCommon md
return (map (fp mpto) ts)
where fp _ [] = []
fp mpto (ea@(e,a):ts) = case unsafePerformIO (maybeWithTO seq mpto (return (pred a))) of
Just True -> ea : fp mpto ts
_ -> fp mpto ts
-- | @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 ios f = all (\(a,b) -> f 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 = mapM_ (putStrLn . pprintUC . fst) . concat
-- | 'pprsIO' is the 'EveryIO' version of pprs
pprsIO :: EveryIO a -> IO ()
pprsIO eio = mapM_ (\d -> eio d >>= mapM_ (putStrLn . pprintUC . fst)) [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 depth eio = mapM_ (\d -> eio d >>= mapM_ (putStrLn . pprintUC . fst)) [0..depth-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 = pprint . everywhere (mkT unqCons)
unqCons :: Name -> Name
unqCons n | show n == show '(:) = mkName ":" -- NB: n == '(:) would not work due to the definition of Eq Name.
| otherwise = n
lengths :: Every a -> IO ()
lengths = print . map length
lengthsIO :: EveryIO a -> IO ()
lengthsIO eio = mapM_ (\d -> eio d >>= putStr . (' ':) . show . length) [0..]
lengthsIOn :: Int -> EveryIO a -> IO ()
lengthsIOn depth eio = mapM_ (\d -> eio d >>= putStr . (' ':) . show . length) [0..depth-1]
printQ :: (Ppr a, Data a) => Q a -> IO ()
printQ q = runQ q >>= putStrLn . pprintUC
\end{code}