MagicHaskeller-0.9.6.4.3: MagicHaskeller.lhs
--
-- (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
, useArrowT, uAT
) where
import Data.Generics(everywhere, mkT, Data, gmapT)
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
<interactive>:5:13:
Illegal type constructor or class name: ¡Æ(->)¡Ç
When splicing a TH type: GHC.Prim.(->) GHC.Types.Int GHC.Types.Bool
In the splice: $([t| (->) Int Bool |])
Prelude Language.Haskell.TH> ((/=0) :: $([t| (->) Int|]) Bool) 3
<interactive>:7:13:
Illegal type constructor or class name: ¡Æ(->)¡Ç
When splicing a TH type: GHC.Prim.(->) GHC.Types.Int
In the splice: $([t| (->) Int |])
Prelude Language.Haskell.TH> ((/=0) :: $([t| Int -> Bool |])) 3
True
This is as opposed to the description in
https://downloads.haskell.org/~ghc/latest/docs/html/libraries/template-haskell-2.10.0.0/src/Language-Haskell-TH-Syntax.html#line-1414
saying
But if the original HsSyn used prefix application, we won't use
these special TH constructors. For example
[] t ConT "[]" `AppT` t
(->) t ConT "->" `AppT` t
In this way we can faithfully represent in TH whether the original
HsType used concrete syntax or not.
So this may be a bug, introduced when making TH more pedantic.
Reading "(->)" to (ConT GHC.Prim.(->)) is a good news for MagicHaskeller which abuses (->) to indicate constructor consumption.
In the case that the distinction between prefixed (->) and the infixed -> is obsoleted, we can still use
type (:-->) = (->)
but then, we need to change more code.
-}
-- nameToExpName :: TH.Name -> TH.Exp
-- nameToExpName = strToExpName . showName
-- strToExpName str = AppE (VarE (mkName "mkName")) (LitE (StringL str))
{- not used any longer
{- This should work in theory, but Language.Haskell.TH.pprint has a bug and it does not print parentheses....
pprintType (ForallT _ _ ty) = pprint ty
pprintType ty = pprint ty
-}
-- 'pprintType' is a workaround for the problem that @Language.Haskell.TH.pprint :: Type -> String@ does not print parentheses correctly.
-- (try @Language.Haskell.TH.runQ [t| (Int->Int)->Int |] >>= \e -> putStrLn (pprint e)@ in your copy of GHCi.)
-- The implementation here is not so pretty, but that's OK for my purposes. Also note that 'pprintType' ignores foralls.
pprintType (ForallT _ [] ty) = pprintType ty
pprintType (ForallT _ _ ty) = error "Type classes are not supported yet. Sorry...."
pprintType (VarT name) = pprint name
pprintType (ConT name) = pprint name
pprintType (TupleT n) = tuplename n
pprintType ArrowT = "(->)"
pprintType ListT = "[]"
pprintType (AppT t u) = '(' : pprintType t ++ ' ' : pprintType u ++ ")"
-- The problem of @Language.Haskell.TH.pprint :: Type -> String@ is now fixed at the darcs HEAD.
-}
primitivesp :: TyConLib -> [[Primitive]] -> [[Typed [CoreExpr]]]
primitivesp 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}