-- -- (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, -- '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, -- | '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, Options, Opt(..), options, MemoType(..), -- | These are versions for 'ProgramGeneratorIO'. mkPGIO, mkPGXOptIO, #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, 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, -- ** 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, etup, mkCurriedDecls ) 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.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 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.Classification(unsafeRandomTestFilter, Filtrable) import MagicHaskeller.Instantiate(mkRandTrie) import MagicHaskeller.MemoToFiles(MemoType(..)) import Data.List(genericLength) -- 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} mkCurriedDecls :: String -> ExpQ -> ExpQ -> DecsQ mkCurriedDecls tag funq eq = do e <- eq fun <- funq case e of TupE es -> fmap concat $ mapM (mcd fun) es _ -> mcd fun e where mcd :: Exp -> Exp -> DecsQ mcd fun v@(VarE name) = let nb = nameBase name in return [ValD (VarP $ mkName $ nb++tag) (NormalB (AppE fun 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 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 = 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 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 (SigE e ty) = p1' (SigE e $ useArrowT ty) 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 = [| (HV (unsafeCoerce# $(return e)), $(expToExpExp e), trToTHType (typeOf $(return e))) |] p1' se e ty = [| (HV (unsafeCoerce# $(return se)), $(expToExpExp e), $(typeToExpType ty)) |] useArrowT :: TH.Type -> TH.Type useArrowT = everywhere (mkT uAT) uAT (ConT name) | nameBase name == "(->)" = ArrowT uAT t = 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 :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 :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 tcl pss = let ixs = scanl (+) 0 $ map genericLength pss in zipWith (\ix -> mergesortWithBy (\(x:::t) (y:::_) -> (x++y):::t) (\(_:::t) (_:::u) -> compare t u) . zipWith (\ n (_,e,ty) -> [if expIsAConstr e then PrimCon n else Primitive n] ::: toCxt (numCxts e) (thTypeToType tcl ty)) [ix..]) ixs pss -- See if the argument is a constructor expression. expIsAConstr (ConE _) = True expIsAConstr (LitE _) = True expIsAConstr (ListE _) = True expIsAConstr (TupE _) = True expIsAConstr (AppE e _) = expIsAConstr e expIsAConstr (InfixE (Just _) (ConE _) (Just _)) = True expIsAConstr _ = False numCxts (VarE nm) = case nameBase nm of 'b':'y':d:'_':_ | isDigit d -> digitToInt d '-':'-':xs@('#':_) -> length $ takeWhile (=='#') xs _ -> 0 numCxts _ = 0 toCxt 0 t = t toCxt n (t :-> u) = t :=> toCxt (n-1) u primitivesc :: TyConLib -> [Primitive] -> [Typed [CoreExpr]] primitivesc tcl ps = mergesortWithBy (\(x:::t) (y:::_) -> (x++y):::t) (\(_:::t) (_:::u) -> compare t u) $ map (\ (HV x,e,thty) -> let ty = thTypeToType tcl thty in [Context $ Dict $ PD.unsafeToDyn tcl ty x e] ::: {- toCxt (numCxts e) -} ty) ps mkPG :: ProgramGenerator pg => [Primitive] -> pg mkPG = mkPGX [] . (:[]) mkPGX :: ProgramGenerator pg => [Primitive] -> [[Primitive]] -> pg mkPGX = mkPG' True -- ^ 'mkPG' is defined as: -- -- > mkPG prims = mkPGSF (mkStdGen 123456) (repeat 5) prims prims mkMemo :: ProgramGenerator pg => [Primitive] -> pg mkMemo = mkPG' False [] . (:[]) mkPG' :: ProgramGenerator pg => Bool -> [Primitive] -> [[Primitive]] -> pg mkPG' cont classes tups = case mkCommon options{contain=cont} totals totals of cmn -> mkTrie cmn (primitivesc (tcl cmn) classes) (primitivesp (tcl cmn) tups) where totals = concat tups ++ 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 = mkPGSF' True mkMemoSF = mkPGSF' False mkPGSF' cont gen nrnds classes optups tups = mkPGOpt (options{primopt = Just [optups], contain = cont, stdgen = gen, nrands = nrnds}) classes tups -- Currently only the pg==ConstrLSF case makes sense. ってのは，optupsのみに関する話で，rndsは関係ない． mkPG075 :: ProgramGenerator pg => [Primitive] -> [Primitive] -> pg mkPG075 = mkPGOpt (options{primopt = Nothing, contain = True, guess = True}) mkMemo075 :: ProgramGenerator pg => [Primitive] -> [Primitive] -> pg mkMemo075 = mkPGOpt (options{primopt = Nothing, contain = False, guess = True}) mkPGOpt :: ProgramGenerator pg => Options -> [Primitive] -> [Primitive] -> pg mkPGOpt opt classes prims = mkPGXOpt opt classes [] [prims] [] mkPGXOpt :: ProgramGenerator pg => Options -> [Primitive] -> [(Primitive,Primitive)] -> [[Primitive]] -> [[(Primitive,Primitive)]] -> pg mkPGXOpt = mkPGXOpts mkTrieOpt mkPGIO :: ProgramGeneratorIO pg => [Primitive] -> [Primitive] -> IO pg mkPGIO classes prims = mkPGXOptIO options classes [] [prims] [] mkPGXOptIO :: ProgramGeneratorIO pg => Options -> [Primitive] -> [(Primitive,Primitive)] -> [[Primitive]] -> [[(Primitive,Primitive)]] -> IO pg mkPGXOptIO = mkPGXOpts mkTrieOptIO mkPGXOpts mkt opt classes partclasses prims partprims = case mkCommon opt (concat totalss ++ totalclss) (concat partialss ++ partialclss) 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 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] -> [Primitive] -> IO () setPrimitives classes tups = do PG (_,_,_,cmn) <- readIORef refmemodeb setPG $ mkPGOpt ((opt cmn){primopt=Nothing}) classes 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 [] yss = yss zipAppend xss [] = xss zipAppend (xs:xss) (ys:yss) = (xs++ys) : zipAppend xss yss #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,z,cmn) <- readIORef refmemodeb writeIORef refmemodeb $ PG (x,y,z,cmn{opt = (opt cmn){timeout=Just pto}}) -- | 'unsetTimeout' disables timeout. This is the safe choice. unsetTimeout :: IO () unsetTimeout = do PG (x,y,z,cmn) <- readIORef refmemodeb writeIORef refmemodeb $ PG (x,y,z,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,z,cmn) <- readIORef refmemodeb writeIORef refmemodeb $ PG (x,y,z,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, tyConName 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 => Bool -- ^ whether to include functions with unused arguments -> IO (Every a) getEverything withAbsents = do memodeb <- readIORef refmemodeb return (everything memodeb withAbsents) getEverythingF :: Typeable a => Bool -- ^ whether to include functions with unused arguments -> IO (Every a) getEverythingF withAbsents = do memodeb <- readIORef refmemodeb return (everythingF memodeb 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 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)) -> Bool -- ^ whether to include functions with unused arguments -> Every a et dmy memodeb filt withAbsents = unMx $ filt ty $ matchPs withAbsents ty memodeb where ty = trToType (extractTCL memodeb) (typeOf dmy) noFilter :: ProgramGenerator pg => pg -> Types.Type -> a -> a noFilter _m _t = id matchPs True = matchingPrograms matchPs False = matchingProgramsWOAbsents mxExprToEvery :: (Expression e, Search m, WithCommon pg, Typeable a) => String -> pg -> Types.Type -> m e -> m (Exp, a) mxExprToEvery msg memodeb _ = fmap (unwrapAE (extractVL memodeb) msg memodeb . toAnnExpr (reducer $ extractCommon memodeb)) mxExprFiltEvery :: (Expression e, FiltrableBF m, WithCommon pg, Typeable a) => String -> pg -> Types.Type -> m e -> m (Exp, a) mxExprFiltEvery msg memodeb ty = fmap (unwrapAE (extractVL memodeb) msg memodeb) . randomTestFilter memodeb ty . fmap (toAnnExpr (reducer $ extractCommon memodeb)) unwrapAE :: (WithCommon pg, Typeable a) => VarLib -> String -> pg -> AnnExpr -> (Exp, a) unwrapAE vl msg memodeb (AE e dyn) = (exprToTHExp vl e, fromDyn tcl dyn (error msg)) where tcl = extractTCL 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 dmy memodeb withAbsents = unMx $ fmap (\e -> (unwrapAE (vl cmn) "MagicHaskeller.etup: type mismatch" memodeb $ toAnnExpr (execute (opt cmn) (vl cmn)) e, unwrapAE (pvl cmn) "MagicHaskeller.etup: type mismatch" memodeb $ toAnnExpr (execute (opt cmn) (pvl cmn)) $ toCE e)) $ matchPs withAbsents ty memodeb where ty = trToType (extractTCL memodeb) (typeOf dmy) cmn = extractCommon 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 = eM 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 dmy memodeb withAbsents = result where tcl = extractTCL memodeb ty = trToType tcl $ typeOf dmy result = unRcT $ mxExprToEvery "MagicHaskeller.everythingM: type mismatch" memodeb undefined $ matchPs withAbsents ty memodeb everythingIO :: (ProgramGeneratorIO pg, Typeable a) => pg -- ^ program generator -> EveryIO a everythingIO = eIO undefined eIO :: (ProgramGeneratorIO 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 $ extractCommon 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 => Bool -- ^ whether to include functions with unused arguments -> (a->Bool) -> TH.Exp findOne withAbsents pred = unsafePerformIO $ findDo (\e _ -> return e) withAbsents 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 => Bool -- ^ whether to include functions with unused arguments -> (a->Bool) -> IO TH.Exp printOne withAbsents pred = do expr <- findDo (\e _ -> return e) withAbsents pred putStrLn $ pprintUC expr return 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 = printAll -- provided just for backward compatibility printAll = findDo (\e r -> putStrLn (pprintUC e) >> r) printAllF :: (Typeable a, Filtrable a) => Bool -- ^ whether to include functions with unused arguments -> (a->Bool) -> IO () printAllF withAbsents pred = do et <- getEverything withAbsents fet <- filterThenF pred et pprs fet findDo :: Typeable a => (TH.Exp -> IO b -> IO b) -> Bool -- ^ whether to include functions with unused arguments -> (a->Bool) -> IO b findDo op withAbsents pred = do et <- getEverything withAbsents 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 => Bool -- ^ whether to include functions with unused arguments -> (a->Bool) -> IO (Every a) filterFirst withAbsents pred = do et <- getEverything withAbsents filterThen pred 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 withAbsents pred = do et <- getEverything withAbsents filterThenF pred et filterThenF pred et = do fd <- filterThen pred et memodeb <- readIORef refmemodeb let o = opt $ extractCommon memodeb return $ everyF o 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 -> Every a -> Every a everyF o = unMx . unsafeRandomTestFilter (timeout o) (fcnrand o) . 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 pred) ts) fp :: Typeable a => Maybe Int -> (a->Bool) -> [(Exp, a)] -> [(Exp, a)] fp mpto pred = filter (\ (_,a) -> unsafePerformIO (maybeWithTO seq mpto (return (pred a))) == Just 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 mpto pred ts = [ t | Just t <- map (fpart mpto pred) ts ] fpart mpto pred (ea@(_,a),eap@(_,ap)) = case unsafePerformIO (maybeWithTO seq mpto (return $! (pred ap))) of Just True -> Just eap Just False -> Nothing Nothing -> case unsafePerformIO (maybeWithTO seq mpto (return $!(pred a))) of Just True -> Just ea _ -> 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) -> [((Exp, a),(Exp,a))] -> IO [(Exp, a)] fpartialIO mpto pred ts = do mbs <- interleaveActions {- parallelInterleaved -} $ map (fpartIO mpto pred) ts --fpartialIO mpto pred ts = do mbs <- mapIO (fpartIO mpto pred) ts return [ tup | Just tup <- mbs ] #ifdef PAR fpartialParIO :: Typeable a => Maybe Int -> (a->Bool) -> [((Exp, a),(Exp,a))] -> ParIO [(Exp, 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) -> ((Exp, a),(Exp,a)) -> IO (Maybe (Exp, a)) fpartIO mpto pred (ea@(_,a),eap@(_,ap)) = do mbb <- maybeWithTO seq mpto $ return $! pred ap case mbb of Just True -> return $ Just eap Just False -> return Nothing Nothing -> do mbb2 <- maybeWithTO seq mpto $ return $! pred a case mbb2 of Just True -> return $ Just ea _ -> return Nothing {- これだと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 -} fpIO :: Typeable a => Maybe Int -> (a->Bool) -> [((Exp, a),(Exp,a))] -> IO [(Exp, a)] fpIO mpto pred ts = do mbs <- {-interleaveActions -}sequence {- parallelInterleaved -} $ {- take 19 $ drop 6550 $ -} zipWith (fIO mpto pred) ts [0..] --fpIO mpto pred ts = do mbs <- runParIO $ mapParIO (liftIO $ fIO mpto pred) $ zip ts [0..] return [ tup | Just tup <- mbs ] fIO :: Typeable a => Maybe Int -> (a->Bool) -> ((Exp, a),(Exp,a)) -> Int -> IO (Maybe (Exp, a)) fIO mpto pred (ea@(e,a),eap@(_,ap)) i = do hPutStrLn stderr (shows i " trying "++pprint e) mbb <- maybeWithTO seq mpto $ return $! pred a case mbb of Just True -> return $ Just ea _ -> return Nothing mapIO :: (a -> IO b) -> [a] -> IO [b] mapIO f xs = mapM (spawnIO . f) xs >>= mapM takeMVar spawnIO :: IO a -> IO (MVar a) spawnIO a = do mv <- newEmptyMVar forkIO (a >>= \v -> v `seq` putMVar mv v) return 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 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, lengthsIOnLn :: Int -> EveryIO a -> IO () lengthsIOn depth eio = mapM_ (\d -> eio d >>= putStr . (' ':) . show . length) [0..depth-1] lengthsIOnLn depth eio = lengthsIOn depth eio >> putStrLn "" printQ :: (Ppr a, Data a) => Q a -> IO () printQ q = runQ q >>= putStrLn . pprintUC \end{code}