--
-- (c) Susumu Katayama 2009
--
\begin{code}
-- # prune
-- prune is supposed to prevent haddock from chasing imports, but seemingly it does not work.
{-# OPTIONS -fglasgow-exts -XTemplateHaskell -cpp #-}
module MagicHaskeller(
-- * Re-exported modules
-- | This library implicitly re-exports the entities from
-- @module Language.Haskell.TH as TH@ and @module Data.Typeable@ from the Standard Hierarchical Library of Haskell.
-- Please refer to their documentations on types from them --- in this documentation, types from TH are all qualified and the only type used from @module Typeable@ is Typeable.Typeable. Other types you had never seen should be our internal representation.
module TH, module Typeable,
-- * Setting up your synthesis
-- | Before synthesis, you have to define at least one program generator algorithm (or you may define one once and reuse it for later syntheses).
-- Other parameters are memoization depth and time out interval, which have default values.
-- You may elect either to set those values to the \'global variables\' using \'@set@*\' functions (i.e. functions whose names are prefixed by @set@), or hand them explicitly as parameters.
-- ** Class for program generator algorithms
-- | Please note that @ConstrL@ and @ConstrLSF@ are obsoleted and users are expected to use the 'constrL' option in 'Option'.
ProgramGenerator,
ProgGen, ProgGenSF, ProgGenXF,
-- ** Functions for creating your program generator algorithm
-- | You can set your primitives like, e.g., @'setPrimitives' $('p' [| ( (+) :: Int->Int->Int, 0 :: Int, \'A\', [] :: [a] ) |])@,
-- where the primitive set is consisted of @(+)@ specialized to type @Int->Int->Int@, @0@ specialized to type @Int@,
-- @ \'A\' @ which has monomorphic type @Char@, and @[]@ with polymorphic type @[a]@.
-- As primitive components one can include any variables and constructors within the scope.
-- However, because currently ad hoc polymorphism is not supported by this library, you may not write
-- @'setPrimitives' $('p' [| (+) :: Num a => a->a->a |])@.
-- Also, you have to specify the type unless you are using a primitive component whose type is monomorphic and instance of 'Data.Typeable.Typeable'
-- (just like when using the dynamic expression of Concurrent Clean), and thus
-- you may write @'setPrimitives' $('p' [| \'A\' |])@,
-- while you have to write @'setPrimitives' $('p' [| [] :: [a] |])@ instead of @'setPrimitives' $('p' [| [] |])@.
p, setPrimitives, mkPG, mkPGSF, setPG,
-- 'mkPG' and 'setPG' used to be called @mkMemo@ and @setMemo@ respectively (because the main ingredient of a program generator is a memoization table). ¤È¤¤¤¦¥³¥á¥ó¥È¤Ï¤½¤°¤ï¤Ê¤¯¤Ê¤Ã¤Æ¤¤¿¤Î¤Ç»ß¤á¤ë¡¥
-- | Older versions prohibited data types holding functions such as @[a->b]@, @(Int->Char, Bool)@, etc. just for efficiency reasons.
-- They are still available if you use 'mkMemo' and 'mkMemoSF' instead of 'mkPG' and 'mkPGSF' respectively, though actually this limitation does not affect the efficiency a lot.
-- (NB: recently I noticed that use of 'mkMemo' or 'mkMemoSF' might not improve the efficiency of generating lambda terms at all, though when I generated combinatory expressions it WAS necessary.
-- In fact, I mistakenly turned this limitation off, and 'mkMemo' and 'mkMemoSF' were equivalent to 'mkPG' and 'mkPGSF', but I did not notice that....)
mkMemo, mkMemoSF,
-- | @mkMemo075@ enables some more old good optimization options used until Version 0.7.5, including guess on the primitive functions.
-- It is for you if you prefer speed, but the result can be non-exhaustive if you use it with your own LibTH.hs.
-- Also, you need to use the prefixed |(->)| in order for the options to take effect. See LibTH.hs for examples.
mkPG075, mkMemo075,
-- | 'mkPGOpt' can be used along with its friends instead of 'mkPG' when the search should be fine-tuned.
mkPGOpt, Options, Opt(..), options,
#ifdef HASKELLSRC
-- *** Alternative way to create your program generator algorithm
-- | 'load', 'loadPrimitives', and 'loadPG' provides an alternative scheme to create program generator algorithms.
-- (But most likely they will become obsolete....)
load, loadPrimitives, loadPG,
#endif
-- ** Memoization depth
setDepth,
-- ** Time out
-- | NB: 'setTimeout' and 'unsetTimeout' will be obsoleted. They are provided for backward compatibility, but
-- not exactly compatible with the old ones in that their results will not affect the behavior of 'everything', etc., which explicitly take a 'ProgramGenerator' as an argument.
-- Also, in the current implementation, the result of 'setTimeout' and 'unsetTimeout' will be overwritten by setPrimitives.
-- Use 'timeout' option instead.
--
-- Because the library generates all the expressions including those with non-linear recursions, you should note that there exist some expressions which take extraordinarily long time. (Imagine a function that takes an integer n and increments 0 for 2^(2^n) times.)
-- For this reason, time out is taken after 0.02
-- second since each invocation of evaluation by default. This default behavior can
-- be overridden by the following functions.
setTimeout, unsetTimeout,
-- ** Defining functions automatically
-- | In this case \"automatically\" does not mean \"inductively\" but \"deductively using Template Haskell\";)
define, Everything, Filter, Every,
-- * Generating programs
-- | (There are many variants, but most of the functions here just filter 'everything' with the predicates you provide.)
--
-- Functions suffixed with \"F\" (like 'everythingF', etc.) are filtered versions, where their results are filtered to totally remove semantic duplications. In general they are equivalent to applying 'everyF' afterwards.
-- (Note that this is filtration AFTER the program generation, unlike the filtration by using 'ProgGenSF' is done DURING program generation.)
-- ** Quick start
findOne, printOne, printAny,
-- ** Incremental filtration
-- | Sometimes you may want to filter further after synthesis, because the predicate you previously provided did not specify
-- the function enough. The following functions can be used to filter expressions incrementally.
filterFirst, filterFirstF, filterThen, filterThenF,
-- ** Expression generators
-- | These functions generate all the expressions that have the type you provide.
getEverything, everything, everythingM, unifyable, matching, getEverythingF, everythingF, unifyableF, matchingF,
-- ** Utility to filter out equivalent expressions
everyF,
-- ** Pretty printers
pprs, printQ,
-- * Internal data representation
-- | The following types are assigned to our internal data representations.
Primitive, HValue(HV),
-- other stuff which will not be documented by Haddock
unsafeCoerce#, {- unifyablePos, -} exprToTHExp, trToTHType -- , specializedPossi
#ifdef HASKELLSRC
, module Language.Haskell.Syntax -- , pprintType
#endif
) where
import Data.Generics(everywhere, mkT, Data)
import Data.Array.IArray
import MagicHaskeller.CoreLang(CoreExpr(..), HValue(..), exprToTHExp, VarLib)
import Language.Haskell.TH as TH
#ifdef HASKELLSRC
import Language.Haskell.Syntax
import Language.Haskell.Pretty
import ReadType
#endif
import MagicHaskeller.TyConLib
import qualified Data.Map as Map
import Data.Char
import MagicHaskeller.Types as Types
import MagicHaskeller.ProgGen(ProgGen(PG))
import MagicHaskeller.ProgGenSF(ProgGenSF, PGSF)
-- import MagicHaskeller.ProgGenLF(ProgGenLF)
import MagicHaskeller.ProgGenXF(ProgGenXF)
import MagicHaskeller.ProgramGenerator
import Control.Monad.Search.Combinatorial -- This should all be exposed?
import Data.Typeable as Typeable
import System.IO.Unsafe(unsafePerformIO)
import Data.IORef
import GHC.Exts(unsafeCoerce#)
-- import Maybe(fromJust)
import System.IO
import System.Random(mkStdGen,StdGen)
import MagicHaskeller.MHTH
import MagicHaskeller.ReadTHType
import MagicHaskeller.ReadTypeRep(trToType, trToTHType)
import MagicHaskeller.MyDynamic
import MagicHaskeller.Expression
import MagicHaskeller.Classify
import MagicHaskeller.Classification(unsafeRandomTestFilter, Filtrable)
import MagicHaskeller.Instantiate(mkRandTrie)
\end{code}
\begin{code}
-- "MemoDeb" name should be hidden, or maybe I could rename it.
type Primitive = (HValue, TH.Exp, TH.Type)
-- | 'define' eases use of this library by automating some function definitions. For example,
--
-- > $( define ''ProgGen "Foo" 15 (p [| (1 :: Int, (+) :: Int -> Int -> Int) |]) )
--
-- is equivalent to
--
-- > memoFoo :: ProgGen
-- > memoFoo = mkPG (p [| (1 :: Int, (+) :: Int -> Int -> Int) |])
-- > everyFoo :: Everything
-- > everyFoo = everything 15 memoFoo
-- > filterFoo :: Filter
-- > filterFoo pred = filterThen pred everyFoo
--
-- If you do not think this function reduces the number of your keystrokes a lot, you can do without it.
define :: TH.Name -> String -> Integer -> TH.ExpQ -> TH.Q [TH.Dec]
define mn name depth pq = pq >>= \prims ->
return [ SigD (mkName ("memo"++name)) (ConT mn),
ValD (VarP (mkName ("memo"++name))) (NormalB (AppE (VarE (mkName "mkPG")) prims -- (VarE (mkName "prims"))
)) [],
SigD (mkName ("every"++name)) (ConT (mkName "Everything")),
ValD (VarP (mkName ("every"++name))) (NormalB ((VarE (mkName "everything") `AppE` LitE (IntegerL depth)) `AppE` VarE (mkName ("memo"++name)))) [],
SigD (mkName ("filter"++name)) (ConT (mkName "Filter")),
ValD (VarP (mkName ("filter"++name))) (NormalB ((VarE (mkName "flip") `AppE` VarE (mkName "filterThen")) `AppE` VarE (mkName ("every"++name)))) [] ]
type Every a = [[(TH.Exp,a)]]
type Everything = Typeable a => Every a
type Filter = Typeable a => (a->Bool) -> IO (Every a)
{- Because the left hand side is not TH.Exp, we cannot splice directly there.
initialize name depth prims = [d| { $(return (VarE (mkName ("memo"++name)))) = mkPG $prims;
$(return (VarE (mkName ("every"++name)))) :: Everything;
$(return (VarE (mkName ("every"++name)))) = everything $(return (LitE (NumL depth))) $(return (VarE (mkName ("memo"++name)))); } |]
-}
{- It is unlikely that mkMTH will ever be used, and seemingly my version of haddock dislikes TH.
-- One could write, for example, $(mkMTH $15 [| ( 0::Int, succ, nat_para, [] ) |] ),
-- but I am not sure if this style using mkMTH will ever be used.
mkMTH :: TH.ExpQ -> TH.ExpQ -> TH.ExpQ
mkMTH n leq = [| mkMD $n $(m leq) |]
-}
-- Rather, one could write, e.g.,
-- mkMD 15 $(p [| ( 0::Int, succ::Int->Int, nat_para, [] :: [a]) |] )
-- | 'p' is used to convert your primitive component set into the internal form.
p :: TH.ExpQ -- ^ Quasi-quote a tuple of primitive components here.
-> TH.ExpQ -- ^ This becomes @[Primitive]@ when spliced.
p eq = eq >>= \e -> case e of TupE es -> (return . ListE) =<< (mapM p' es)
_ -> (return . ListE . return) =<< p' e -- This default pattern should also be defined, because it takes two (or more) to tuple!
p' :: TH.Exp -> TH.ExpQ
p' se@(SigE e ty) = do ee <- expToExpExp e
et <- typeToExpType ty
return $ TupE [ AppE (ConE (mkName "HV")) (AppE (VarE (mkName "unsafeCoerce#")) se), ee, et]
p' e = do ee <- expToExpExp e
return $ TupE [ AppE (ConE (mkName "HV")) (AppE (VarE (mkName "unsafeCoerce#")) e), ee, AppE (VarE (mkName "trToTHType")) (AppE (VarE (mkName "typeOf")) e)]
-- nameToExpName :: TH.Name -> TH.Exp
-- nameToExpName = strToExpName . showName
-- strToExpName str = AppE (VarE (mkName "mkName")) (LitE (StringL str))
{- not used any longer
{- This should work in theory, but Language.Haskell.TH.pprint has a bug and it does not print parentheses....
pprintType (ForallT _ _ ty) = pprint ty
pprintType ty = pprint ty
-}
-- 'pprintType' is a workaround for the problem that @Language.Haskell.TH.pprint :: Type -> String@ does not print parentheses correctly.
-- (try @Language.Haskell.TH.runQ [t| (Int->Int)->Int |] >>= \e -> putStrLn (pprint e)@ in your copy of GHCi.)
-- The implementation here is not so pretty, but that's OK for my purposes. Also note that 'pprintType' ignores foralls.
pprintType (ForallT _ [] ty) = pprintType ty
pprintType (ForallT _ _ ty) = error "Type classes are not supported yet. Sorry...."
pprintType (VarT name) = pprint name
pprintType (ConT name) = pprint name
pprintType (TupleT n) = tuplename n
pprintType ArrowT = "(->)"
pprintType ListT = "[]"
pprintType (AppT t u) = '(' : pprintType t ++ ' ' : pprintType u ++ ")"
-- The problem of @Language.Haskell.TH.pprint :: Type -> String@ is now fixed at the darcs HEAD.
-}
primitivesp :: TyConLib -> [Primitive] -> [Typed [CoreExpr]]
primitivesp tcl ps
= zipWith (\ n (_,_,ty) -> [Primitive n] ::: thTypeToType tcl ty) [0..] ps
primitivesToVL :: TyConLib -> [Primitive] -> VarLib
primitivesToVL tcl ps
= listArray (0, length ps - 1) $ map (\ (HV x, e, ty) -> (e, unsafeToDyn tcl (thTypeToType tcl ty) x e)) ps
{-
mkPG :: Int -- ^ memoization depth. (Sub)expressions within this size are memoized, while greater expressions will be recomputed (to save the heap space).
-> [Primitive] -> (Int, Memo)
mkPG n tups = (n, mkPG' tups)
-}
mkPG :: ProgramGenerator pg => [Primitive] -> pg
mkPG = mkPG' True
-- ^ 'mkPG' is defined as:
--
-- > mkPG prims = mkPGSF (mkStdGen 123456) (repeat 5) prims prims
mkMemo :: ProgramGenerator pg => [Primitive] -> pg
mkMemo = mkPG' False
mkPG' cont tups = case mkCommon options{contain=cont} tups of cmn -> mkTrie cmn (primitivesp (tcl cmn) tups)
-- | 'mkPGSF' and 'mkMemoSF' are provided mainly for backward compatibility. These functions are defined only for the 'ProgramGenerator's whose names end with @SF@ (i.e., generators with synergetic filtration).
-- For such generators, they are defined as:
--
-- > mkPGSF gen nrnds optups tups = mkPGOpt (options{primopt = Just optups, contain = True, stdgen = gen, nrands = nrnds}) tups
-- > mkMemoSF gen nrnds optups tups = mkPGOpt (options{primopt = Just optups, contain = False, stdgen = gen, nrands = nrnds}) tups
mkPGSF,mkMemoSF :: ProgramGenerator pg =>
StdGen
-> [Int] -- ^ number of random samples at each depth, for each type.
-> [Primitive]
-> [Primitive] -> pg
mkPGSF = mkPGSF' True
mkMemoSF = mkPGSF' False
mkPGSF' cont gen nrnds optups tups = mkPGOpt (options{primopt = Just optups, contain = cont, stdgen = gen, nrands = nrnds}) tups
-- Currently only the pg==ConstrLSF case makes sense. ¤Ã¤Æ¤Î¤Ï¡¤optups¤Î¤ß¤Ë´Ø¤¹¤ëÏäǡ¤rnds¤Ï´Ø·¸¤Ê¤¤¡¥
mkPG075 :: ProgramGenerator pg => [Primitive] -> pg
mkPG075 = mkPGOpt (options{primopt = Nothing, contain = True, guess = True})
mkMemo075 :: ProgramGenerator pg => [Primitive] -> pg
mkMemo075 = mkPGOpt (options{primopt = Nothing, contain = False, guess = True})
mkPGOpt :: ProgramGenerator pg => Options -> [Primitive] -> pg
mkPGOpt opt prims = case mkCommon opt prims of cmn -> mkTrieOpt cmn (primitivesp (tcl cmn) primsOpt) (primitivesp (tcl cmn) prims)
where primsOpt = case primopt opt of Nothing -> prims
Just po -> po
-- this can be moved to somewhere near Common is defined (currently ProgramGenerator.lhs), when 'Primitive' is moved to some more adequate place.
-- ¼ÂºÝProgramGenerator.lhs¤ÇPrimitive¤ò°·¤¨¤ì¤Ð¤â¤Ã¤Èñ½ã²½¤Ç¤¤ë¤Ï¤º¡¥
mkCommon :: Options -> [Primitive] -> Common
mkCommon opts prims = let (_, _, ts) = unzip3 prims
tyconlib = thTypesToTCL ts
optunit = forget opts
in Cmn {opt = optunit, tcl = tyconlib, vl = primitivesToVL tyconlib prims, rt = mkRandTrie (nrands opts) tyconlib (stdgen opts)}
-- | options for limiting the hypothesis space.
type Options = Opt [Primitive]
forget :: Opt a -> Opt ()
forget opt = case primopt opt of Nothing -> opt{primopt = Nothing}
Just _ -> opt{primopt = Just ()}
setPG :: ProgGen -> IO ()
setPG = writeIORef refmemodeb
-- | @setPrimitives@ creates a @ProgGen@ from the given set of primitives using the current set of options, and sets it as the current program generator.
-- It used to be equivalent to @setPG . mkPG@ which overwrites the options with the default, but it is not now.
setPrimitives :: [Primitive] -> IO ()
setPrimitives tups = do PG (x,y,cmn) <- readIORef refmemodeb
setPG $ mkPGOpt ((opt cmn){primopt=Nothing}) tups
-- setPrimitives tups = writeIORef refmemodeb (mkPG tups) -- This definition overwrites the old configuration.
#ifdef HASKELLSRC
-- | 'load' loads a component library file.
load :: FilePath
-> TH.ExpQ -- ^ This becomes @([[HValue]], String)@ when spliced.
load fp = do str <- runIO $ readFile fp
f str
-- | f is supposed to be used by load, but not hidden.
f :: String -> TH.ExpQ
f str = return (TupE [ f' $ readHsDecls (str++"\n"), LitE (StringL str)])
f' :: [HsDecl] -> TH.Exp
f' decls = ListE [ ListE $ map (\e -> AppE (ConE (mkName "HV")) (AppE (VarE (mkName "unsafeCoerce#")) (VarE (mkName (hsNameToName e))))) hsnames |
HsTypeSig _loc hsnames hsqt@(HsQualType _context hsty) <- decls ]
primitives :: [[HValue]] -> TyConLib -> [HsDecl] -> [Typed [CoreExpr]]
primitives cnl tcl decls
= zipWith (\ (exps,ty) hvs -> zipWith (\ e (HV x) -> Primitive e (unsafeToDyn tcl ty x e)) exps hvs ::: ty)
[ (map (VarE . mkName . hsNameToName) hsnames, hsTypeToType tcl hsty) | HsTypeSig _loc hsnames hsqt@(HsQualType _context hsty) <- decls ]
cnl
{- I once thought the following definition would be better, but on the second thought I was bothered because loadPG will become obsolete....
loadPG :: Int -- ^ memoization depth
-> FilePath
-> TH.ExpQ -- ^ This becomes 'Memo' when spliced.
loadPG n str = [| loadPG' n
-}
loadPG :: ProgramGenerator a => ([[HValue]], String) -> a
loadPG (cnl, str) = mkTrie tcl (primitives cnl tcl hsdecls)
where tcl = extractTyConLib hsdecls
hsdecls = readHsDecls str
loadPrimitives :: ([[HValue]], String) -> IO ()
loadPrimitives tup = writeIORef refmemodeb (loadPG tup)
#endif
-- | 'setTimeout' sets the timeout in microseconds. Also, my implementation of timeout also catches inevitable exceptions like stack space overflow. Note that setting timeout makes the library referentially untransparent. (But currently @setTimeout 20000@ is the default!)
setTimeout :: Int -- ^ time in microseconds
-> IO ()
setTimeout n = do pto <- newPTO n
PG (x,y,cmn) <- readIORef refmemodeb
writeIORef refmemodeb $ PG (x,y,cmn{opt = (opt cmn){timeout=Just pto}})
-- | 'unsetTimeout' disables timeout. This is the safe choice.
unsetTimeout :: IO ()
unsetTimeout = do PG (x,y,cmn) <- readIORef refmemodeb
writeIORef refmemodeb $ PG (x,y,cmn{opt = (opt cmn){timeout=Nothing}})
{-# NOINLINE refdepth #-}
refdepth :: IORef Int
refdepth = unsafePerformIO (newIORef defaultDepth)
defaultDepth = 10
setDepth :: Int -- ^ memoization depth. (Sub)expressions within this size are memoized, while greater expressions will be recomputed (to save the heap space).
-> IO ()
setDepth d = writeIORef refdepth d
-- ^ Currently the default depth is 10. You may want to lower the value if your computer often swaps, or increase it if you have a lot of memory.
{-# NOINLINE refmemodeb #-}
refmemodeb :: IORef ProgGen
refmemodeb = unsafePerformIO (newIORef defaultMD)
defaultMD = mkPG [] :: ProgGen
trsToTCL :: [TypeRep] -> TyConLib -- ReadType.extractTyConLib :: [HsDecl] -> TyConLib¤ò»²¹Í¤Ë¤Ç¤¤ë¡¥ -- ¤³¤Î2¹Ô¤È
trsToTCL trs
= (Map.fromListWith (\new old -> old) [ tup | k <- [0..7], tup <- tcsByK ! k ], tcsByK)
where tnsByK :: Array Kind [TypeName]
tnsByK = accumArray (flip (:)) [] (0,7) ( trsToTCstrs trs ) -- ¤³¤³¤òÊѤ¨¤¿¡¥
tcsByK :: Array Kind [(TypeName,Types.TyCon)]
tcsByK = listArray (0,7) [ tnsToTCs (tnsByK ! k) | k <- [0..7] ]
tnsToTCs :: [TypeName] -> [(TypeName,Types.TyCon)]
tnsToTCs tns = zipWith (\ i tn -> (tn, i)) [0..] tns
-- x ¼ÂºÝ¤Ë¤Ï(->)¤ÏTyCon°·¤¤¤Ë¤Ï¤·¤Ê¤¤¤ó¤À¤±¤É¡¤¤Û¤ó¤Î¤Á¤ç¤Ã¤È¤À¤±ÌµÂ̤ˤʤë¤À¤±¤Ê¤Î¤Ç¤¤¤¤¤Ç¤·¤ç¡¥
trsToTCstrs :: [TypeRep] -> [(Int, String)] -- Int is the arity of the TyCon. There can be duplicates.
trsToTCstrs [] = []
trsToTCstrs (tr:ts) = case splitTyConApp tr of (tc,trs) -> (length trs, tyConString tc) : trsToTCstrs (trs++ts)
-- Memo¤ägetEverything¼«ÂΤÏIORef¤ò»È¤ï¤º¤ËIO¤Ê¤·¤Ç¼ÂÁõ¤Ç¤¤ëÌõ¤Ç¡¤¤½¤Î°ÕÌ£¤Ç¤Ï¡¤IORef¤ò»È¤ï¤Ê¤¤Êý¤¬¤¤¤¤¤«¤â¡¥
-- x ¤Ä¤¤¤Ç¤Ë¤¤¤¦¤È¡¤1ÉäǤΥ¿¥¤¥à¥¢¥¦¥È¤òɽ¤¹PTO¡Ê¤ÎGLOBAL_VAR¡Ë¤âIO¤Ê¤·¤ÇÍѰդǤ¤ë¡¥¡ÊunsafePerformIO»È¤¦¤±¤É¡Ë
-- | 'getEverything' uses the \'global\' values set with @set*@ functions. 'getEverythingF' is its filtered version
getEverything :: Typeable a => IO (Every a)
getEverything = do depth <- readIORef refdepth
memodeb <- readIORef refmemodeb
return (everything depth memodeb)
getEverythingF :: Typeable a => IO (Every a)
getEverythingF =do depth <- readIORef refdepth
memodeb <- readIORef refmemodeb
return (everythingF depth memodeb)
{-
getEverything = result
where ty = typeOf $ snd $ head $ head $ unsafePerformIO result
result = do memodeb@(trie,prims,depth,tcl) <- readIORef refmemodeb
return $ unMx $ toMx (fmap (\ e -> (exprToTHExp (error "unknown conlib") e, unsafeExecute e)) (matchingPrograms (trToType tcl ty) memodeb))
-}
-- | 'everything' generates all the expressions that fit the inferred type, and their representations in the 'TH.Exp' form.
-- It returns a stream of lists, which is equivalent to Spivey's @Matrix@ data type, i.e., that contains expressions consisted of n primitive components at the n-th element (n = 1,2,...).
-- 'everythingF' is its filtered version
everything, everythingF :: (ProgramGenerator pg, Typeable a) =>
Int -- ^ memoization depth.
-> pg -- ^ program generator
-> Every a
everything memodepth memodeb = et undefined memodepth memodeb (mxExprToEvery "MagicHaskeller.everything: type mismatch" memodeb)
everythingF memodepth memodeb = et undefined memodepth memodeb (mxExprFiltEvery "MagicHaskeller.everythingF: type mismatch" memodeb)
et :: (ProgramGenerator pg, Typeable a) =>
a -- ^ dummy argument
-> Int -- ^ memoization depth.
-> pg -- ^ program generator
-> (Types.Type -> Matrix AnnExpr -> Matrix (Exp, a))
-> Every a
et dmy memodepth memodeb filt = unMx $ filt ty $ matchingPrograms ty (memodepth,memodeb)
where ty = trToType (extractTCL memodeb) (typeOf dmy)
noFilter :: ProgramGenerator pg => pg -> Types.Type -> a -> a
noFilter _m _t = id
mxExprToEvery :: (Expression e, Search m, ProgramGenerator pg, Typeable a) => String -> pg -> Types.Type -> m e -> m (Exp, a)
mxExprToEvery msg memodeb _ = fmap (unwrapAE msg memodeb . toAnnExpr (reducer memodeb))
mxExprFiltEvery :: (Expression e, FiltrableBF m, ProgramGenerator pg, Typeable a) => String -> pg -> Types.Type -> m e -> m (Exp, a)
mxExprFiltEvery msg memodeb ty = fmap (unwrapAE msg memodeb) . randomTestFilter memodeb ty . fmap (toAnnExpr (reducer memodeb))
unwrapAE :: (ProgramGenerator pg, Typeable a) => String -> pg -> AnnExpr -> (Exp, a)
unwrapAE msg memodeb (AE e dyn) = (exprToTHExp (extractVL memodeb) e, fromDyn tcl dyn (error msg))
where tcl = extractTCL memodeb
{-
̵¸Â¥ê¥¹¥È¤ò»È¤¦¤Ê¤é¡¤unsafeInterleaveIO¤¬É¬ÍפʤϤº¡¥¤½¤Î¾ì¹çIO¤ËÆò½¤¹¤ë¤³¤È¤Ë¤Ê¤ë¡¥
-}
everythingM :: (ProgramGenerator pg, Typeable a, Monad m, Functor m) =>
Int -- ^ memoization depth.
-> pg -- ^ program generator
-> Int -- ^ query depth
-> m [(TH.Exp, a)]
everythingM = eM undefined
eM :: (ProgramGenerator pg, Typeable a, Monad m, Functor m) =>
a -- ^ dummy argument
-> Int -- ^ memoization depth.
-> pg -- ^ program generator
-> Int
-> m [(TH.Exp, a)]
eM dmy memodepth memodeb = result
where tcl = extractTCL memodeb
ty = trToType tcl $ typeOf dmy
result = unRcT $ mxExprToEvery "MagicHaskeller.everythingM: type mismatch" memodeb undefined $ matchingPrograms ty (memodepth,memodeb)
strip :: m (Every a) -> a
strip = undefined
unifyable, matching, unifyableF, matchingF :: ProgramGenerator pg =>
Int -- ^ memoization depth
-> pg -- ^ program generator
-> TH.Type -- ^ query type
-> [[TH.Exp]]
-- ^ Those functions are like 'everything', but take 'TH.Type' as an argument, which may be polymorphic.
-- For example, @'printQ' ([t| forall a. a->a->a |] >>= return . 'unifyable' True 10 memo)@ will print all the expressions using @memo@ whose types unify with @forall a. a->a->a@.
-- (At first I (Susumu) could not find usefulness in finding unifyable expressions, but seemingly Hoogle does something alike, and these functions might enhance it.)
unifyable memodepth memodeb tht = unMx $ genExps noFilter unifyingPrograms memodepth memodeb tht
matching memodepth memodeb tht = unMx $ genExps noFilter matchingPrograms memodepth memodeb tht
-- unifyablePos memodepth memodeb tht = unMx $ toMx $ fmap (\(es,subst,mx) -> (map (pprintUC . exprToTHExp (extractVL memodeb)) es, subst, mx)) $ unifyingPossibilities (thTypeToType (extractTCL memodeb) tht) (memodepth,memodeb)
unifyableF memodepth memodeb tht = unMx $ genExps randomTestFilter unifyingPrograms memodepth memodeb tht
matchingF memodepth memodeb tht = unMx $ genExps randomTestFilter matchingPrograms memodepth memodeb tht
genExps filt rawGenProgs memodepth memodeb tht
= case thTypeToType (extractTCL memodeb) tht of
ty -> fmap (exprToTHExp (extractVL memodeb) . toCE) $
filt memodeb ty $ fmap (toAnnExpr (reducer memodeb)) (rawGenProgs ty (memodepth,memodeb))
-- Another advantage of these functions is that you do not need to define @instance Typeable@ for user defined types.
-- ¤È»×¤Ã¤¿¤±¤É¡¤GHC¤Ç¤Ïderiving Typeable¤Ç´Êñ¤ËÄêµÁ¤Ç¤¤ë¤·¡¤Typeable¤¬ÄêµÁ¤Ç¤¤Ê¤¤·¿¤Ê¤ó¤Æ¤Ê¤µ¤½¤¦¡Êderiving Typeable¤·Ëº¤ì¤¿data type¤ò´Þ¤àdata¤¬¤½¤¦¡©¡Ë
-- specializedPossi memodepth memodeb tht = unMx $ toMx $ fmap show (specializedPossibleTypes (thTypeToType (extractTCL memodeb) tht) (memodepth,memodeb))
{-
wrappit :: (Search m, Functor m, Typeable a) => m CoreExpr -> [[(TH.Exp,a)]]
wrappit = unMx . toMx . fmap (\ e -> (exprToTHExp e, unsafeExecute e))
-}
-- | @'findOne' pred@ finds an expression 'e' that satisfies @pred e == True@, and returns it in 'TH.Exp'.
findOne :: Typeable a => (a->Bool) -> TH.Exp
findOne pred = unsafePerformIO $ findDo (\e _ -> return e) pred
{- x Ç°¤Î¤¿¤á¤ä¤Ã¤Æ¤ß¤¿¤±¤É¡¤¤ä¤Ã¤Ñ¥À¥á¤ä¤Í¡¥¤Æ¤æ¡¼¤«¡¤Recomp¤Î¤Þ¤Þ¤ä¤Ã¤Æ³Æ¿¼¤µ¤Ç¸«¤ë¼ê¤Ï¤¢¤ë¤«¤â¡¥
findAny :: Typeable a => (a->Bool) -> [TH.Exp]
findAny pred = unsafePerformIO $ findDo (\e r -> r >>= \es -> return (e:es)) pred
-}
-- | 'printOne' prints the expression found first.
printOne :: Typeable a => (a->Bool) -> IO ()
printOne pred = do expr <- findDo (\e _ -> return e) pred
putStrLn $ pprintUC expr
-- | 'printAny' prints all the expressions satisfying the given predicate.
printAny :: Typeable a => (a->Bool) -> IO ()
printAny = findDo (\e r -> putStrLn (pprintUC e) >> r)
findDo :: Typeable a => (TH.Exp -> IO b -> IO b) -> (a->Bool) -> IO b
findDo op pred = do et <- getEverything
md <- readIORef refmemodeb
let mpto = timeout $ opt $ extractCommon md
fp mpto (concat et)
where fp mpto ((e,a):ts) = do -- hPutStrLn stderr ("trying" ++ pprintUC e)
result <- maybeWithPTO seq (return (pred a)) mpto
case result of Just True -> e `op` fp mpto ts
Just False -> fp mpto ts
Nothing -> hPutStrLn stderr ("timeout on "++pprintUC e) >> fp mpto ts
-- x ËÜÅö¤Ïrecomp¤Î¤Þ¤Þ¤Ç¤ä¤Ã¤¿Êý¤¬Â®¤¤¤Ï¤º¡¥
-- | 'filterFirst' is like 'printAny', but by itself it does not print anything. Instead, it creates a stream of expressions represented in tuples of 'TH.Exp' and the expressions themselves.
filterFirst :: Typeable a => (a->Bool) -> IO (Every a)
filterFirst pred = do et <- getEverything
filterThen pred et
-- randomTestFilter should be applied after filterThen, because it's slower
filterFirstF :: (Typeable a, Filtrable a) => (a->Bool) -> IO (Every a)
filterFirstF pred = do et <- getEverything
filterThenF pred et
filterThenF pred et = do
fd <- filterThen pred et
memodeb <- readIORef refmemodeb
let mpto = timeout $ opt $ extractCommon memodeb
return $ everyF mpto fd
{- refmemodeb ¤Ë¤¢¤ë¤â¤Î¤¬¼ÂºÝ¤Ë»È¤ï¤ì¤Æ¤¤¤ë¤â¤Î¤È¤Ï¸Â¤é¤Ê¤¤¡¥refmemodeb¤ò»È¤ï¤Ê¤¤¤È¤¤¤¦ÁªÂò¤â¤¢¤ë¤Î¤Ç¡¥
filterFirstF pred = do et <- getEverything
filterThenF pred et
filterThenF pred ts = do
fd <- filterThen pred ts
let x=undefined
_=pred x
memodeb <- readIORef refmemodeb
return $ unMx $ randomTestFilter memodeb (getType memodeb x) $ Mx et
getType :: Typeable a => a -> ProgGen -> Types.Type
getType ty memodeb = trToType (extractTCL memodeb) (typeOf ty)
-}
everyF :: (Typeable a, Filtrable a) =>
Maybe Int -- ^ microsecs until timeout
-> Every a -> Every a
everyF mto = unMx . unsafeRandomTestFilter mto . Mx
-- | 'filterThen' may be used to further filter the results.
filterThen :: Typeable a => (a->Bool) -> Every a -> IO (Every a)
filterThen pred ts = do md <- readIORef refmemodeb
let mpto = timeout $ opt $ extractCommon md
return (map (fp mpto) ts)
where fp _ [] = []
fp mpto (ea@(e,a):ts) = case unsafePerformIO (maybeWithPTO seq (return (pred a)) mpto) of
Just True -> ea : fp mpto ts
_ -> fp mpto ts
{- if not doing timeout
filterThen pred ts = return (map fp ts)
where fp [] = []
fp (ea@(e,a):ts) = case pred a of
True -> ea : fp ts
_ -> fp ts
-}
{- x ¤¤¤í¤¤¤í¤ä¤Ã¤Æ¤ß¤¿¤±¤É¡¤¤ä¤Ã¤Ñɽ¼¨¤ÈÂåÆþ¤ò°ìÅ٤ˤä¤ë¤Î¤Ï̵Íý¡¥
... ¤Æ¤æ¡¼¤«¡¤
System.IO.Unsafe.unsafeInterleaveIO :: IO a -> IO a
¤ò»È¤¨¤Ð¤¤¤¤¤Ï¤º¡¥
filterThen pred ts = do mpto <- readIORef refpto
return (fp mpto ts)
where fp mpto (ea@(e,a):ts) = if unsafePerformIO (do mb <- maybeWithPTO (return (pred a)) mpto
case mb of Just True -> do putStrLn $ pprintUC e
return True
_ -> return False)
then ea : fp mpto ts
else fp mpto ts
-}
{-
filterThen pred ts = do mpto <- readIORef refpto
fp mpto ts
where fp mpto (ea@(e,a):ts) = do mb <- maybeWithPTO (return (pred a)) mpto
case mb of Just True -> do putStrLn $ pprintUC e
rest <- fp mpto ts
return (ea:rest)
_ -> fp mpto ts
-}
-- utility functions to pretty print the results
-- | 'pprs' pretty prints the results to the console, using 'pprintUC'
pprs :: Every a -> IO ()
pprs = mapM_ (putStrLn . pprintUC . fst) . concat
-- | 'pprintUC' is like 'Language.Haskell.TH.pprint', but unqualifies (:) before pprinting in order to avoid printing "GHC.Types.:" which GHCi does not accept and sometimes annoys when doing some demo.
pprintUC :: (Ppr a, Data a) => a -> String
pprintUC = pprint . everywhere (mkT unqCons)
unqCons :: Name -> Name
unqCons n | show n == show '(:) = mkName ":" -- NB: n == '(:) would not work due to the definition of Eq Name.
| otherwise = n
printQ :: (Ppr a, Data a) => Q a -> IO ()
printQ q = runQ q >>= putStrLn . pprintUC
\end{code}