diff --git a/Control/Monad/Search/Combinatorial.lhs b/Control/Monad/Search/Combinatorial.lhs --- a/Control/Monad/Search/Combinatorial.lhs +++ b/Control/Monad/Search/Combinatorial.lhs @@ -10,7 +10,7 @@ {-# OPTIONS -cpp -XUndecidableInstances -XMultiParamTypeClasses -XTypeSynonymInstances #-} module Control.Monad.Search.Combinatorial(Matrix(..), (/\), (\/), Recomp(..), RecompT(..), rcToMx, mxToRc, Search(..), diag, Delay(..), msumMx, msumRc, listToRc, consMx, consRc, zipWithBF, printMx, printNMx, {- filterMx, -} mapDepthDB, Bag, Stream, cat, toList, getDepth, scanl1BF, zipDepthMx, zipDepthRc, zipDepth3Mx, zipDepth3Rc, scanlRc, - DBound(..), zipDepthDB, DBMemo(..), Memoable(..), shrink) where + DBound(..), DBoundT(..), zipDepthDB, DBMemo(..), Memoable(..), shrink, DB, dbtToRcT) where import Control.Monad -- hiding (join) -- ... but still collided when using Hat. #ifdef HOOD import Observe @@ -94,6 +94,8 @@ fmap f (DB g) = DB (\d -> fmap (\(x,i)->(f x,i)) (g d)) instance Functor f => Functor (RecompT f) where fmap f (RcT g) = RcT $ \dep -> fmap (map f) (g dep) +instance Functor f => Functor (DBoundT f) where + fmap f (DBT g) = DBT (\d -> fmap (map (\(x,i)->(f x,i))) (g d)) -- should be slightly more efficient than msum msumMx xs = Mx (xs : nils) @@ -161,20 +163,24 @@ filterMx f = mapDepth (filter f) -} +class Search m => DB m where + mapDepthDB :: (Bag (a,Int) -> Bag (b,Int)) -> m a -> m b + zipDepthDB :: (Int -> Bag (a,Int) -> Bag (b,Int)) -> m a -> m b -mapDepthDB :: (Bag (a,Int) -> Bag (b,Int)) -> DBound a -> DBound b -mapDepthDB f (DB g) = DB (f.g) +instance DB DBound where + mapDepthDB f (DB g) = DB (f.g) + zipDepthDB f (DB g) = DB (\d -> f d (g d)) +instance (Functor m, Monad m) => DB (DBoundT m) where + mapDepthDB f (DBT g) = DBT $ fmap f . g + zipDepthDB f (DBT g) = DBT $ \d -> fmap (f d) (g d) + zipDepthMx :: (Int -> Bag a -> Bag b) -> Matrix a -> Matrix b zipDepthMx f (Mx xss) = Mx (zipWith f [0..] xss) zipDepthRc :: (Int -> Bag a -> Bag b) -> Recomp a -> Recomp b zipDepthRc f (Rc g) = Rc (\d -> f d (g d)) --- $B8+3]$1>e$N?<$5$r;H$& Bag (a,Int) -> Bag (b,Int)) -> DBound a -> DBound b -zipDepthDB f (DB g) = DB (\d -> f d (g d)) - zipDepth3Mx :: (Int -> Bag a -> Bag b -> Bag c) -> Matrix a -> Matrix b -> Matrix c zipDepth3Mx f (Mx xss) (Mx yss) = Mx (zipWith3 f [0..] xss yss) @@ -352,17 +358,30 @@ swap (b,x) = (x,b) -newtype DBound a = DB {unDB :: Int -> Bag (a, Int)} +newtype DBound a = DB {unDB :: Int -> Bag (a, Int)} +newtype DBoundT m a = DBT {unDBT :: Int -> m (Bag (a, Int))} instance Monad DBound where return x = DB $ \n -> [(x,n)] DB p >>= f = DB $ \n -> [ (y,s) | (x,r) <- p n, (y,s) <- unDB (f x) r ] +instance Monad m => Monad (DBoundT m) where + return x = DBT $ \n -> return [(x,n)] + DBT p >>= f = DBT $ \n -> do ts <- p n + tss <- mapM (\(x,r) -> unDBT (f x) r) ts + return $ concat tss instance MonadPlus DBound where mzero = DB $ \_ -> [] DB p1 `mplus` DB p2 = DB $ \n -> p1 n ++ p2 n +instance Monad m => MonadPlus (DBoundT m) where + mzero = DBT $ \_ -> return [] + DBT p1 `mplus` DBT p2 = DBT $ \n -> liftM2 (++) (p1 n) (p2 n) instance Delay DBound where delay (DB p) = DB $ \n -> case n of 0 -> [] n -> p (n-1) ndelay i (DB p) = DB $ \n -> if n Delay (DBoundT m) where + delay (DBT p) = DBT $ \n -> case n of 0 -> return [] + n -> p (n-1) + ndelay i (DBT p) = DBT $ \n -> if n [ x | (x,0) <- p n ] fromRc (Rc p) = DB $ \n -> [ (x,n-m) | m <- [0..n], x <- p m ] @@ -378,6 +397,24 @@ (\ (k,i) (l,j) -> case compare j i of EQ -> rel k l -- Cheaper Int comparison is done in advance. c -> c)) -- Shallower elements come earlier. ifDepth pred (DB t) (DB f) = DB fun + where fun depth | pred depth = t depth + | otherwise = f depth + +dbtToRcT (DBT p) = RcT $ \n -> do t <- p n + return [ x | (x,0) <- t ] + +instance (Functor m, Monad m) => Search (DBoundT m) where + toRc = error "No toRc for DBoundT." + fromRc (Rc p) = DBT $ \n -> return [ (x,n-m) | m <- [0..n], x <- p m ] + + toMx = error "No toMx for DBoundT" + fromMx (Mx xss) = DBT $ \n -> return $ concat $ zipWith (\r xs -> map (\x->(x,r)) xs) [n,n-1..0] xss + fromDB (DB p) = DBT $ \n -> return $ p n + fromDF xs = DBT $ \n -> return [ (x,n) | x <- xs ] + toDF = error "No toDF for DBoundT" + mapDepth f (DBT g) = DBT $ \d -> g d >>= \gd -> case unzip $ gd of (xs, is) -> return $ zip (f xs) is + catBags (DBT f) = DBT (\d -> f d >>= \fd -> return [ (x,i) | (xs,i) <- fd, x <- xs ]) + ifDepth pred (DBT t) (DBT f) = DBT fun where fun depth | pred depth = t depth | otherwise = f depth #ifdef QUICKCHECK diff --git a/MagicHaskeller.cabal b/MagicHaskeller.cabal --- a/MagicHaskeller.cabal +++ b/MagicHaskeller.cabal @@ -1,5 +1,5 @@ Name: MagicHaskeller -Version: 0.8.6.3 +Version: 0.9.1 Cabal-Version: >= 1.2 License: BSD3 License-file: LICENSE @@ -32,9 +32,9 @@ -- Flag Benchmark Library - Build-depends: template-haskell, base >= 4 && < 5, syb, containers, array, random, directory, bytestring, mtl + Build-depends: old-time, template-haskell, base >= 4 && < 5, syb, containers, array, random, directory, bytestring, mtl, html, network, pretty Exposed-modules: MagicHaskeller, Control.Monad.Search.Combinatorial, Control.Monad.Search.Best, MagicHaskeller.ProgGen, MagicHaskeller.ProgGenSF, - MagicHaskeller.Expression, MagicHaskeller.LibTH, MagicHaskeller.Analytical, MagicHaskeller.Options, MagicHaskeller.Classification, MagicHaskeller.GetTime + MagicHaskeller.Expression, MagicHaskeller.LibTH, MagicHaskeller.Analytical, MagicHaskeller.Options, MagicHaskeller.Classification, MagicHaskeller.GetTime, MagicHaskeller.Minimal, MagicHaskeller.IOGenerator Other-modules: MagicHaskeller.MemoToFiles, MagicHaskeller.ShortString, MagicHaskeller.Types, MagicHaskeller.PriorSubsts, Data.Memo, MagicHaskeller.ClassifyTr, MagicHaskeller.CoreLang, MagicHaskeller.DebMT, MagicHaskeller.TyConLib, @@ -43,13 +43,14 @@ MagicHaskeller.Instantiate, MagicHaskeller.Classify, MagicHaskeller.MHTH, MagicHaskeller.MyCheck, MagicHaskeller.ExprStaged, MagicHaskeller.Combinators, MagicHaskeller.ReadDynamic, MagicHaskeller.MyDynamic, MagicHaskeller.ClassifyDM, MagicHaskeller.ProgramGenerator, MagicHaskeller.Analytical.FMExpr, - MagicHaskeller.Analytical.Parser, MagicHaskeller.Analytical.Syntax, MagicHaskeller.Analytical.UniT, MagicHaskeller.Analytical.Synthesize + MagicHaskeller.Analytical.Parser, MagicHaskeller.Analytical.Syntax, MagicHaskeller.Analytical.UniT, MagicHaskeller.Analytical.Synthesize, + MagicHaskeller.ExpToHtml Extensions: CPP, TemplateHaskell GHC-options: -O2 -fvia-C cpp-options: -DCHTO if flag(GHCAPI) && !os(windows) - Build-depends: ghc >= 6.10, old-time, ghc-paths + Build-depends: ghc >= 6.10, ghc-paths Exposed-modules: MagicHaskeller.RunAnalytical, MagicHaskeller.ExecuteAPI610 if flag(READFILE) diff --git a/MagicHaskeller.lhs b/MagicHaskeller.lhs --- a/MagicHaskeller.lhs +++ b/MagicHaskeller.lhs @@ -48,7 +48,14 @@ mkPG075, mkMemo075, -- | 'mkPGOpt' can be used along with its friends instead of 'mkPG' when the search should be fine-tuned. - mkPGOpt, Options, Opt(..), options, MemoType(..), + 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, + + Options, Opt(..), options, MemoType(..), #ifdef HASKELLSRC -- *** Alternative way to create your program generator algorithm @@ -91,7 +98,7 @@ -- ** 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, + filterFirst, filterFirstF, filterThen, filterThenF, fp, -- ** Expression generators -- | These functions generate all the expressions that have the type you provide. @@ -128,6 +135,8 @@ import MagicHaskeller.Types as Types +import MagicHaskeller.T10(mergesortWithBy) + import MagicHaskeller.ProgGen(ProgGen(PG)) import MagicHaskeller.ProgGenSF(ProgGenSF, PGSF) -- import MagicHaskeller.ProgGenLF(ProgGenLF) @@ -247,20 +256,35 @@ -- 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 +primitivesp :: TyConLib -> [[Primitive]] -> [[Typed [CoreExpr]]] +primitivesp tcl pss + = let ixs = scanl (+) 0 $ map length pss + in zipWith (\ix -> mergesortWithBy (\(x:::t) (y:::_) -> (x++y):::t) (\(_:::t) (_:::u) -> compare t u) . + zipWith (\ n (_,e,ty) -> [Primitive n $ expIsAConstr 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 + + mkPG :: ProgramGenerator pg => [Primitive] -> pg -mkPG = mkPG' True +mkPG = mkPGX . (:[]) +mkPGX :: ProgramGenerator pg => [[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' cont tups = case mkCommon options{contain=cont} tups of cmn -> mkTrie cmn (primitivesp (tcl cmn) tups) +mkMemo = mkPG' False . (:[]) +mkPG' :: ProgramGenerator pg => Bool -> [[Primitive]] -> pg +mkPG' cont tups = case mkCommon options{contain=cont} $ concat 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: @@ -275,7 +299,7 @@ -> [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 +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 @@ -284,7 +308,9 @@ 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) +mkPGOpt opt = mkPGXOpt opt . (:[]) +mkPGXOpt :: ProgramGenerator pg => Options -> [[Primitive]] -> pg +mkPGXOpt opt prims = case mkCommon opt $ concat prims of cmn -> mkTrieOpt cmn (primitivesp (tcl cmn) primsOpt) (primitivesp (tcl cmn) prims) where primsOpt = case primopt opt of Nothing -> prims Just po -> po @@ -525,11 +551,12 @@ filterThen :: Typeable a => (a->Bool) -> Every a -> IO (Every a) filterThen pred ts = do md <- readIORef refmemodeb let mpto = timeout $ opt $ extractCommon md - return (map (fp mpto) ts) - where fp _ [] = [] - fp mpto (ea@(e,a):ts) = case unsafePerformIO (maybeWithTO seq mpto (return (pred a))) of - Just True -> ea : fp mpto ts - _ -> fp mpto ts + return (map (fp mpto pred) ts) +fp :: Typeable a => Maybe Int -> (a->Bool) -> [(Exp, a)] -> [(Exp, a)] +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 -- | @io2pred@ converts a specification given as a set of I/O pairs to the predicate form which other functions accept. diff --git a/MagicHaskeller/Analytical/Synthesize.hs b/MagicHaskeller/Analytical/Synthesize.hs --- a/MagicHaskeller/Analytical/Synthesize.hs +++ b/MagicHaskeller/Analytical/Synthesize.hs @@ -231,7 +231,7 @@ in case [ output iop | iop <- iops ] of outs@(C _ (cid Types.::: cty) flds : rest) - | all (`sConstrIs` cid) rest -> return (foldl (:$) (Primitive cid), + | all (`sConstrIs` cid) rest -> return (foldl (:$) (Primitive cid True), zipWith (\iops retty -> setIOPairs iops fun Types.::: Types.popArgs argtys retty) (transpose [ divideIOP iop | iop <- iops ]) (case Types.revSplitArgs cty of (_,fieldtys,_) -> fieldtys), diff --git a/MagicHaskeller/Classification.hs b/MagicHaskeller/Classification.hs --- a/MagicHaskeller/Classification.hs +++ b/MagicHaskeller/Classification.hs @@ -251,6 +251,7 @@ Int -> ([k],e) -> ([k],e) -> r liftRelation rel len (xs,_) (ys,_) = liftRel rel len xs ys liftRel _ 0 _ _ = cEQ +liftRel _ _ [] [] = cEQ liftRel rel len (x:xs) (y:ys) = case rel x y of c | c == cEQ -> liftRel rel (len-1) xs ys diff --git a/MagicHaskeller/Classify.hs b/MagicHaskeller/Classify.hs --- a/MagicHaskeller/Classify.hs +++ b/MagicHaskeller/Classify.hs @@ -1,12 +1,12 @@ -- -- (c) Susumu Katayama -- -{-# OPTIONS -XMagicHash -cpp #-} +{-# LANGUAGE MagicHash, CPP #-} module MagicHaskeller.Classify(randomTestFilter, filterBF, filterRc, filterDB -- , filterDBPos , ofilterDB, opreexecute, CmpBot, cmpBot -- used by ClassifyDM.hs , diffSortedBy, diffSortedByBot, FiltrableBF ) where - +#define CHTO import Control.Monad.Search.Combinatorial -- import Types(Subst) -- Subst¤Ëspecialize¤¹¤ëɬÍפϤʤ¤¤±¤É¡¥ import Data.Maybe @@ -139,6 +139,7 @@ liftCmp :: Int -> (a->a->Ordering) -> [a] -> [a] -> Ordering -- liftCmp len cmp xs ys = fromMaybe (error "liftCmp") $ liftCmpBot len cmp xs ys liftCmp 0 cmp xs ys = EQ +liftCmp _ _ [] [] = EQ liftCmp len cmp (x:xs) (y:ys) = trace "liftCmp" $ case cmp x y of EQ -> trace "just eq" $ diff --git a/MagicHaskeller/ClassifyDM.hs b/MagicHaskeller/ClassifyDM.hs --- a/MagicHaskeller/ClassifyDM.hs +++ b/MagicHaskeller/ClassifyDM.hs @@ -1,6 +1,8 @@ -- -- (c) Susumu Katayama -- +{-# LANGUAGE CPP #-} +#define CHTO module MagicHaskeller.ClassifyDM(filterDM, filterList, filterListDB, filterDMlite, spreexecuteDM) where -- , filterDMTI) where import Control.Monad.Search.Combinatorial @@ -55,7 +57,7 @@ filterListDB cmn typ aes = DB $ \db -> [(filterList cmn typ db aes,db)] -filterDM :: Common -> Type -> DBound AnnExpr -> DBound AnnExpr +filterDM :: DB m => Common -> Type -> m AnnExpr -> m AnnExpr filterDM cmn typ = case typeToRandomsOrdDM (nrands $ opt cmn) (tcl cmn) (rt cmn) typ of Nothing -> id @@ -81,7 +83,8 @@ map (\(ae,i) -> (sprDM (uncurryDyn (mkUncurry $ tcl cmn) typ) rndss ae i {- i, not d-}, i))) listCmp :: Int -> (a->a->Ordering) -> [a] -> [a] -> Ordering -listCmp 0 cmp _ _ = EQ +listCmp 0 cmp _ _ = EQ +listCmp n cmp [] [] = EQ listCmp n cmp (x:xs) (y:ys) = case cmp x y of EQ -> listCmp (n-1) cmp xs ys c -> c diff --git a/MagicHaskeller/Combinators.hs b/MagicHaskeller/Combinators.hs --- a/MagicHaskeller/Combinators.hs +++ b/MagicHaskeller/Combinators.hs @@ -1,6 +1,7 @@ -- -- (c) Susumu Katayama -- +{-# LANGUAGE TemplateHaskell #-} module MagicHaskeller.Combinators where import MagicHaskeller.ExprStaged import Language.Haskell.TH diff --git a/MagicHaskeller/CoreLang.lhs b/MagicHaskeller/CoreLang.lhs --- a/MagicHaskeller/CoreLang.lhs +++ b/MagicHaskeller/CoreLang.lhs @@ -6,7 +6,7 @@ (This looks like Bindging.hs....) \begin{code} -{-# OPTIONS -cpp -XExistentialQuantification -XRankNTypes #-} +{-# LANGUAGE CPP, ExistentialQuantification, RankNTypes, TemplateHaskell #-} -- workaround Haddock invoked from Cabal unnecessarily chasing imports. (If cpp fails, haddock ignores the remaining part of the module.) #ifndef __GLASGOW_HASKELL__ -- x #hoge @@ -42,7 +42,8 @@ | Lambda CoreExpr | X Int -- de Bruijn notation | FunLambda CoreExpr | FunX Int -- different system of de Bruijn notation for functions, used by IOPairs.hs | Tuple Int - | Primitive Int + | Primitive Int + Bool -- True if the primitive is a constructor expression | CoreExpr :$ CoreExpr | Case CoreExpr [(Int,Int,CoreExpr)] -- the case expression. [(primitive ID of the constructor, arity of the constructor, rhs of ->)] | Fix CoreExpr Int [Int] -- Fix expr n is === foldl (:$) (Y :$ FunLambda (napply n Lambda expr)) (map X is) @@ -58,7 +59,7 @@ rnf (Lambda e) = rnf e rnf (X i) = rnf i rnf (Tuple i) = rnf i - rnf (Primitive _) = () -- ºÇ¸å¤Î¥Ñ¥¿¡¼¥ó¤Ë¥Þ¥Ã¥Á¤¹¤ë¤Î¤Ç¤³¤ì¤ÏÍפé¤Ê¤«¤Ã¤¿¤«¡¥ + rnf (Primitive _ _) = () -- ºÇ¸å¤Î¥Ñ¥¿¡¼¥ó¤Ë¥Þ¥Ã¥Á¤¹¤ë¤Î¤Ç¤³¤ì¤ÏÍפé¤Ê¤«¤Ã¤¿¤«¡¥ rnf (c :$ d) = rnf c `seq` rnf d rnf e = () #endif @@ -67,7 +68,7 @@ ceToInteger (Lambda e) = ceToInteger e -- ·¿¤¬ÊѤï¤Ã¤Á¤ã¤¦¤Î¤ÇLambda¤Ï̵»ë¤Ç¤­¤ë¤Ï¤º¡¥... ¤È¤¤¤¤¤Ä¤Ä¼«¿®Ìµ¡¥July 24, 2008¤Înotes¤ò»²¾È. ¤Þ¡¤hash¤Ë¤Ï»È¤¨¤ë¤È¤¤¤¦ÄøÅ٤ΤĤâ¤ê¡¥ ceToInteger (f :$ e) = 3 * (ceToInteger f `interleave` ceToInteger e) ceToInteger (X n) = 3 * toInteger n + 1 -ceToInteger (Primitive n) = 3 * toInteger n + 2 +ceToInteger (Primitive n _) = 3 * toInteger n + 2 0 `interleave` 0 = 0 i `interleave` j = (j `interleave` (i `shiftR` 1)) * 2 + (i `mod` 2) @@ -79,7 +80,7 @@ fromEnum (Lambda e) = fromIntegral prime * fromEnum e -- ·¿¤¬ÊѤï¤Ã¤Á¤ã¤¦¤Î¤ÇLambda¤Ï̵»ë¤Ç¤­¤ë¤Ï¤º¡¥... ¤È¤¤¤¤¤Ä¤Ä¼«¿®Ìµ¡¥July 24, 2008¤Înotes¤ò»²¾È. ¤Þ¡¤hash¤Ë¤Ï»È¤¨¤ë¤È¤¤¤¦ÄøÅ٤ΤĤâ¤ê¡¥ fromEnum (f :$ e) = fromEnum f #* fromEnum e fromEnum (X n) = n * 0xdeadbeef - fromEnum (Primitive n) = (-1-n) * 0xdeadbeef + fromEnum (Primitive n _) = (-1-n) * 0xdeadbeef m #* c = fromIntegral (hashInt m) + (c `mod` fromIntegral prime) instance Ord Exp where @@ -122,10 +123,10 @@ x2hsx dep fdep (X n) = VarE (mkName [chr (dep - n)]) -- X n¤ÏX 0, X 1, .... x2hsx dep fdep (FunX n) = VarE (mkName ['f',chr (fdep - n)]) -- X n¤ÏX 0, X 1, .... -- x2hsx _ (Qualified con) = VarE (mkName (pl ! con)) - x2hsx _ _ (Primitive n) = case PD.dynExp (vl ! n) of ConE name -> ConE $ mkName $ nameBase name + x2hsx _ _ (Primitive n _) = case PD.dynExp (vl ! n) of ConE name -> ConE $ mkName $ nameBase name VarE name -> VarE $ mkName $ nameBase name e -> e - x2hsx dep fdep (Primitive n :$ e0 :$ e1) + x2hsx dep fdep (Primitive n _ :$ e0 :$ e1) = let hsx0 = x2hsx dep fdep e0 hsx1 = x2hsx dep fdep e1 in case PD.dynExp (vl!n) of diff --git a/MagicHaskeller/Execute.hs b/MagicHaskeller/Execute.hs --- a/MagicHaskeller/Execute.hs +++ b/MagicHaskeller/Execute.hs @@ -1,7 +1,7 @@ -- -- (c) Susumu Katayama -- -{-# OPTIONS -XMagicHash #-} +{-# LANGUAGE MagicHash, TemplateHaskell #-} module MagicHaskeller.Execute(unsafeExecute, unDeBruijn) where import System.IO.Unsafe(unsafeInterleaveIO) import MagicHaskeller.CoreLang @@ -55,7 +55,7 @@ unsafeExecute :: VarLib -> CoreExpr -> Dynamic unsafeExecute vl e = exe (unDeBruijn e) where exe (e0 :$ e1) = dynAppErr "apply" (exe e0) (exe e1) - exe (Primitive n) = fromPD (vl!n) + exe (Primitive n _) = fromPD (vl!n) exe S = $(dynamic [|defaultTCL|] [| s :: (b->c->a) -> (b->c) -> b -> a |]) exe K = $(dynamic [|defaultTCL|] [| const :: a->b->a |]) exe I = $(dynamic [|defaultTCL|] [| id :: a->a |]) diff --git a/MagicHaskeller/ExecuteAPI610.hs b/MagicHaskeller/ExecuteAPI610.hs --- a/MagicHaskeller/ExecuteAPI610.hs +++ b/MagicHaskeller/ExecuteAPI610.hs @@ -9,7 +9,7 @@ import GHC.Exts import GHC.Paths(libdir) -- as instructed in http://haskell.org/haskellwiki/GHC/As_a_library import DynFlags -- (DynFlag, defaultDynFlags, PackageFlag(ExposePackage)) -- , glasgowExtsFlags) ¤Ïexport¤µ¤ì¤Æ¤¤¤Ê¤¤¤é¤·¤¤. -import SrcLoc (SrcSpan(..), noSrcSpan, noSrcLoc, interactiveSrcLoc, Located(L), noLoc) +import SrcLoc (SrcSpan(..), noSrcSpan, noSrcLoc, interactiveSrcLoc, noLoc) -- import MyCorePrep ( corePrepExpr ) import CorePrep(corePrepExpr) -- ¥³¥ó¥Ñ¥¤¥ë¤¬Ä̤é¤Ê¤¤¤Î¤Ç¥ª¥ê¥¸¥Ê¥ë¤Ë¤·¤Æ¤ß¤ë @@ -95,29 +95,35 @@ loadObj :: [String] -- ^ visible modules (including package modules). You may omit the Prelude. -> IO (CoreLang.VarLib -> CoreLang.CoreExpr -> Dynamic) -loadObj fss = fmap unsafeExecuteAPI $ prepareAPI fss +loadObj fss = fmap unsafeExecuteAPI $ prepareAPI [] fss -- Just follow http://haskell.org/haskellwiki/GHC/As_a_library -- ÌäÂê¤Ï¡¤¤¹¤Ç¤ËÆɤޤì¤Æ¤¤¤ëmodule¤Ï¤É¤¦¤¹¤ë¤«¤Ã¤Æ¤³¤È¤À¤±¤É¡¤:load¥³¥Þ¥ó¥ÉƱÍͺÆÆɤ߹þ¤ß -{- addNonPackageTarget¤Ã¤Æ¤Î¤òÄêµÁ¤·¤¿¤Î¤Ç¡¤Ê¬¤±¤ëɬÍפϤʤ¯¤Ê¤Ã¤¿¤Ï¤º¡¥ +-- addNonPackageTarget¤Ã¤Æ¤Î¤òÄêµÁ¤·¤¿¤Î¤Ç¡¤Ê¬¤±¤ëɬÍפϤʤ¯¤Ê¤Ã¤¿¤Ï¤º¡¥ prepareAPI :: [FilePath] -- ^ modules to be loaded (except package modules) -> [FilePath] -- ^ visible modules (including package modules) - -> IO Session -prepareAPI fss allfss --} + -> IO HscEnv +prepareAPI loadfss visfss +{- prepareAPI :: [String] -- ^ visible modules (including package modules). -- Supplying @[]@ here works without any problems within GHCi, and currently @prepareAPI@ does not work without --interactive, -- so this argument is actually of no use:( -> IO HscEnv prepareAPI fss +-} +#ifdef GHC7 +-- = defaultErrorHandler defaultFatalMessager defaultFlushOut $ -- This is for 7.6.1 + = defaultErrorHandler defaultLogAction $ +#else = defaultErrorHandler defaultDynFlags $ - runGhc (Just pathToGHC) $ do +#endif + runGhc (Just pathToGHC) $ do -- liftIO $ hPutStrLn stderr "setting up flags" dfs <- getSessionDynFlags -- when (flags dfs /= flags defaultDynFlags) $ error "flags are different" - let newf = dfs{opt_P = "-DTEMPLATE_HASKELL" : "-DCLASSIFY" : "-DCHTO" : opt_P dfs, -- defaultDynFlags¤Î¥½¡¼¥¹¤¬·ë¹½»²¹Í¤Ë¤Ê¤Ã¤¿¤ê¡¥ - packageFlags = [ ExposePackage "ghc", ExposePackage "old-time", ExposePackage "ghc-paths" ] + let newf = dfs{ -- opt_P = "-DTEMPLATE_HASKELL" : "-DCLASSIFY" : "-DCHTO" : opt_P dfs, -- defaultDynFlags¤Î¥½¡¼¥¹¤¬·ë¹½»²¹Í¤Ë¤Ê¤Ã¤¿¤ê¡¥ + packageFlags = [ ExposePackage "ghc", ExposePackage "old-time", ExposePackage "ghc-paths" ] -- , ExposePackage "MagicHaskeller" ] {- flags = Opt_TemplateHaskell : Opt_Cpp : -- Opt_FlexibleInstances : Opt_ExistentialQuantification : Opt_PolymorphicComponents : Opt_RelaxedPolyRec : Opt_MagicHash : @@ -130,7 +136,7 @@ -- ...°ã¤¦¡¥¤½¤Îdynamic linking¤Ç¤Ï¤Ê¤¤¡¥ -- liftIO $ hPutStrLn stderr "loading modules" -- This IS necessary. - ts <- mapM (\fs -> guessTarget fs Nothing) fss + ts <- mapM (\fs -> guessTarget fs Nothing) loadfss setTargets ts sf <- defaultCleanupHandler newf (load LoadAllTargets) case sf of Succeeded -> return () @@ -138,11 +144,15 @@ -- liftIO $ hPutStrLn stderr "setting up modules" #ifdef GHC7 - modules <- mapM (\fs -> fmap (\x -> (x,Nothing)) $ findModule (mkModuleName fs) Nothing) ("Prelude":fss) + modules <- mapM (\fs -> fmap (\x -> (x,Nothing)) $ findModule (mkModuleName fs) Nothing) ("Prelude":visfss) #else - modules <- mapM (\fs -> findModule (mkModuleName fs) Nothing) ("Prelude":fss) + modules <- mapM (\fs -> findModule (mkModuleName fs) Nothing) ("Prelude":visfss) #endif +#ifdef GHC7 + setContext [ IIDecl $ (simpleImportDecl . mkModuleName $ moduleName){GHC.ideclQualified = False} | moduleName <- "Prelude":visfss ] -- GHC 7.4 +#else setContext [] modules +#endif #ifdef PRELINK -- prelink! @@ -188,14 +198,19 @@ -- unwrapCore, unwrapCore' ¤ÎξÊý¤¬Àµ¤·¤¯Æ°¤¯¡¥unwrapCore¤Ïghc6.8¤ÇÆ°¤¤¤Æ¤¤¤¿¤Î¤ò»ý¤Ã¤Æ¤­¤¿¤â¤Î¤Ç¡¤compileExprHscMain¤ÎÊý¤ò¥³¥á¥ó¥È¥¢¥¦¥È¤·¤ÆrunCoreExpr¤Ë¤¹¤ë¤È¿§¡¹¤Ï¤·¤ç¤ëÂå¤ï¤ê¤ËÀµ¤·¤¯Æ°¤«¤Ê¤¤¡¥ -unwrapCore, unwrapCore' :: HscEnv -> CoreSyn.CoreExpr -> IO a +unwrapCore :: HscEnv -> CoreSyn.CoreExpr -> IO a unwrapCore hscEnv ce = do -- iohvs <- runCoreExpr hscEnv ce -- (removeIdInfo ce) iohvs <- unsafeCoerce# $ compileExprHscMain hscEnv ce [hv] <- iohvs return hv -unwrapCore' hscEnv ce = fmap head $ unsafeCoerce# =<< HscMain.compileExpr hscEnv (srcLocSpan interactiveSrcLoc) ce +-- unwrapCore' hscEnv ce = fmap head $ unsafeCoerce# =<< HscMain.compileExpr hscEnv (srcLocSpan interactiveSrcLoc) ce +#ifdef GHC7 +ce2b dfs pe = coreExprToBCOs dfs undefined pe +#else +ce2b dfs pe = coreExprToBCOs dfs pe +#endif runCoreExpr, runPrepedCoreExpr :: HscEnv -> CoreExpr -> IO a runCoreExpr hscEnv ce @@ -205,7 +220,7 @@ pe <- corePrepExpr dfs ce -- runPrepedCoreExpr¤È¤Î°ã¤¤¤Ï¤³¤ÎcorePrepExpr¤¬¤¢¤ë¤«¤É¤¦¤«¤À¤± bcos <- -- repeatIO 10 $ - coreExprToBCOs dfs pe + ce2b dfs pe #ifdef PRELINK hv <- linkTheExpr bcos @@ -219,7 +234,7 @@ do let dfs = hsc_dflags hscEnv - bcos <- coreExprToBCOs dfs ce + bcos <- ce2b dfs ce -- repeatIO 10 $ #ifdef PRELINK hv <- linkTheExpr bcos @@ -245,14 +260,19 @@ (tcmsgs, mbtc) <- tcRnStmt hscEnv icxt pst case mbtc of Nothing -> perror dfs tcmsgs Just (ids, tc_expr) -> do -- desugar +#ifdef GHC7 + let typeEnv = mkTypeEnv (ic_tythings icxt) +#else let typeEnv = mkTypeEnv (map AnId (ic_tmp_ids icxt)) +#endif (desmsgs, mbds) <- deSugarExpr hscEnv iNTERACTIVE (ic_rn_gbl_env icxt) typeEnv tc_expr case mbds of Nothing -> perror dfs desmsgs Just ds -> return (Just (ids, ds)) +#ifdef GHC7 +perror dfs (wmsg,emsg) = let sdocs = pprErrMsgBag wmsg ++ pprErrMsgBag emsg in mapM_ (printError noSrcSpan) sdocs >> return Nothing +#else perror dfs msg = printErrorsAndWarnings dfs msg >> return Nothing - -unwrapLStmt (L _ (LetStmt (HsValBinds (ValBindsIn bg _)))) = unL $ head $ bagToList bg -unL (L _ x) = x +#endif thExpToStmt :: TH.Exp -> HsExpr.LStmt RdrName.RdrName thExpToStmt = wrapLHsExpr . thExpToLHsExpr @@ -272,7 +292,7 @@ showsPrec _ (Let bs e) = ("let"++) . shows bs . (" in "++) . shows e showsPrec _ (Case _ _ _ _) = ("case"++) showsPrec _ (Cast e t) = ("Cast "++) . showParen True (shows e) . (""++) - showsPrec _ (Note _ _) = ("Note"++) +-- showsPrec _ (Note _ _) = ("Note"++) showsPrec _ (Type t) = (showSDoc (pprType t) ++) instance Show b => Show (Bind b) where showsPrec _ (NonRec b e) = (' ':) . shows b . (" = "++) . shows e @@ -300,7 +320,7 @@ = do let dflags = hsc_dflags hscEnv smpl <- simplifyExpr dflags ce prep <- corePrepExpr dflags smpl - bcos <- coreExprToBCOs dflags prep + bcos <- ce2b dflags prep linkExpr hscEnv noSrcSpan bcos #ifdef GHC6 @@ -310,7 +330,7 @@ -> IO (CoreLang.CoreExpr -> Dynamic) directLoadObj fss tups = defaultErrorHandler defaultDynFlags $ do - hscEnv <- prepareAPI fss + hscEnv <- prepareAPI [] fss #ifdef PRELINK hPutStrLn stderr "prelink! (temporarily)" @@ -415,7 +435,7 @@ ceToCSCE ga ce = ctc (ord 'a'-1) ce where ctc dep (CoreLang.Lambda e) = CoreSyn.Lam (mkIntVar (dep+1)) $ ctc (dep+1) e ctc dep (CoreLang.X n) = CoreSyn.Var $ mkIntVar (dep-n) - ctc dep (CoreLang.Primitive n) = ga ! n + ctc dep (CoreLang.Primitive n _) = ga ! n ctc dep (e0 CoreLang.:$ e1) = ctc dep e0 `CoreSyn.App` ctc dep e1 @@ -520,7 +540,7 @@ Let b e == Let c f = {- b==c && -} e==f Case e b t ab == Case f c u bc = e==f {- && b==c && t==u && ab == bc -} Cast e c == Cast f d = e==f {- && c==d -} - Note n e == Note m f = {- n==m && -} e==f +-- Note n e == Note m f = {- n==m && -} e==f Type t == Type u = True -- t==u diff --git a/MagicHaskeller/ExpToHtml.hs b/MagicHaskeller/ExpToHtml.hs new file mode 100644 --- /dev/null +++ b/MagicHaskeller/ExpToHtml.hs @@ -0,0 +1,101 @@ +module MagicHaskeller.ExpToHtml(expSigToString, refer, pprnn, annotateFree) where +import Language.Haskell.TH as TH +import Language.Haskell.TH.PprLib(to_HPJ_Doc) +import Text.PrettyPrint +import Network.URI(escapeURIString, isUnreserved) +import Text.Html(stringToHtmlString) +import MagicHaskeller.LibTH(fromPrelude, fromDataList, fromDataChar, fromDataMaybe, Primitive) +import Data.Char(isAlpha, ord) +import qualified Data.Map +import Data.Generics + +expToString :: Exp -> String +-- expToString = ('\n':) . pprint +-- expToString = (\xs -> '(':xs++")
") . {- replaceRightArrow . -} pprint . annotateEverywhere -- simple and stupid +expToString = (\xs -> '(':xs++")
") . filter (/='\n') . {- replaceRightArrow . -} pprint . annotateFree [] -- no buttons +expSigToString predStr sig expr + = mkButton predStr sig expr (pprnn (annotateFree [] expr)) -- with buttons + +pprnn = renderStyle style{mode=OneLineMode} . to_HPJ_Doc . pprExp 4 + +isAbsent :: TH.Exp -> Bool +isAbsent (LamE pats e) = any (==WildP) pats || isAbsent e +isAbsent (VarE name) = nameBase name == "const" +isAbsent _ = False + +-- どうも ->をescapeする必要はないみたい．ま，<->みたいな演算子はescapeされているはずだし，みたいなコメントはないはずなので，→で置き換えても害はなさそう． +-- と思ったけど，コピペするのに不便． +replaceRightArrow "" = "" +replaceRightArrow ('-':'>':xs) = "→"++replaceRightArrow xs +replaceRightArrow (x:xs) = x : replaceRightArrow xs + + +-- Unfortunately, w3m does not understand "++body ++ "
" +mkButton predStr sig expr body = "   "++body++"" +--
でやる場合、
をつけると改行しすぎ。 + + +escapeQuote '\'' = "'" +escapeQuote c = [c] + +annotateEverywhere = everywhere (mkT annotateName) + +annotateFree :: [String] -> TH.Exp -> TH.Exp +annotateFree names v@(VarE name) | show name `elem` names = v + | otherwise = VarE $ annotateName name +annotateFree _ (ConE name) = ConE $ annotateName name +annotateFree _ l@(LitE _) = l +annotateFree names (AppE f e) = annotateFree names f `AppE` annotateFree names e +annotateFree names (InfixE mbf op mbe) = InfixE (fmap (annotateFree names) mbf) (annotateFree names op) (fmap (annotateFree names) mbe) +annotateFree names (LamE pats e) = LamE pats $ annotateFree (patsToNames pats names) e +annotateFree names (TupE es) = TupE $ map (annotateFree names) es +annotateFree names (CondE b t f) = CondE (annotateFree names b) (annotateFree names t) (annotateFree names f) +annotateFree names (ListE es) = ListE $ map (annotateFree names) es +annotateFree names (SigE e t) = SigE (annotateFree names e) t +annotateFree names e = annotateEverywhere e -- bothered.... + +patsToNames [] = id +patsToNames (p:ps) = patToNames p . patsToNames ps +patToNames (VarP name) = (show name :) +patToNames (TupP ps) = patsToNames ps +patToNames (ConP _ ps) = patsToNames ps +patToNames (InfixP p _ q) = patsToNames [p,q] +patToNames (TildeP p) = patToNames p +patToNames (AsP name p) = (show name :) . patToNames p +patToNames (ListP ps) = patsToNames ps +patToNames (SigP p _) = patToNames p +patToNames _ = id + + +-- 名前の1文字目が記号だとbinary operator扱いになってカッコがついてしまうので． +annotateName :: TH.Name -> TH.Name +annotateName name = case nameBase name of nameStr@(c:cs) | isAlpha c -> mkName $ c : refLink nameStr cs + | c `elem` "=+!@#$%^&*-\\|:/?<>.~" -> mkName $ refLink nameStr $ stringToHtmlString nameStr + _ -> name -- special names like [] and () +refLink nameStr body = "" ++ body ++ "" +refer str = case Data.Map.lookup str mapNameModule of Nothing -> referHoogle str + Just f -> f str +mapNameModule :: Data.Map.Map String (String->String) +mapNameModule = Data.Map.fromList $ + mkAssoc "base" "Prelude" preludeNameBases ++ + mkAssoc "base" "Data-List" (primssToStrs fromDataList) ++ + mkAssoc "base" "Data-Char" (primssToStrs fromDataChar) ++ + mkAssoc "base" "Data-Maybe" (primssToStrs fromDataMaybe) +mkAssoc package mod namebases = [ (str, referHackage package mod) | str <- namebases ] + +preludeNameBases = ["iterate", "!!", "id", "$", "const", ".", "flip", "subtract", "maybe", "foldr", "zipWith"] ++ -- These are not included in the component library, but introduced by MagicHaskeller.LibTH.postprocess. + primssToStrs fromPrelude + +primssToStrs = map TH.nameBase . primsToNames . concat +primsToNames :: [Primitive] -> [TH.Name] +primsToNames ps = [ name | (_, VarE name, _) <- ps ] ++ [ name | (_, ConE name, _) <- ps ] + ++ [ name | (_, _ `AppE` VarE name, _) <- ps ] -- ad hoc approach to the (flip foo) cases:) + +-- So far this should work: +referHackage package modulename str = "http://hackage.haskell.org/packages/archive/"++package++"/latest/doc/html/"++modulename++".html#v:"++hackageEncode str +hackageEncode cs@(a:_) | isAlpha a = cs + | otherwise = concatMap (\c -> '-' : shows (ord c) "-") cs + +-- But this is more generic:) +referHoogle str = "http://www.haskell.org/hoogle/?hoogle=" ++ escapeURIString isUnreserved str diff --git a/MagicHaskeller/ExprStaged.hs b/MagicHaskeller/ExprStaged.hs --- a/MagicHaskeller/ExprStaged.hs +++ b/MagicHaskeller/ExprStaged.hs @@ -1,7 +1,7 @@ -- -- (c) Susumu Katayama -- -{-# OPTIONS -O -fglasgow-exts #-} +{-# LANGUAGE MagicHash, TemplateHaskell #-} module MagicHaskeller.ExprStaged where import MagicHaskeller.CoreLang import MagicHaskeller.MyDynamic diff --git a/MagicHaskeller/Expression.hs b/MagicHaskeller/Expression.hs --- a/MagicHaskeller/Expression.hs +++ b/MagicHaskeller/Expression.hs @@ -23,6 +23,8 @@ import qualified Data.Set as S import qualified Data.IntMap as IM +import Data.List(sortBy) + -- AnnExpr remembers each Dynamic corresponding to the CoreExpr. data AnnExpr = AE CoreExpr Dynamic deriving Show instance Eq AnnExpr where @@ -47,8 +49,9 @@ meToAE (ME ce _ f) = AE ce f class (Ord e, Show e) => Expression e where - fromCE :: (CoreExpr->Dynamic) -> Int -> Int -> CoreExpr -> e -- $B$3$NL>A0$O8m2r$r>7$/$+$b!%(BmkHead$B$H$+$=$s$JL>A0$K$9$k(B? + mkHead :: (CoreExpr->Dynamic) -> Int -> Int -> CoreExpr -> e toCE :: e -> CoreExpr + fromCE :: (CoreExpr -> Dynamic) -> CoreExpr -> e mapCE :: (CoreExpr -> CoreExpr) -> e -> e -- $B$3$l$bJQ!%(B (<$>) :: e -> e -> e appEnv :: Int -> e -> e -> e @@ -58,9 +61,16 @@ fromAnnExpr :: AnnExpr -> e reorganize :: Monad m => ([Type] -> m [e]) -> [Type] -> m [e] reorganizeId :: ([Type] -> [e]) -> [Type] -> [e] -- reorganize for Id monad + replaceVars' :: Int -> e -> [Int] -> e -- @replaceVars@ without uniq + reorganizeId' :: (Functor m) => ([Type] -> m e) -> [Type] -> m e + reorganizeId' fun avail = case cvtAvails' avail of + (args, newavail) -> + fmap (\e -> replaceVars' 0 e args) $ fun newavail + instance Expression CoreExpr where - fromCE _ _ _ = id + mkHead _ _ _ = id toCE = id + fromCE _ = id mapCE = id (<$>) = (:$) appEnv _ = (:$) @@ -70,10 +80,12 @@ fromAnnExpr (AE ce _) = ce reorganize = reorganizer reorganizeId = reorganizerId + replaceVars' = replaceVarsCE' instance Expression AnnExpr where - fromCE _ lenavails arity ce@(X i) = AE ce (getDyn_LambdaBoundHead i lenavails arity) -- Note that 'dynss' and 'dynsss' uses - fromCE reduce lenavails arity ce = AE ce ((getDyn lenavails arity) `dynApp` reduce ce) -- 'unsafeExecute' instead of 'reduce'. + mkHead _ lenavails arity ce@(X i) = AE ce (getDyn_LambdaBoundHead i lenavails arity) -- Note that 'dynss' and 'dynsss' uses + mkHead reduce lenavails arity ce = AE ce ((getDyn lenavails arity) `dynApp` reduce ce) -- 'unsafeExecute' instead of 'reduce'. toCE (AE ce _) = ce + fromCE = toAnnExpr mapCE f (AE ce d) = AE (f ce) d AE e1 h1 <$> AE e2 h2 = AE (e1:$e2) (dynApp h1 h2) appEnv lenavails (AE e1 h1) (AE e2 h2) = AE (e1:$e2) (dynApp (dynApp (dynSn lenavails) h1) h2) @@ -83,6 +95,8 @@ fromAnnExpr = id reorganize = id reorganizeId = id + reorganizeId' = id -- Well, this is overridden to id because replaceVars' for AnnExpr is not yet implemented. + -- $B$F$JLu$G!% CoreExpr -> CoreExpr windType (a:->b) e = Lambda (windType b e) windType _ e = e @@ -185,25 +199,52 @@ -} + + +-- @reorganize@ without uniq +reorganize' :: Monad m => ([Type] -> m [CoreExpr]) -> [Type] -> m [CoreExpr] +reorganize' fun avail + = case cvtAvails' avail of + (args, newavail) -> + do agentExprs <- fun newavail + return [ replaceVars' 0 e args | e <- agentExprs ] + +replaceVarsCE' :: Int -> CoreExpr -> [Int] -> CoreExpr +replaceVarsCE' dep e@(X n) args = case args !? (n - dep) of Nothing -> e + Just m -> X (m + dep) +replaceVarsCE' dep (Lambda e) args = Lambda (replaceVarsCE' (dep+1) e args) +replaceVarsCE' dep (f :$ e) args = replaceVarsCE' dep f args :$ replaceVarsCE' dep e args +replaceVarsCE' dep e args = e + +cvtAvails' = unzip . sortBy (\(_,k) (_,l) -> compare k l) . zip [0..] + + + + + -- Moved from T10 -- uniqSorter :: (Ord e) => [(e,Int)] -> [(e,Int)] -uniqSorter, uniqSortPatAVL, annUniqSortAVL :: (Expression e) => [(e,Int)] -> [(e,Int)] -uniqSorter = annUniqSortAVL -- uniqSortPatAVL -- annUniqSort -- swapUniqSort -- id -- uniqSort -- annUniqSort +uniqSorter, uniqSortPatAVL :: (Expression e) => [(e,Int)] -> [(e,Int)] +uniqSorter = swapUniqSort -- uniqSortPatAVL -- swapUniqSort -- id -- uniqSort uniqSort, uniqSortAVL :: Ord a => [a] -> [a] uniqSort = mergesortWithBy const compare swapUniqSort :: (Ord a, Ord b) => [(a,b)] -> [(a,b)] swapUniqSort = mergesortWithBy const (\(a,b) (c,d) -> compare (b,a) (d,c)) -annUniqSort :: Expression e => [(e,Int)] -> [(e,Int)] -annUniqSort = map snd . mergesortWithBy const (\a b -> compare (fst a) (fst b)) . map (\t@(ce,_i) -> (fromEnum $ toCE ce, t)) -aUS :: Expression e => [e] -> [e] -aUS = map snd . mergesortWithBy const (\a b -> compare (fst a) (fst b)) . map (\e -> (fromEnum $ toCE e, e)) uniqSortAVL = S.toList . S.fromList -- $B$^$:$O8e$m$N(BInt$B$GJ,$1$k$N$G!$(BIntMap$B$H$N(B2$BCJ9=$((B +-- causes `Stack space overflow' error when used by SimpleServer uniqSortPatAVL ts = [ (x,j) | (j, set) <- IM.toList $ IM.fromListWith S.union $ map (\(x,i) -> (i, S.singleton x)) ts , x <- S.toList set ] +{- The hashing uniqsorters are really problematic. See newnotes on 2012/11/04 +annUniqSort :: Expression e => [(e,Int)] -> [(e,Int)] +annUniqSort = map snd . mergesortWithBy const (\a b -> compare (fst a) (fst b)) . map (\t@(ce,_i) -> (fromEnum $ toCE ce, t)) +aUS :: Expression e => [e] -> [e] +aUS = map snd . mergesortWithBy const (\a b -> compare (fst a) (fst b)) . map (\e -> (fromEnum $ toCE e, e)) +annUniqSortAVL :: (Expression e) => [(e,Int)] -> [(e,Int)] annUniqSortAVL = IM.elems . IM.fromList . map (\t@(ce,_i) -> (fromEnum $ toCE ce, t)) --- fromEnum$B2?EY$b$d$jD>$9$N$bGO$9$N$bGO [a] +arbitraries = arbs 4 (mkStdGen 1) +arbs :: Arbitrary a => Int -> StdGen -> [a] +arbs n stdgen = case split stdgen of + (g0,g1) -> f n g0 : arbs n g1 + where Gen f = arbitrary + +--showIOPairs :: IOGenerator a => String -> String -> a -> String +--showIOPairs crlf funname fun = concat $ map ((crlf ++) . (funname++)) $ generate fun +showIOPairsHTML :: IOGenerator a => String -> a -> String +showIOPairsHTML = showIOPairsHTML' (const showIOPairHTML) +showIOPairsWithFormsHTML :: IOGenerator a => + String -- ^ CGI.myPath, which is usually "/cgi-bin/MagicHaskeller.cgi" + -> String -- ^ predicate before escaping single quotes + -> String -> a -> String +showIOPairsWithFormsHTML mypath predicate + = let beginForm = " && "++) . (funname++) . shower boxSize) iopairs + where iopairs = generateIOPairs fun + boxSize = maximum $ 20 : map length (snd $ unzip iopairs) + +type AnnShowS = (Exp->Exp) -- ^ annotater + -> String -> String +showIOPairHTML (args,ret) = foldr (\arg str -> "  " ++ arg (annotateFree []) str) ("   ==    "++ret++ "  ") args + +showIOPairWithFormHTML begin boxSize pair@(args,ret) = showIOPairHTML (args, mkForm begin boxSize pair) +mkForm :: String + -> Int + -> ([AnnShowS],String) + -> String +-- predicate¤Èinputs¤Èoutput¤¬¤¢¤ì¤Ð¤è¤¤¡¥CGI¦¤Ç¤Ï¡¤ '(':predicate++") && f "++inputs++" == "++output ¤òpredicate¤È¤·¤Æ¼Â¹Ô +mkForm begin boxSize (args,ret) + = begin ++ concatMap escapeQuote (showsInputs args "") ++ "'> " +showsInputs args = \s -> foldr (\arg str -> ' ' : arg id str) s args +escapeQuote '\'' = "'" +escapeQuote c = [c] + +class IOGenerator a where +-- generate :: a -> [String] + generateIOPairs :: a -> [([AnnShowS],String)] -- list of pairs of shown arguments and shown return values +instance (IOGenerator r) => IOGenerator (Int->r) where + -- generate f = [ ' ' : showParen (a<0) (shows a) s | a <- uniqSort $ take 5 arbitraries, s <- generate (f a) ] + generateIOPairs = generateIOPairsLitNum integrals +instance (IOGenerator r) => IOGenerator (Integer->r) where + -- generate f = [ ' ' : showParen (a<0) (shows a) s | a <- uniqSort $ take 5 arbitraries, s <- generate (f a) ] + generateIOPairs = generateIOPairsLitNum integrals +instance (IOGenerator r) => IOGenerator (Float->r) where + -- generate f = [ ' ' : showParen (a<0) (shows a) s | a <- uniqSort $ take 5 arbitraries, s <- generate (f a) ] + generateIOPairs = generateIOPairsLitNum arbitraries +instance (IOGenerator r) => IOGenerator (Double->r) where + -- generate f = [ ' ' : showParen (a<0) (shows a) s | a <- uniqSort $ take 5 arbitraries, s <- generate (f a) ] + generateIOPairs = generateIOPairsLitNum arbitraries + +-- Can be used for Integer, Double, and Float, but not for Ratio and Complex. +generateIOPairsLitNum rs f = [ (const (showParen (a<0) (shows a)) : args, ret) | a <- uniqSort $ take 4 rs, (args,ret) <- generateIOPairs (f a) ] + +integrals :: Integral i => [i] +integrals = concat $ zipWith (\a b -> [a,b]) [0,-1..] [1..] + +instance (IOGenerator r) => IOGenerator (()->r) where +-- generate f = generateFun False f + generateIOPairs f = generateIOPairsFun False f +instance (IOGenerator r) => IOGenerator (Bool->r) where +-- generate f = generateFun False f + generateIOPairs f = generateIOPairsFun False f +instance (IOGenerator r) => IOGenerator (Ordering->r) where +-- generate f = generateFun False f + generateIOPairs f = generateIOPairsFun False f +instance (IOGenerator r) => IOGenerator (Char->r) where +-- generate f = generateFun False f + generateIOPairs f = [ (const (shows a) : args, ret) | a <- " \nAb."{- ++ take 0 arbitraries -}, (args,ret) <- generateIOPairs (f a) ] + +instance (IOGenerator r) => IOGenerator (String->r) where +-- generate f = generateFun False f + generateIOPairs f = [ (const (shows a) : args, ret) | a <- sortBy (compare `on` length) $ uniqSort $ "" : "12345" : "Abc\nd Ef" : take 2 arbitraries, + (args, ret) <- generateIOPairs (f a) ] +{----------------------------------------------------------------------- Do not use these in order to deal with types like [Int->Int]->Int. + -- ¤¿¤À¡¢¥³¥á¥ó¥È¥¢¥¦¥È¤¹¤ë¤È¡¢[Int]¤È¤«¤Ç¤âeverythingF¤ò»È¤¦¤¿¤á´ÊÌ󤵤ì¤Æ¤¤¤Ê¤¤·Á¤Çɽ¼¨¤µ¤ì¤Æ¤·¤Þ¤¦¤Î¤Ç¡¤Ê¬¤«¤ê¤Ë¤¯¤¯¤Ê¤Ã¤Æ¤·¤Þ¤¦¡¥Î¾Êý¤Î¥Ð¡¼¥¸¥ç¥ó¤òÍÑ°Õ¤·¤Æ¥¨¥é¡¼¤Ë¤Ê¤Ã¤¿¤é¤â¤¦°ìÊý¤Ã¤Æ¤Î¤¬¤è¤µ¤½¤¦¡£ +instance (Arbitrary a, Show a, Ord a, IOGenerator r) => IOGenerator ([a]->r) where +-- generate f = generateFun False f + generateIOPairs f = [ (shows a : args, ret) | a <- sortBy (compare `on` length) $ uniqSort $ [] : take 4 arbitraries, + (args, ret) <- generateIOPairs (f a) ] + +instance (Arbitrary a, Show a, Ord a, IOGenerator r) => IOGenerator (Maybe a -> r) where +-- generate f = generateFun False f + generateIOPairs f = generateIOPairsFun True f +instance (Arbitrary a, Show a, Ord a, Integral a, Random a, IOGenerator r) => IOGenerator (Ratio a -> r) where +-- generate f = generateFun False f + generateIOPairs f = generateIOPairsFun True f +instance (Arbitrary a, Show a, Ord a, Arbitrary b, Show b, Ord b, IOGenerator r) => IOGenerator ((a,b)->r) where +-- generate f = generateFun False f + generateIOPairs f = generateIOPairsFun False f +instance (Arbitrary a, Show a, Ord a, Arbitrary b, Show b, Ord b, Arbitrary c, Show c, Ord c, IOGenerator r) => IOGenerator ((a,b,c)->r) where +-- generate f = generateFun False f + generateIOPairs f = generateIOPairsFun False f +instance (Arbitrary a, Show a, Ord a, Arbitrary b, Show b, Ord b, IOGenerator r) => IOGenerator ((Either a b)->r) where +-- generate f = generateFun False f + generateIOPairs f = generateIOPairsFun True f +---------------------------------------------------------------------} +instance (ShowArbitrary a, IOGenerator r) => IOGenerator (a->r) where +-- generate f = generateFun True f + generateIOPairs = mhGenerateIOPairs + +mhGenerateIOPairs f = [ (astr : args, ret) + | (astr, a) <- take 5 showArbitraries, + (args, ret) <- generateIOPairs (f a) ] + +-- | 'ShowArbitrary' is a variant of 'Arbitrary' for presenting I/O example pairs. It uses everythingF for generating printable functions. +-- Here `good presentation' is more important than `good randomness'. +class ShowArbitrary a where + showArbitraries :: [(AnnShowS, a)] +sas :: (Show a) => (a->Bool) -> [a] -> [(AnnShowS, a)] +sas cond xs = [ (const $ showParen (cond x) (shows x), x) | x <- xs ] +sasNum :: (Show a, Arbitrary a, Num a, Ord a) => [(AnnShowS, a)] +sasNum = sas (<0) arbitraries +sasFalse :: (Show a) => [a] -> [(AnnShowS, a)] +sasFalse = sas (const False) +sasIntegral :: (Show a, Arbitrary a, Integral a, Ord a) => [(AnnShowS, a)] +sasIntegral = sas (<0) [0,1] ++ -- interleave [2..] [-1,-2..] + drop 2 sasNum +-- interleave xs ys = concat $ transpose [xs, ys] +instance ShowArbitrary () where + showArbitraries = repeat (const ("()"++),()) +instance ShowArbitrary Bool where + showArbitraries = sasFalse $ [False, True] ++ arbitraries +instance ShowArbitrary Int where + showArbitraries = sasIntegral +instance ShowArbitrary Integer where + showArbitraries = sasIntegral +instance ShowArbitrary Float where + showArbitraries = sasNum +instance ShowArbitrary Double where + showArbitraries = sasNum +instance ShowArbitrary Char where + showArbitraries = sasFalse $ " \nAb."++ drop 5 arbitraries +instance ShowArbitrary Ordering where + showArbitraries = sasFalse $ [LT,EQ,GT] ++ arbitraries +instance (Integral i, Random i, Show i) => ShowArbitrary (Ratio i) where + showArbitraries = sas (const True) arbitraries +instance ShowArbitrary a => ShowArbitrary (Maybe a) where + showArbitraries = (const ("Nothing"++), Nothing) : map (mapSA "Just " Just) showArbitraries +instance (ShowArbitrary a, ShowArbitrary b) => ShowArbitrary (Either a b) where + showArbitraries = zipWith3 (\b l r -> if b then mapSA "Left " Left l else mapSA "Right " Right r) arbitraries showArbitraries showArbitraries +-- ¤Û¤ó¤È¤Ï¤â¤Ã¤È¥é¥ó¥À¥à¤Ë¤¹¤Ù¤­¤Ç¤Ï¤¢¤ë¡¥2ËÜEither¤¬¤¢¤ë¾ì¹ç¡¤Æ±¤¸arbitraries::[Bool]¤ò¶¦Í­¤¹¤ë¤Î¤Ç¡¤Æ±¤¸²Õ½ê¤ÇLeft¤äRight¤Ë¤Ê¤ë¡¥ +mapSA str fun (f,x) = (\annotater -> showParen True ((str++) . f annotater), fun x) +instance (ShowArbitrary a, ShowArbitrary b) => ShowArbitrary (a, b) where + showArbitraries = zipWith (\(f1,x1) (f2,x2) -> (\annotater -> ('(':) . f1 annotater . (',':) . f2 annotater . (')':), (x1,x2))) + (skip 1 showArbitraries) + (skip 1 $ drop 1 showArbitraries) +instance (ShowArbitrary a, ShowArbitrary b, ShowArbitrary c) => ShowArbitrary (a, b, c) where + showArbitraries = zipWith3 (\(f1,x1) (f2,x2) (f3,x3) -> (\annotater -> ('(':) . f1 annotater . (',':) . f2 annotater . (',':) . f3 annotater . (')':), (x1,x2,x3))) + (skip 2 showArbitraries) + (skip 2 $ drop 1 showArbitraries) + (skip 2 $ drop 2 showArbitraries) +-- leap frog +skip n (x:xs) = x : skip n (drop n xs) +instance ShowArbitrary a => ShowArbitrary [a] where + showArbitraries = map cvt $ chopBy arbitraries showArbitraries +-- ¤Û¤ó¤È¤Ï¤â¤Ã¤È¥é¥ó¥À¥à¤Ë¤¹¤Ù¤­¤Ç¤Ï¤¢¤ë¡¥2ËÜ[a]¤¬¤¢¤ë¾ì¹ç¡¤Æ±¤¸arbitraries::[Int]¤ò¶¦Í­¤¹¤ë¤Î¤Ç¡¤Æ±¤¸²Õ½ê¤ÇƱ¤¸Ä¹¤µ¤Ë¤Ê¤ë¡¥ +chopBy :: [Int] -> [a] -> [[a]] +chopBy _ [] = [] -- everythingF¤ò»È¤Ã¤Æ¤¢¤ëÅÀ¤ÇÀÚ¤ë¸Â¤ê¡¤Í­¸Â¤Î²ÄǽÀ­¤âɬ¤º»Ä¤ë¡¥¶õ¥ê¥¹¥È¤Ç¤¢¤ë¤³¤È¤â¤¢¤ê¤¨¤ë¤Î¤Ç¡¤cycle¤·¤Æ¤â¥À¥á¡¥ +chopBy (i:is) xs | i < 0 = chopBy is xs + | otherwise = case splitAt i xs of (tk,dr) -> tk : chopBy is dr +cvt :: [(AnnShowS,a)] -> (AnnShowS, [a]) +cvt ts = case unzip ts of (fs, xs) -> (showsList fs, xs) + +showsList fs@(f:_) | head (f id "") == '\'' -- The String case is dealt with here. I use overlapping instances only conservatively. The drawback is that "" is still printed as []. + = const $ shows (map (\fun -> read $ fun id "") fs :: String) +showsList fs = \annotater -> ('[':) . foldr (.) (']':) (intersperse (',':) $ map ($ annotater) fs) + +instance (Typeable a, Typeable b) => ShowArbitrary (a->b) where + showArbitraries = map (\(e,a) -> (\annotater -> (pprnn (annotater (postprocess e)) ++) , a)) $ concat $ take 3 $ everythingF pgfull + + +-- generateFun b f = [ ' ' : showParen b (shows a) s | a <- uniqSort $ take 5 arbitraries, s <- generate (f a) ] +generateIOPairsFun b f = [ (const (showParen b (shows a)) : args, ret) + | a <- uniqSort $ take 5 arbitraries + , (args, ret) <- generateIOPairs (f a) ] + +instance Show a => IOGenerator a where +-- generate x = [" = "++show x] + generateIOPairs x = [([], show x)] + +uniqSort :: Ord a => [a] -> [a] +uniqSort = map head . group . sort diff --git a/MagicHaskeller/Instantiate.hs b/MagicHaskeller/Instantiate.hs --- a/MagicHaskeller/Instantiate.hs +++ b/MagicHaskeller/Instantiate.hs @@ -1,7 +1,7 @@ -- -- (c) Susumu Katayama -- -{-# OPTIONS -fglasgow-exts -cpp #-} +{-# LANGUAGE TemplateHaskell, RankNTypes, CPP #-} module MagicHaskeller.Instantiate(mkRandTrie, RTrie, -- arbitraries, uncurryDyn, uncurryTy, mkUncurry, typeToOrd, typeToRandomsOrd, typeToRandomsOrdDM, mkCurry, curryDyn , typeToArb -- exported just for testing Classification.tex @@ -148,16 +148,17 @@ argTypeToRandoms :: TyConLib -> CmpMap -> Maps -> Type -> Maybe [Dynamic] argTypeToRandoms tcl cmap (arbtup, coarbtup, gen, _) a = do arb <- typeToArb arbtup coarbtup a - let arbsDyn = arbitrariesByDyn tcl arb gen - case typeToCompare tcl cmap a of Nothing -> return arbsDyn - Just cmp -> return $ nubByCmp cmp arbsDyn + return $ arbitrariesByDyn tcl arb gen argTypeToRandomss :: [Int] -> TyConLib -> CmpMap -> Maps -> Type -> Maybe [[Dynamic]] argTypeToRandomss nrnds tcl cmap (arbtup, coarbtup, _, gen) a = do arb <- typeToArb arbtup coarbtup a let arbssDyn = arbitrariessByDyn nrnds tcl arb gen case typeToCompare tcl cmap a of Nothing -> return arbssDyn - Just cmp -> return $ map (nubByCmp cmp) arbssDyn + Just cmp -> return $ map (nubByCmp cmp . take 20) arbssDyn nubByCmp cmp = nubBy (\a b -> cmp a b == EQ) +-- nubByCmp¤ÏƱ¤¸Íð¿ô¤¬Æþ¤é¤Ê¤¤¤è¤¦¤Ë¤¹¤ëƯ¤­¤¬¤¢¤ë¡¥¤¿¤À¤·¡¤Bool¤Ê¤É¤Î¤è¤¦¤ËËܼÁŪ¤Ë2¼ïÎष¤«¤Ê¤¤¤â¤Î¤ËÂФ·¤ÆnubByCmp¤·¤ÆÍð¿ô¤ò5¤Ä¼è¤í¤¦¤È¤¹¤ë¤È̵¸Â¥ë¡¼¥×¤ËÆþ¤Ã¤Æ¤·¤Þ¤¦¤Î¤Ç¡¤¤½¤ì¤òÈò¤±¤ë¤¿¤á¤Ëtake 20¤òÆþ¤ì¤Æ¤¤¤ë¡¥ +-- argTypeToRandoms¤Ç¤â¤½¤ì¤ò¤·¤è¤¦¤È¤¹¤ë¤È·ë¹½¤ä¤ä¤³¤·¤¤¤³¤È¤Ë¤Ê¤ë¤Î¤Ç¡¤¤½¤Ã¤Á¤Ç¤ÏnubByCmp¤·¤Ê¤¤¤³¤È¤Ë¤¹¤ë¡¥2012/5/29¤Înewnotes»²¾È¡¥ +-- ¤Æ¤æ¡¼¤«¡¤argTypeToRandomss¤À¤±¤ÇÁ´Éô¤ä¤ì¤Ð¤¤¤¤¤ó¤À¤±¤É¡¥ type MapTC a = IntMap.IntMap (IntMap.IntMap a) type CmpMap = (MapTC Dynamic, Dynamic) @@ -234,7 +235,7 @@ ("Bool", $(dynamic [|tcl|] [| arbitraryBool :: Gen Bool |])), ("Double", $(dynamic [|tcl|] [| arbitraryDouble :: Gen Double |])), ("Float", $(dynamic [|tcl|] [| arbitraryFloat :: Gen Float |])), - ("()", $(dynamic [|tcl|] [| arbitraryVoid :: Gen () |])), + ("()", $(dynamic [|tcl|] [| arbitraryUnit :: Gen () |])), ("Ordering",$(dynamic [|tcl|] [| arbitraryOrdering:: Gen Ordering|]))] mct1 = [("Maybe", $(dynamic [|tcl|] [| arbitraryMaybe :: Gen a -> Gen (Maybe a) |])), ("[]", $(dynamic [|tcl|] [| arbitraryList :: Gen a -> Gen [a] |]))] @@ -273,7 +274,7 @@ ("Bool", $(dynamic [|tcl|] [| coarbitraryBool :: Bool -> Gen x -> Gen x |])), ("Double", $(dynamic [|tcl|] [| coarbitraryDouble :: Double -> Gen x -> Gen x |])), ("Float", $(dynamic [|tcl|] [| coarbitraryFloat :: Float -> Gen x -> Gen x |])), - ("()", $(dynamic [|tcl|] [| coarbitraryVoid :: () -> Gen x -> Gen x |])), + ("()", $(dynamic [|tcl|] [| coarbitraryUnit :: () -> Gen x -> Gen x |])), ("Ordering", $(dynamic [|tcl|] [| coarbitraryOrdering :: Ordering -> Gen x -> Gen x |]))] mct1 = [("[]", $(dynamic [|tcl|] [| coarbitraryList :: (a -> Gen x -> Gen x) -> [a] -> Gen x -> Gen x |])), ("Maybe", $(dynamic [|tcl|] [| coarbitraryMaybe :: (a -> Gen x -> Gen x) -> Maybe a -> Gen x -> Gen x |]))] diff --git a/MagicHaskeller/LibTH.hs b/MagicHaskeller/LibTH.hs --- a/MagicHaskeller/LibTH.hs +++ b/MagicHaskeller/LibTH.hs @@ -11,7 +11,20 @@ import MagicHaskeller import System.Random(mkStdGen) import Control.Monad(liftM2) +import Data.List hiding (tail, init) +import Data.Char +import Data.Maybe +import qualified Data.Generics as G +import Prelude hiding (tail, init, gcd) +-- total variants of prelude functions +tail = drop 1 +init xs = zipWith const xs (drop 1 xs) +-- gcd in the latest library is total, but with older versions gcd 0 0 causes an error. +gcd x y = gcd' (abs x) (abs y) + where gcd' a 0 = a + gcd' a b = gcd' b (a `rem` b) + initialize, init075, inittv1 :: IO () initialize = do setPrimitives (list ++ nat ++ natural ++ mb ++ bool ++ $(p [| (hd :: (->) [a] (Maybe a), (+) :: Int -> Int -> Int, (+) :: Integer -> Integer -> Integer) |])) setDepth 10 @@ -29,9 +42,10 @@ setDepth 10 tuple = $(p [| ((,) :: a -> b -> (a,b), uncurry :: (a->b->c) -> (->) (a,b) c) |]) +tuple' = $(p [| ((,) :: a -> b -> (a,b), flip uncurry :: (->) (a,b) ((a->b->c) -> c)) |]) -- Specialized memoization tables. Choose one for quicker results. -mall, mlist, mlist', mnat, mlistnat, mnat_nc :: ProgramGenerator pg => pg +mall, mlist, mlist', mnat, mlistnat, mnat_nc, mnatural, mlistnatural :: ProgramGenerator pg => pg mall = mkPG (list ++ nat ++ natural ++ mb ++ bool ++ $(p [| (hd :: (->) [a] (Maybe a), (+) :: Int -> Int -> Int, (+) :: Integer -> Integer -> Integer) |])) mlist = mkPG list mlist' = mkPG list' @@ -56,11 +70,15 @@ -- Gamma |- A -- This is just for the efficiency reason, and one can use the infixed form, i.e., maybe :: a -> (b->a) -> Maybe b -> a, if efficiency does not matter. In fact, this info is ignored if both 'guess' and 'constrL' options are False. -mb, nat, natural, list', list, bool, boolean, eq, intinst, list1, list2, list3, nats, tuple, rich, rich', debug :: [Primitive] +mb, mb', nat, natural, nat', nat'woPred, natural', list'', list', list, bool, boolean, eq, intinst, list1, list1', list2, list3, list3', nats, tuple, tuple', rich, rich', debug :: [Primitive] mb = $(p [| ( Nothing :: Maybe a, Just :: a -> Maybe a, maybe :: a -> (b->a) -> (->) (Maybe b) a ) |] ) +mb' = $(p [| ( Nothing :: Maybe a, Just :: a -> Maybe a, flip . maybe :: a -> (->) (Maybe b) ((b->a) -> a) ) |] ) nat = $(p [| (0 :: Int, succ :: Int->Int, nat_para :: (->) Int (a -> (Int -> a -> a) -> a)) |] ) natural = $(p [| (0 :: Integer, succ :: Integer->Integer, nat_para :: (->) Integer (a -> (Integer -> a -> a) -> a)) |] ) +nat' = $(p [| (0 :: Int, succ :: Int->Int, nat_cata :: (->) Int (a -> (a -> a) -> a), pred :: Int->Int) |] ) +nat'woPred = $(p [| (0 :: Int, succ :: Int->Int, nat_cata :: (->) Int (a -> (a -> a) -> a)) |] ) +natural' = $(p [| (0 :: Integer, succ :: Integer->Integer, nat_cata :: (->) Integer (a -> (a -> a) -> a), pred :: Integer->Integer) |] ) -- Nat paramorphism nat_para :: Integral i => i -> a -> (i -> a -> a) -> a @@ -69,6 +87,13 @@ np i = let i' = i-1 in f i' (np i') +-- Nat paramorphism. nat_cata i x f == iterate f x `genericIndex` abs i holds, but the following implementation is much more efficient (and thus safer). +nat_cata :: Integral i => i -> a -> (a -> a) -> a +nat_cata i x f = nc (abs i) -- Version 0.8 does not deal with partial functions very well. + where nc 0 = x + nc i = f (nc (i-1)) + +list'' = $(p [| ([], (:), flip . flip foldr :: a -> (->) [b] ((b -> a -> a) -> a), tail :: [a] -> [a]) |] ) -- foldr's argument order makes the synthesis slower:) list' = $(p [| ([], (:), foldr :: (b -> a -> a) -> a -> (->) [b] a, tail :: [a] -> [a]) |] ) -- foldr's argument order makes the synthesis slower:) list = $(p [| ([], (:), list_para :: (->) [b] (a -> (b -> [b] -> a -> a) -> a)) |] ) @@ -83,37 +108,158 @@ iF True t f = t iF False t f = f --- | 'postprocess' replaces uncommon functions like paramorphisms with well-known functions. In future it can do some refactoring. -postprocess :: Exp -> ExpQ +-- | 'postprocess' replaces uncommon functions like catamorphisms with well-known functions. +postprocess :: Exp -> Exp +postprocess (AppE (AppE (AppE (InfixE (Just e1) (VarE name) (Just e2)) e3) e4) e5) | nameBase name == "." = postprocess $ ((e1 `AppE` (e2 `AppE` e3)) `AppE` e4) `AppE` e5 -- ad hoc pattern:S +-- postprocess (AppE (AppE (AppE (AppE (VarE name) e1) e2) e3) e4) | nameBase name == "flip" = postprocess $ ((e1 `AppE` e3) `AppE` e2) `AppE` e4 +postprocess (AppE (e@(AppE (AppE (VarE name) p) t)) f) + = case nameBase name of + "iF" -> CondE ppp ppt ppf + "enumFromThenTo" -> ArithSeqE $ FromThenToR ppp ppt ppf + "nat_cata" -> InfixE (Just $ (VarE (mkName "iterate") `AppE` ppf) `AppE` ppt) + (VarE (mkName "!!")) -- Should I use genericIndex instead of (!!) also here? + (Just $ case ppp of LitE (IntegerL i) -> LitE $ IntegerL $ abs i + _ -> VarE (mkName "abs") `AppE` ppp) + "flip" -> postprocess $ + case ppp of VarE nm -> (VarE (mkName $ nameBase nm) `AppE` ppf) `AppE` ppt -- can't recall why, but the name needs to be unqualified + _ -> (ppp `AppE` ppf) `AppE` ppt + "." -> postprocess (p `AppE` (t `AppE` f)) + _ -> postprocess e `AppE` ppf + where ppp = postprocess p + ppt = postprocess t + ppf = postprocess f + +postprocess (AppE f@(AppE (VarE name) lj) e) + = case nameBase name of "drop" -> case pplj of LitE (IntegerL j) | j<=0 -> ppe + | j> 0 -> ppdrop j e + _ -> (dropE `AppE` pplj) `AppE` ppe + "enumFromTo" -> ArithSeqE $ FromToR pplj ppe + _ -> postprocess f `AppE` ppe + where pplj = postprocess lj + ppe = postprocess e +postprocess (AppE v@(VarE name) e) + = case nameBase name of + "tail" -> ppdrop 1 e + "negate" -> case ppe of LitE (IntegerL i) -> LitE $ IntegerL $ (-i) + LitE (RationalL r) -> LitE $ RationalL $ (-r) + _ -> AppE v ppe + "succ" -> case ppe of + LitE (IntegerL i) -> LitE $ IntegerL $ succ i + LitE (RationalL r) -> LitE $ RationalL $ succ r + LitE (CharL c) -> LitE $ CharL $ succ c + InfixE (Just (LitE (IntegerL n))) (VarE nm) (Just e) + | nameBase nm == "+" -> InfixE (Just $ LitE $ IntegerL $ succ n) plusE (Just e) + AppE (VarE nm) e + | nameBase nm == "succ" -> InfixE (Just $ LitE $ IntegerL 2) plusE (Just e) -- This is OK, if we use succ only for numbers. + _ -> AppE (ppv v) ppe + _ -> AppE (ppv v) ppe + where ppe = postprocess e +-- The following pattern is actually unnecessary if only eta-long normal expressions will be generated. +postprocess e@(VarE _) = ppv e +postprocess (AppE f x) = postprocess f `AppE` postprocess x +postprocess (InfixE me1 op me2) = case (j1,op,j2) of + (Just (LitE (IntegerL i1)), VarE opname, Just (LitE (IntegerL i2))) -> + case nameBase opname of "+" -> LitE $ IntegerL $ i1+i2 + "-" -> LitE $ IntegerL $ i1-i2 + "*" -> LitE $ IntegerL $ i1*i2 + _ -> theDefault + _ -> theDefault + where j1 = fmap postprocess me1 + j2 = fmap postprocess me2 + theDefault = InfixE j1 op j2 + +postprocess (LamE pats e) = ppLambda pats (postprocess e) + +postprocess (TupE es) = TupE (map postprocess es) +postprocess (ListE es) = ListE (map postprocess es) +postprocess (SigE e ty) = postprocess e `SigE` ty +postprocess e = e + +shown `appearsIn` e = G.everything (||) (False `G.mkQ` (\name -> show (name::Name) == shown)) e + + + +-- ¤³¤ÎÊÕ¤ÏCoreLang¤Ç¤ä¤ë¤Ù¤­¤È¤¤¤¦µ¤¤â¡¥¾¯¤Ê¤¯¤È¤â¡¤¤½¤Ã¤Á¤Ç´Ø¿ô¤òÄêµÁ¤¹¤Ù¤­¡¥ +-- \x -> iF foo bar x ¤Î¾ì¹ç¤âÀè¤Ë¦Ç´ÊÌ󤵤ì¤Æ¤·¤Þ¤¦¤È¥¤¥Þ¥¤¥Á¤Ç¤Ï¤¢¤ë¡¥¤Î¤Ç¡¤¦Ç´ÊÌó¤ÏiF, nat_cata, tail¤Ê¤É¤Î½èÍý¤Î¸å¤Ë¤ä¤ë¡¥ +-- For readability, we apply eta-reduction only when we can fully eta-reduce at the outermost lambda-abstraction. +ppLambda [VarP n] (AppE e (VarE n')) | shown == show n' && not (shown `appearsIn` e) = e + where shown = show n +ppLambda [VarP n, VarP m] (AppE (AppE e (VarE n')) (VarE m')) + | shown == show n' && showm == show m' && free = e + | shown == show m' && showm == show n' && free = flipE `AppE` e + where shown = show n + showm = show m + free = not (shown `appearsIn` e) && not (showm `appearsIn` e) +-- postprocess (LamE [WildP] e) = constE `AppE` e -- not sure if this is more readable.... +ppLambda [VarP n, WildP] (VarE n') | show n == show n' = constE +ppLambda [VarP n] (VarE n') | show n == show n' = VarE (mkName "id") +ppLambda [VarP n, VarP m] (InfixE (Just (VarE n')) op (Just (VarE m'))) | show n == show n' && show m == show m' = op +ppLambda pats@[VarP n, VarP m] e@(InfixE (Just (VarE n')) op@(VarE opna) (Just (VarE m'))) + = if show n == show m' && show m == show n' + then case nameBase opna of "<" -> VarE (mkName ">") + "<=" -> VarE (mkName ">=") + "-" -> VarE (mkName "subtract") + name | name `elem` ["==","/=","+","*","&&","||"] -> op + | otherwise -> flipE `AppE` op + else LamE pats e +ppLambda [VarP n] (InfixE (Just (VarE n')) op (Just e)) + | shown == show n' && not (shown `appearsIn` e) = case op of VarE name | nameBase name == "-" -> VarE (mkName "subtract") `AppE` e + _ -> InfixE Nothing op (Just e) + where shown = show n +ppLambda [VarP n] (InfixE (Just e) op (Just (VarE n'))) | shown == show n' && not (shown `appearsIn` e) = InfixE (Just e) op Nothing + where shown = show n +ppLambda pats e = LamE pats e + + + +ppv e@(VarE name) | nameBase name `elem` ["iF", "nat_cata"] = LamE [ VarP n | n <- names ] (postprocess (AppE (AppE (AppE e p) t) f)) + | otherwise = e + where names = [ mkName [n] | n <- "ptf" ] + [p,t,f] = map VarE names + + +ppdrop m0j e + = case postprocess e of + AppE (AppE (VarE drn) (LitE (IntegerL i))) list | nameBase drn == "drop" -> droppy (m0j + i) list -- NB: m0j and i are both positive. + ppe -> droppy m0j ppe + where droppy i e = (dropE `AppE` (LitE $ IntegerL i)) `AppE` e + +constE = VarE $ mkName "const" +flipE = VarE $ mkName "flip" +plusE = VarE $ mkName "+" +dropE = VarE $ mkName "drop" + +procSucc n (AppE (VarE name) e) | nameBase name == "succ" = procSucc (n+1) e +procSucc n (LitE (CharL c)) = LitE $ CharL $ iterate succ c `genericIndex` n +procSucc n (LitE (IntegerL i)) = LitE $ IntegerL $ n+i +procSucc n (LitE (RationalL r)) = LitE $ RationalL $ fromInteger n + r +procSucc n e = InfixE (Just $ LitE $ IntegerL n) (VarE $ mkName "+") (Just $ postprocess e) -- This is OK, if we use succ only for numbers. + +postprocessQ :: Exp -> ExpQ {- This type of patterns is not available yet. -postprocess (AppE (AppE (AppE (VarE 'iF) p) t) f) = [| if $(postprocess p) then $(postprocess t) else $(postprocess f) |] -postprocess (AppE (AppE (AppE (VarE 'nat_para) i) x) f) = [| let {np 0 = $(postprocess x); np (n+1) = $(postprocess f) n (np n)} in np (abs $(postprocess i)) |] -postprocess (AppE (AppE (AppE (VarE 'list_para) xs) x) f) = [| let {lp [] = $(postprocess x); lp (y:ys) = $(postprocess f) y ys (lp ys)} in lp $(postprocess xs) |] +postprocessQ (AppE (AppE (AppE (VarE 'iF) p) t) f) = [| if $(postprocessQ p) then $(postprocessQ t) else $(postprocessQ f) |] +postprocessQ (AppE (AppE (AppE (VarE 'nat_para) i) x) f) = [| let {np 0 = $(postprocessQ x); np (n+1) = $(postprocessQ f) n (np n)} in np (abs $(postprocessQ i)) |] +postprocessQ (AppE (AppE (AppE (VarE 'list_para) xs) x) f) = [| let {lp [] = $(postprocessQ x); lp (y:ys) = $(postprocessQ f) y ys (lp ys)} in lp $(postprocessQ xs) |] -} -postprocess (AppE (AppE (AppE (VarE name) p) t) f) +postprocessQ (AppE (e@(AppE (AppE (VarE name) p) t)) f) = case nameBase name of - "iF" -> [| if $(postprocess p) then $(postprocess t) else $(postprocess f) |] - "nat_para" -> [| let {np 0 = $(postprocess t); np n = let i=n-1 in $(postprocess f) i (np i)} in np (abs $(postprocess p)) |] - "list_para" -> [| let {lp [] = $(postprocess t); lp (y:ys) = $(postprocess f) y ys (lp ys)} in lp $(postprocess p) |] -postprocess (AppE f x) = [| $(postprocess f) $(postprocess x) |] --- postprocess (VarE 'iF) = [| \p t f -> if p then t else f |] -- This pattern is actually unnecessary because only eta-long normal expressions will be generated. + "iF" -> [| if $(postprocessQ p) then $(postprocessQ t) else $(postprocessQ f) |] + "nat_cata" -> [| iterate $(postprocessQ f) $(postprocessQ t) !! abs $(postprocessQ p) |] + "nat_para" -> [| let {np 0 = $(postprocessQ t); np n = let i=n-1 in $(postprocessQ f) i (np i)} in np (abs $(postprocessQ p)) |] + "list_para" -> [| let {lp [] = $(postprocessQ t); lp (y:ys) = $(postprocessQ f) y ys (lp ys)} in lp $(postprocessQ p) |] + _ -> [| $(postprocessQ e) $(postprocessQ f) |] +postprocessQ (AppE f x) = [| $(postprocessQ f) $(postprocessQ x) |] +-- postprocessQ (VarE 'iF) = [| \p t f -> if p then t else f |] -- This pattern is actually unnecessary because only eta-long normal expressions will be generated. -- ... -postprocess (InfixE me1 op me2) = let fmapM f Nothing = return Nothing - fmapM f (Just x) = fmap Just (f x) - in liftM2 (\e1 e2 -> InfixE e1 op e2) (fmapM postprocess me1) (fmapM postprocess me2) -postprocess (LamE pats e) = fmap (LamE pats) (postprocess e) -postprocess (TupE es) = fmap TupE (mapM postprocess es) -postprocess (ListE es) = fmap ListE (mapM postprocess es) -postprocess (SigE e ty) = fmap (`SigE` ty) (postprocess e) -postprocess e = return e +postprocessQ (InfixE me1 op me2) = let fmapM f Nothing = return Nothing + fmapM f (Just x) = fmap Just (f x) + in liftM2 (\e1 e2 -> InfixE e1 op e2) (fmapM postprocessQ me1) (fmapM postprocessQ me2) +postprocessQ (LamE pats e) = fmap (LamE pats) (postprocessQ e) +postprocessQ (TupE es) = fmap TupE (mapM postprocessQ es) +postprocessQ (ListE es) = fmap ListE (mapM postprocessQ es) +postprocessQ (SigE e ty) = fmap (`SigE` ty) (postprocessQ e) +postprocessQ e = return e -{- -postprocess :: Exp -> Exp -postprocess (AppE (AppE (AppE (VarE 'iF) p) t) f) = CondE (postprocess p) (postprocess t) (postprocess f) -postprocess (VarE 'iF) = LamE [ VarP n | n <- names ] (CondE p t f) - where names@[p,t,f] = [ mkName [n] | n <- "ptf" ] -postprocess --} exploit :: (Typeable a, Filtrable a) => (a -> Bool) -> IO () exploit pred = filterThenF pred (everything (reallyall::ProgGenSF)) >>= pprs @@ -122,6 +268,7 @@ (||) :: Bool -> Bool -> Bool, not :: Bool -> Bool) |] ) -- Type classes are not supported yet.... +-- Without tuning of the probability distribution over Chars and Lists, these are almost useless. eq = $(p [| ((==) :: Int->Int->Bool, (/=) :: Int->Int->Bool, (==) :: Char->Char->Bool, (/=) :: Char->Char->Bool, (==) :: Bool->Bool->Bool, (/=) :: Bool->Bool->Bool, @@ -129,19 +276,26 @@ (==) :: [Char]->[Char]->Bool, (/=) :: [Char]->[Char]->Bool, (==) :: [Bool]->[Bool]->Bool, (/=) :: [Bool]->[Bool]->Bool) |] ) -- ...bothered. -intinst = $(p [| ( (<=) :: Int->Int->Bool, +{- +eq = $(p [| ((==) :: Int->Int->Bool, (/=) :: Int->Int->Bool, + (==) :: Char->Char->Bool, (/=) :: Char->Char->Bool, + (==) :: Bool->Bool->Bool, (/=) :: Bool->Bool->Bool) |]) +-} +intinst = intinst1++intinst2 +intinst1 = $(p [| ( (<=) :: Int->Int->Bool, (<) :: Int->Int->Bool, - (>=) :: Int->Int->Bool, - (>) :: Int->Int->Bool, + -- (>=) :: Int->Int->Bool, + -- (>) :: Int->Int->Bool, max :: Int->Int->Int, min :: Int->Int->Int, (-) :: Int->Int->Int, (*) :: Int->Int->Int, div :: Int->Int->Int, mod :: Int->Int->Int, - gcd :: Int->Int->Int, - lcm :: Int->Int->Int, (^) :: Int->Int->Int) |]) +intinst2 = $(p [| ( + gcd :: Int->Int->Int, + lcm :: Int->Int->Int) |]) list1 = $(p [| (map :: (a -> b) -> (->) [a] [b], (++) :: [a] -> [a] -> [a], @@ -154,6 +308,17 @@ drop :: Int -> [a] -> [a], takeWhile :: (a -> Bool) -> [a] -> [a], dropWhile :: (a -> Bool) -> [a] -> [a]) |] ) +list1' = $(p [| (flip map :: (->) [a] ((a -> b) -> [b]), + (++) :: [a] -> [a] -> [a], + filter :: (a -> Bool) -> [a] -> [a], + concat :: [[a]] -> [a], + flip concatMap :: (->) [a] ((a -> [b]) -> [b]), + length :: (->) [a] Int, + replicate :: Int -> a -> [a], + take :: Int -> [a] -> [a], + drop :: Int -> [a] -> [a], + takeWhile :: (a -> Bool) -> [a] -> [a], + dropWhile :: (a -> Bool) -> [a] -> [a]) |] ) list2 = $(p [| ( lines :: [Char] -> [[Char]], words :: [Char] -> [[Char]], @@ -166,6 +331,12 @@ any :: (a -> Bool) -> (->) [a] Bool, all :: (a -> Bool) -> (->) [a] Bool, zipWith :: (a->b->c) -> (->) [a] ((->) [b] [c]) ) |] ) +list3' = $(p [| (reverse :: [a] -> [a], + and :: [Bool] -> Bool, + or :: [Bool] -> Bool, + flip any :: (->) [a] ((a -> Bool) -> Bool), + flip all :: (->) [a] ((a -> Bool) -> Bool), + flip . flip zipWith :: (->) [a] ((->) [b] ((a->b->c) -> [c])) ) |] ) nats = $(p [| (1 ::Int, 2 :: Int, 3 :: Int) |]) @@ -185,12 +356,14 @@ (list++bool) rich -rich = (list' ++ - nat ++ - mb ++ bool ++ $(p [| (hd :: [a] -> Maybe a, (+) :: Int -> Int -> Int) |]) ++ - boolean ++ eq ++ intinst ++ - list1 ++ list2 ++ list3) - +-- I think having both succ and pred is not good, and pred x can be synthesized as x - succ 0. +-- Still, having both cons and tail is OK. +soso = (list'' ++ + nat'woPred ++ + mb' ++ bool ++ $(p [| (+) :: Int -> Int -> Int |]) ++ -- x $(p [| (hd :: [a] -> Maybe a, (+) :: Int -> Int -> Int) |]) ++ + boolean ++ eq ++ intinst1 ++ + list1' ++ list3') +rich = soso ++ list2 ++ intinst2 ++ $(p [| init :: [a] -> [a] |]) poormix = mkPGSF (mkStdGen 123456) nrnds @@ -211,3 +384,27 @@ debug = $(p [| (list_para :: (->) [b] (a -> (b -> [b] -> a -> a) -> a), concatMap :: (a -> [b]) -> (->) [a] [b]) |] ) +-- Library used by the program server backend +pgfull :: ProgGenSF +-- pgfull = mkPG ($(MagicHaskeller.LibTH.load "libsrc/PreludeList.hs") ++ mb ++ bool ++ boolean ++ $(p [| ([], (:), (+) :: Int -> Int -> Int, replicate :: Int -> a -> [a]) |]) ++ $(p [| until :: (a -> Bool) -> (a -> a) -> a -> a |]) ++ nat ++ eq ++ intinst) -- rich とあまり変わらない． +pgfull = mkPGXOpt options{tv1=True,nrands=repeat 20} $ foldr (zipWith (++)) literals [fromPrelude, fromDataList, fromDataChar, fromDataMaybe] +literals = [$(p [|(1::Int, ' '::Char)|]),[],[]] +fromPrelude = [soso ++ $(p [| (abs :: Int->Int, compare :: Char->Char->Ordering, compare :: Int->Int->Ordering, foldr const :: a -> [a] -> a, + flip (flip . either) :: (->) (Either a b) ((a -> c) -> (b -> c) -> c)) |]), + list2 ++ $(p [| (scanl :: (a -> b -> a) -> a -> [b] -> [a], scanr :: (a -> b -> b) -> b -> [a] -> [b], scanl1 :: (a -> a -> a) -> [a] -> [a], scanr1 :: (a -> a -> a) -> [a] -> [a], replicate :: Int -> a -> [a], sum :: [Int]->Int, product :: [Int]->Int, + -- until :: (a -> Bool) -> (a -> a) -> a -> a) を入れてたが，どうもuntilがあると急に遅くなる．その割に，全く使われない．何じゃらホイ + enumFromTo :: Int->Int->[Int], show :: Int -> String) |])++ $(p [| flip uncurry :: (->) (a,b) ((a->b->c) -> c) |]), + intinst2 ++ $(p [| ((,) :: a -> b -> (a,b), Left :: a -> Either a b, Right :: b -> Either a b) |])] -- , enumFromThenTo :: Int->Int->Int->[Int]) |])] -- The problem is that enumFromThenTo 1 1 2 is infinite. +fromDataList = [$(p [| (sortBy, nubBy, deleteBy, transpose, stripPrefix :: String->String->Maybe String)|]), + $(p [| ( + find, flip findIndex :: (->) [a] ((a -> Bool) -> Maybe Int), flip findIndices :: (->) [a] ((a -> Bool) -> [Int]), deleteFirstsBy, unionBy, intersectBy, groupBy, insertBy, maximumBy, minimumBy) |]), + $(p [| (intersperse, subsequences, permutations, -- dropWhileEnd, + inits, tails, + isPrefixOf :: String -> String -> Bool, isSuffixOf :: String -> String -> Bool, isInfixOf :: String -> String -> Bool + ) |])] +fromDataChar = [$(p [| (toUpper, toLower) |]), + $(p [| (ord, chr, digitToInt, intToDigit, isControl, isSpace, isLower, isUpper, isAlpha, isAlphaNum, isDigit) |]), + $(p [| (isPrint, isOctDigit, isHexDigit) |])] +fromDataMaybe = [[], + $(p [| (catMaybes, listToMaybe, maybeToList) |])] + -- mapMaybe f = catMaybes . map f diff --git a/MagicHaskeller/MemoToFiles.hs b/MagicHaskeller/MemoToFiles.hs --- a/MagicHaskeller/MemoToFiles.hs +++ b/MagicHaskeller/MemoToFiles.hs @@ -39,48 +39,56 @@ -> Type -> PriorSubsts (RecompT IO) [b] memoPSRTIO policy mt f t = PS $ \subst mx -> let (tn, decoder) = encode t mx - in (fmap (\ (exprs, sub, m) -> (exprs, retrieve decoder sub `plusSubst` subst, mx+m)) $ (memoRTIO policy mt (\u -> freezePS u (f u)) tn)) + in (fmap (\ (exprs, sub, m) -> (exprs, retrieve decoder sub `plusSubst` subst, mx+m)) $ (memoRTIO policy (\ty depth -> return $ unMx (lookupMT mt ty) !! depth) (\u -> freezePS u (f u)) tn)) memoRTIO :: ShortString b => - MemoCond -- IO¤òÊÖ¤¹¡¥¤Ä¤Þ¤ê¡¤¥á¥â¥ê¤ä¥Ï¡¼¥É¥Ç¥£¥¹¥¯¤Î¶õ¤­¤Ë¤è¤Ã¤Æ¤âÊѤ¨¤é¤ì¤ë¤è¤¦¤Ë¤¹¤ë¡¥ - -> MapType (Matrix b) -- ^ Memoization table for the Ram case. + MemoCond + -> (Type -> Int -> IO [b]) -- ^ look up the memoization table in the RAM. -> (Type -> RecompT IO b) -- ^ This will be used instead if the entry is not found. -> Type -> RecompT IO b -memoRTIO policy mt f t = RcT $ memoer policy mt (\ty -> unRcT (f ty)) t +memoRTIO policy lor f t = RcT $ memoer policy lor (\ty -> unRcT (f ty)) t memoer :: ShortString b => MemoCond - -> MapType (Matrix b) + -> (Type -> Int -> IO [b]) -> (Type -> Int -> IO [b]) -> Type -> Int -> IO [b] -memoer policy mt f ty depth +memoer policy lor f ty depth = do memotype <- policy ty depth case memotype of Recompute -> compute - Ram -> return $ unMx (lookupMT mt ty) !! depth - Disk fp -> let directory = fp++shows depth "/" -- care about Windows later.... - filepath = directory ++ show ty - in do createDirectoryIfMissing True directory - memoToFile readsBriefly showsBriefly filepath compute + Ram -> lor ty depth + Disk fp | Prelude.length filepath < 250 -> do -- If I remember correctly, UNIX does not permit filenames longer than 255 letters. + -- System.IO.putStrLn "Hit!" + -- System.IO.putStrLn ("Directory name: "++directory) + -- System.IO.putStrLn ("FilePath: "++ filepath) + createDirectoryIfMissing True directory + memoToFile readBriefly showBriefly filepath compute + | otherwise -> compute -- This is safer than Ram. Still this behavior can be overridden by specifying the MemoCond accordingly + -- (though that can be unsafe). + where + directory = fp++shows depth "/" -- care about Windows later.... + filepath = directory ++ show ty where compute = f ty depth data MemoType = Recompute -- ^ Recompute instead of memoizing. | Ram -- ^ Use the memoization table based on lazy evaluation, like in older versions. | Disk FilePath -- ^ Use the directory specified by @FilePath@ as the persistent memoization table. -type MemoCond = Type -> Int -> IO MemoType +type MemoCond = Type -> Int -> IO MemoType -- IO¤òÊÖ¤¹¡¥¤Ä¤Þ¤ê¡¤¥á¥â¥ê¤ä¥Ï¡¼¥É¥Ç¥£¥¹¥¯¤Î¶õ¤­¤Ë¤è¤Ã¤Æ¤âÊѤ¨¤é¤ì¤ë¤è¤¦¤Ë¤¹¤ë¡¥ -- | General-purposed memoizer (This could be put in a different module.) -memoToFile :: (C.ByteString -> Maybe (a,C.ByteString)) -> (a -> LC.ByteString -> LC.ByteString) +memoToFile :: (C.ByteString -> Maybe a) -- ^ parser + -> (a -> LC.ByteString) -- ^ printer -> FilePath -- ^ where to memoize -> IO a -- ^ invoked if there is no such file -> IO a memoToFile parser printer filepath compute = let write = do result <- compute - LC.writeFile filepath (printer result LC.empty) + LC.writeFile filepath (printer result) return result in do there <- doesFileExist filepath if there then do cs <- C.readFile filepath -- Read strictly, and close (not semi-close) it. System.IO.readFile cannot achieve this behavior. - case parser cs of Just (x,_) -> return x - _ -> do -- If the file is broken, just fix it. ¤Ç¤â狼¤¬½ñ¤­¹þ¤ßÃæ¤À¤Èº¤¤ë? + case parser cs of Just x -> return x + _ -> do -- If the file is broken, just fix it. ¤Ç¤â狼¤¬½ñ¤­¹þ¤ßÃæ¤À¤Èº¤¤ë? System.IO.hPutStrLn stderr ("File " ++ filepath ++ " was broken.") write else write diff --git a/MagicHaskeller/Minimal.hs b/MagicHaskeller/Minimal.hs new file mode 100644 --- /dev/null +++ b/MagicHaskeller/Minimal.hs @@ -0,0 +1,12 @@ +-- minimal set of definitions for safer use by a server +module MagicHaskeller.Minimal(f1E, f1EF, ProgGenSF) where +import MagicHaskeller.LibTH +import MagicHaskeller.ProgGenSF +import Data.Typeable + +deadline = Just 20000 + +f1E :: Typeable a => (a -> Bool) -> ProgGenSF -> [[Exp]] +f1E pred = map (map (postprocess . fst)) . map (fp deadline pred) . everything +f1EF :: (Filtrable a, Typeable a) => (a -> Bool) -> ProgGenSF -> [[Exp]] +f1EF pred = map (map (postprocess . fst)) . everyF deadline . map (fp deadline pred) . everything diff --git a/MagicHaskeller/MyCheck.hs b/MagicHaskeller/MyCheck.hs --- a/MagicHaskeller/MyCheck.hs +++ b/MagicHaskeller/MyCheck.hs @@ -39,10 +39,10 @@ -- arbitrary :: (Random a, Bounded a) => Gen a -- arbitrary = arbitraryR (minBound, maxBound) -arbitraryVoid :: Gen () -arbitraryVoid = return () -coarbitraryVoid :: Coarb () b -coarbitraryVoid _ = id +arbitraryUnit :: Gen () +arbitraryUnit = return () +coarbitraryUnit :: Coarb () b +coarbitraryUnit _ = id arbitraryBool :: Gen Bool arbitraryBool = arbitraryR (False,True) @@ -88,7 +88,13 @@ coarbitraryRealFloat :: RealFloat a => Coarb a b coarbitraryRealFloat x = let (sig, xpo) = decodeFloat x in newvariant sig . newvariant xpo -arbitraryChar = arbitraryR (' ', chr 126) +arbitraryChar = do r <- arbitraryR (0,11) + [arbNum, arbNum, arbASC, return '\n', retSpc, arbLow, arbLow, arbLow, arbLow, arbUpp, arbUpp, arbUpp] !! r +retSpc = return ' ' +arbASC = arbitraryR (' ', chr 126) +arbNum = arbitraryR ('0','9') +arbLow = arbitraryR ('a','z') +arbUpp = arbitraryR ('A','Z') coarbitraryChar c = newvariant (ord c) arbitraryOrdering :: Gen Ordering @@ -158,9 +164,9 @@ coarbitrary :: a -> Gen b -> Gen b instance Arbitrary () where - arbitrary = arbitraryVoid + arbitrary = arbitraryUnit instance Coarbitrary () where - coarbitrary = coarbitraryVoid + coarbitrary = coarbitraryUnit instance Arbitrary Bool where arbitrary = arbitraryBool diff --git a/MagicHaskeller/MyDynamic.hs b/MagicHaskeller/MyDynamic.hs --- a/MagicHaskeller/MyDynamic.hs +++ b/MagicHaskeller/MyDynamic.hs @@ -1,6 +1,7 @@ -- -- (c) Susumu Katayama -- +{-# LANGUAGE CPP #-} # ifdef REALDYNAMIC module MagicHaskeller.MyDynamic(module MagicHaskeller.PolyDynamic, dynamic, dynamicH) where import MagicHaskeller.PolyDynamic diff --git a/MagicHaskeller/PolyDynamic.hs b/MagicHaskeller/PolyDynamic.hs --- a/MagicHaskeller/PolyDynamic.hs +++ b/MagicHaskeller/PolyDynamic.hs @@ -3,7 +3,7 @@ -- -- Dynamic with unsafe execution. -{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# LANGUAGE CPP, TemplateHaskell, MagicHash, RankNTypes #-} module MagicHaskeller.PolyDynamic ( Dynamic(..), fromDyn, -- :: Type -> Dynamic -> a -> a diff --git a/MagicHaskeller/PriorSubsts.lhs b/MagicHaskeller/PriorSubsts.lhs --- a/MagicHaskeller/PriorSubsts.lhs +++ b/MagicHaskeller/PriorSubsts.lhs @@ -74,6 +74,8 @@ {-# SPECIALIZE instance MonadPlus (PriorSubsts []) #-} mzero = PS (\_ _->mzero) mplus = distPS mplus +instance Delay m => Delay (PriorSubsts m) where + delay (PS f) = PS $ \s i -> delay $ f s i instance Monoid a => Monoid (PriorSubsts [] a) where mempty = PS (\_ _ -> []) mappend = distPS $ mergeWithBy (\(xs,k,i) (ys,_,_) -> (xs `mappend` ys, k, i)) (\ (_,k,_) (_,l,_) -> k `compare` l) @@ -88,17 +90,17 @@ {-# SPECIALIZE applyPS :: Type -> PriorSubsts [] Type #-} -applyPS :: MonadPlus m => Type -> PriorSubsts m Type +applyPS :: Monad m => Type -> PriorSubsts m Type applyPS ty = PS (\s i -> return (apply s ty, s, i)) {-# SPECIALIZE updatePS :: Subst -> PriorSubsts [] () #-} -updatePS :: MonadPlus m => Subst -> PriorSubsts m () +updatePS :: Monad m => Subst -> PriorSubsts m () updatePS subst = PS (\s i -> return ((), subst `plusSubst` s, i)) {-# SPECIALIZE updateSubstPS :: (Subst -> [] Subst) -> PriorSubsts [] () #-} -updateSubstPS :: MonadPlus m => (Subst -> m Subst) -> PriorSubsts m () +updateSubstPS :: Monad m => (Subst -> m Subst) -> PriorSubsts m () updateSubstPS f = PS (\s i -> f s >>= \s' -> return ((), s', i)) {-# SPECIALIZE setSubst :: Subst -> PriorSubsts [] () #-} -setSubst :: MonadPlus m => Subst -> PriorSubsts m () +setSubst :: Monad m => Subst -> PriorSubsts m () setSubst subst = updateSubstPS (\_ -> return subst) {-# SPECIALIZE mguPS :: Type -> Type -> PriorSubsts [] () #-} diff --git a/MagicHaskeller/ProgGen.lhs b/MagicHaskeller/ProgGen.lhs --- a/MagicHaskeller/ProgGen.lhs +++ b/MagicHaskeller/ProgGen.lhs @@ -94,9 +94,9 @@ unifyingPossibilitiesIO :: Type -> MemoDeb CoreExpr -> RecompT IO ([CoreExpr],Subst,Int) unifyingPossibilitiesIO ty memodeb = unPS (mguProgsIO memodeb [] ty) emptySubst 0 -type MemoDeb a = (MemoTrie a, ([Prim],[Prim]), Common) +type MemoDeb a = (MemoTrie a, ([[Prim]],[[Prim]]), Common) -mkTrieMD :: Common -> [Typed [CoreExpr]] -> MemoDeb CoreExpr +mkTrieMD :: Common -> [[Typed [CoreExpr]]] -> MemoDeb CoreExpr mkTrieMD cmn txs = let memoDeb = (memoTrie, qtl, cmn) @@ -111,7 +111,7 @@ #endif -- We need to specialize the type (to BF) in order to avoid ambiguity. in memoDeb - where qtl = splitPrims txs + where qtl = splitPrimss txs -- moved from DebMT.lhs to avoid cyclic modules. @@ -164,7 +164,7 @@ fe = filtExprs (guess $ opt cmn) rg = if tv0 $ opt cmn then retGenTV0 else if tv1 $ opt cmn then retGenTV1 else retGen - in fromAssumptions (PG memodeb) lenavails behalf mguPS reqret avail `mplus` msum (map (rg (PG memodeb) lenavails fe lltbehalf behalf reqret) primgen ++ map (retPrimMono (PG memodeb) lenavails lltbehalf behalf mguPS reqret) primmono ) + in fromAssumptions (PG memodeb) lenavails behalf mguPS reqret avail `mplus` mapSum (rg (PG memodeb) lenavails fe lltbehalf behalf reqret) primgen `mplus` mapSum (retPrimMono (PG memodeb) lenavails lltbehalf behalf mguPS reqret) primmono #ifdef DESTRUCTIVE lookupListrie rec (trie, (primgen,_),tcl,rtrie) avail t = rec ((snd trie, snd trie), (primgen,[]), tcl, rtrie) avail t @@ -176,7 +176,10 @@ let args' = filter (not.isClosed.toCE) args when (null args') mzero return args' - | otherwise = rec memodeb avail t + | otherwise = do args <- rec memodeb avail t + let args' = filter (not.isConstrExpr.toCE) args + when (null args') mzero + return args' filtExprs g a b | g = filterExprs a b | otherwise = id #endif diff --git a/MagicHaskeller/ProgGenSF.lhs b/MagicHaskeller/ProgGenSF.lhs --- a/MagicHaskeller/ProgGenSF.lhs +++ b/MagicHaskeller/ProgGenSF.lhs @@ -3,7 +3,12 @@ -- \begin{code} -{-# OPTIONS -cpp -XRelaxedPolyRec #-} +{-# LANGUAGE CPP, RelaxedPolyRec #-} -- Of course, LANGUAGE CPP must be before #ifdef. +#ifdef GHC7 +{-# LANGUAGE DatatypeContexts #-} +#else +{-# OPTIONS -fglasgow-exts #-} +#endif module MagicHaskeller.ProgGenSF(ProgGenSF, PGSF) where import MagicHaskeller.Types import MagicHaskeller.TyConLib @@ -39,6 +44,10 @@ reorganize_ = reorganizer_ -- reorganize_ = id +reorganizerId' :: (Functor m, Expression e) => ([Type] -> m e) -> [Type] -> m e +reorganizerId' = reorganizeId' +--reorganizerId' = id + classify = True traceExpTy _ = id -- traceExpTy fty = trace ("lookupexp "++ show fty) @@ -46,7 +55,8 @@ -- traceTy fty = trace ("lookup "++ show fty) -- Memoization table, created from primitive components -type ProgGenSF = PGSF AnnExpr +--type ProgGenSF = PGSF AnnExpr +type ProgGenSF = PGSF CoreExpr -- temporarily, until reorganize for ProgGenSF is implemented. newtype Expression e => PGSF e = PGSF (MemoDeb e) -- internal data representation. -- ^ Program generator with synergetic filtration. -- This program generator employs filtration by random testing, and rarely generate semantically equivalent expressions more than once, while different expressions will eventually appear (for most of the types, represented with Prelude types, whose arguments are instance of Arbitrary and which return instance of Ord). @@ -62,7 +72,7 @@ type ExpTip e = Matrix e type ExpTrie e = MapType (ExpTip e) -type TypeTrie e = MapType (Matrix ([e], Subst, Int)) +type TypeTrie e = MapType (Matrix (ExpTip e, Subst, Int)) type MemoTrie e = (TypeTrie e, ExpTrie e) @@ -71,6 +81,7 @@ lookupMT mt fty -- ¤³¤Ã¤Á¤À¤Èlookup -- filtBF cmn fty $ matchFunctions (maxBound', memoDeb) fty -- ¤³¤Ã¤Á¤À¤Èrecompute +filtBF :: Expression e => Common -> Type -> DBound e -> Matrix e -- filtBF ty = fmap fromAnnExpr . filterBF tcl rtrie ty . fmap (toAnnExprWind (execute opt) ty) . tabulate --filtBF cmn ty = dbToCumulativeMx . fmap fromAnnExpr . fDM cmn ty . fmap (toAnnExprWind (execute (opt cmn) (vl cmn)) ty) . mapDepthDB uniqSorter -- . mondepth filtBF cmn ty | classify = dbToCumulativeMx . fmap fromAnnExpr . fDM cmn ty . fmap (toAnnExprWind (execute (opt cmn) (vl cmn)) ty) . (\(DB g) -> DB (\d -> -- trace (shows (length (g d)) $ ('\t':) $ shows d $ ('\t':) $ show ty) $ @@ -101,7 +112,7 @@ unifyingPossibilities ty memodeb = unPS (unifyableExprs memodeb [] ty) emptySubst 0 matchProgs :: Expression e => MemoDeb e -> Type -> Matrix AnnExpr -matchProgs memodeb ty = fmap (toAnnExprWindWind (reducer $ PGSF memodeb) ty) $ lmt memodeb $ normalize ty -- ¤³¤Ã¤Á¤À¤Èlookup +matchProgs memodeb ty = fmap (toAnnExprWindWind (reducer $ PGSF memodeb) ty) $ lookupReorganized memodeb ty -- ¤³¤Ã¤Á¤À¤Èlookup {- matchProgs memodeb ty = fmap toAnnExpr $ wind (fmap (mapCE Lambda)) (lookupFuns memodeb) [] (quantify ty) -- ¤³¤Ã¤Á¤À¤Èrecompute ¤È¤¤¤¦¤È¸ìÊÀ¤¬¤¢¤ë¡¥recompute¤·¤¿¤­¤ãlmt¤Î¤È¤³¤í¤òÊѤ¨¤ë¤Ù¤·¡¥ @@ -123,9 +134,9 @@ -- specializedPossibleTypes ty memodeb@(_,((mt,_),_,_,_)) = fmap (\(_,s,_) -> apply s ty) $ toRc $ lmtty mt ty -type MemoDeb e = (MemoTrie e, (([Prim],[Prim]),([Prim],[Prim])), Common) +type MemoDeb e = (MemoTrie e, (([[Prim]],[[Prim]]),([[Prim]],[[Prim]])), Common) -mkTrieOptSF :: Expression e => Common -> [Typed [CoreExpr]] -> [Typed [CoreExpr]] -> MemoDeb e +mkTrieOptSF :: Expression e => Common -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]] -> MemoDeb e mkTrieOptSF cmn txsopt txs = let memoDeb = (memoTrie, (qtlopt,qtl), cmn) @@ -134,13 +145,17 @@ typeTrie = mkMTty (tcl cmn) (\ty -> freezePS ty (specTypes memoDeb ty)) expTrie = mkMTexp (tcl cmn) (\ty -> filtBF cmn ty $ matchFunctions memoDeb ty) in memoDeb - where qtlopt = splitPrims txsopt - qtl = splitPrims txs + where qtlopt = splitPrimss txsopt + qtl = splitPrimss txs dbToCumulativeMx :: (Ord a) => DBound a -> Matrix a +dbToCumulativeMx (DB f) = Mx $ case map (sort . map fst . f) [0..] of + xss -> let result = zipWith (diffSortedBy compare) xss $ scanl (++) [] result in result -- ¿ʬËÜÅö¤ÏÌÀ¼¨Åª¤Ëlookup¤·Ä¾¤¹¤Ù¤­¡¥ +{- The following does not accurately give other chances to the expressions once dropped. ¥³¡¼¥É¤ò¤¤¤¸¤Ã¤Æ¤¤¤ë¤¦¤Á¤Ë¤¤¤Ä¤Î´Ö¤Ë¤«ºÇ½é¤ÎÀ߷פò˺¤ì¤Æ¤³¤ó¤Ê¤ó¤Ê¤Ã¤Æ¤¿¡¥ -- dbToCumulativeMx (DB f) = Mx $ map (map fst . f) [0..] dbToCumulativeMx (DB f) = let foo = map (sort . map fst . f) [0..] in Mx $ zipWith (diffSortedBy compare) foo ([]:foo) -- in Mx $ zipWith (\\) foo ([]:foo) +-} mkMTty = mkMT mkMTexp = mkMT @@ -158,10 +173,10 @@ = let mxty = maxVarID ty -- `max` maximum (map maxVarID avail) in Mx $ map (tokoro10ap ty) $ scanl1 (++) $ unMx $ toMx $ unPS ps emptySubst (mxty+1) -} -freezePS :: Type -> PriorSubsts DBound (ExpTip e) -> Matrix ([e],Subst,Int) +freezePS :: Type -> PriorSubsts DBound (ExpTip e) -> Matrix (ExpTip e,Subst,Int) freezePS ty ps = let mxty = maxVarID ty -- `max` maximum (map maxVarID avail) - in zipDepthMx (\d tups -> map (\(Mx xss, s, i)->(xss!!d, s, i)) $ tokoro10ap ty tups) $ toMx $ fmap fst $ Rc $ unDB $ unPS ps emptySubst (mxty+1) + in mapDepth (tokoro10ap ty) $ toMx $ fmap fst $ Rc $ unDB $ unPS ps emptySubst (mxty+1) -- MemoStingy.tokoro10 is different from T10.tokoro10, in that duplicates will be removed. -- (Note that the type can be specialized to [(Type,k,i)] -> [(Type,k,i)]) @@ -202,7 +217,7 @@ | memocond depth = lookupUniExprs memodeb avail t depth >> return () | otherwise = makeUniExprs memodeb avail t depth >> return () -lookupUniExprs :: Expression e => MemoDeb e -> [Type] -> Type -> Int -> PriorSubsts [] [e] +lookupUniExprs :: Expression e => MemoDeb e -> [Type] -> Type -> Int -> PriorSubsts [] (ExpTip e) lookupUniExprs memodeb@((mt,_),_,_) avail t depth = lookupNormalized (\tn -> unMx (lmtty mt tn) !! depth) avail t @@ -213,6 +228,8 @@ sub <- getSubst return $ quantify (apply sub $ popArgs avail t) +lookupReorganized md typ = let (avs, retty) = splitArgs $ normalize typ + in reorganizerId' (\av -> lmt md $ popArgs av retty) avs -- entry point for memoization specTypes :: (Search m, Expression e) => MemoDeb e -> Type -> PriorSubsts m (ExpTip e) @@ -221,7 +238,14 @@ reorganize_ (\av -> specCases' memodeb av t) avail -- quantify¤ÏmemoÀè¤Ç´û¤Ë¤ä¤é¤ì¤Æ¤¤¤ë¤Î¤ÇÉÔÍ× typ <- applyPS ty - return (lmt memodeb $ normalize typ) + return $ lookupReorganized memodeb typ +specTypesRecompute :: (Expression e) => MemoDeb e -> Type -> PriorSubsts DBound (ExpTip e) +specTypesRecompute memodeb@((_,mt),_,cmn) ty + = do let (avail,t) = splitArgs ty + reorganize_ (\av -> specCases' memodeb av t) avail +-- quantify¤ÏmemoÀè¤Ç´û¤Ë¤ä¤é¤ì¤Æ¤¤¤ë¤Î¤ÇÉÔÍ× + typ <- applyPS ty + return (filtBF cmn typ $ matchFunctions memodeb typ) -- ¤³¤Î¹Ô¤Î¤ß°ã¤¦¡¥ funApSub_ :: Search m => (Type -> PriorSubsts m ()) -> (Type -> PriorSubsts m ()) -> Type -> PriorSubsts m () @@ -235,7 +259,7 @@ -- specCases' trie prims@(primgen,primmono) avail reqret = msum (map (retMono.fromPrim) primmono) `mplus` msum (map retMono fromAvail ++ map retGen primgen) specCases' memodeb@((ttrie,etrie), (prims@(primgen,primmono),_),cmn) avail reqret - = msum (map retPrimMono primmono ++ map retMono avail ++ map retGen primgen) + = mapSum retPrimMono primmono `mplus` msum (map retMono avail) `mplus` mapSum retGen primgen where fas | constrL $ opt cmn = funApSub_ lltbehalf behalf | otherwise = funApSub_spec behalf where behalf = specializedCases memodeb avail @@ -266,14 +290,18 @@ type Generator m e = MemoDeb e -> [Type] -> Type -> PriorSubsts m [e] unifyableExprs :: Expression e => Generator DBound e -unifyableExprs memodeb avails ty = convertPS fromRc $ unifyableExprs' memodeb avails ty -unifyableExprs' :: Expression e => Generator Recomp e -unifyableExprs' memodeb = applyDo (wind (fmap (map (mapCE Lambda))) (lookupNormalized (lookupTypeTrie memodeb))) +unifyableExprs memodeb = applyDo (wind (fmap (map (mapCE Lambda))) (lookupNormalized (lookupTypeTrie memodeb))) +-- memocondexp d = True +memocondexp d = 0 MemoDeb e -> Type -> Recomp ([e], Subst, Int) -lookupTypeTrie ((mt,_), _, _) t - = toRc $ lmtty mt t +lookupTypeTrie :: Expression e => MemoDeb e -> Type -> DBound ([e], Subst, Int) +lookupTypeTrie memodeb@((mt,_), _, _) t + = DB $ \db -> let Mx tss | memocondexp db = lmtty mt t + | otherwise = freezePS t $ specTypesRecompute memodeb t + in let ts = tss !! db in concat [ zipWith (\depth ys -> ((ys, s, i), db-depth)) [0..db] yss | (Mx yss, s, i) <- ts ] +-- in DB $ \db -> let ts = tss !! db in [ ((yss!!depth, s, i), db-depth) | depth <- [0..db], (Mx yss, s, i) <- ts ] -- same as the above (but maybe a little less efficient). +-- in DB $ \db -> concat $ zipWith (\depth ts -> map (\(Mx yss, s, i) -> ((yss!!depth, s, i), db-depth)) ts) [0..db] tss -- cumulative in type. This would be necessary if TypeTrie were not cumulative, but actually TypeTrie is. lookupNormalized :: MonadPlus m => (Type -> m (e, Subst, Int)) -> [Type] -> Type -> PriorSubsts m e @@ -307,10 +335,10 @@ lenavails = length avail -- fe :: Type -> Type -> [CoreExpr] -> [CoreExpr] -- ^ heuristic filtration fe = filtExprs (guess $ opt cmn) - in fromAssumptions (PGSF md) lenavails behalf matchPS reqret avail `mplus` - msum (map (retPrimMono (PGSF md) lenavails lltbehalf behalf matchPS reqret) primmono - ++ map (( if tv0 $ opt cmn then retGenTV0 else - if tv1 $ opt cmn then retGenTV1 else retGenOrd) (PGSF md) lenavails fe lltbehalf behalf reqret) primgen) + in fromAssumptions (PGSF md) lenavails behalf (\a b -> guard $ a==b) reqret avail `mplus` + mapSum (retPrimMono (PGSF md) lenavails lltbehalf behalf matchPS reqret) primmono `mplus` + mapSum (( if tv0 $ opt cmn then retGenTV0 else + if tv1 $ opt cmn then retGenTV1 else retGenOrd) (PGSF md) lenavails fe lltbehalf behalf reqret) primgen lookupListrie :: (Search m, Expression e) => Int -> Generator m e -> Generator m e lookupListrie lenavails rec memodeb@(_,_,cmn) avail t @@ -320,7 +348,11 @@ let args' = filter (not.isClosed.toCE) args when (null args') mzero return args' - | otherwise = rec memodeb avail t + | otherwise = do + args <- rec memodeb avail t + let args' = filter (not.isConstrExpr.toCE) args + when (null args') mzero + return args' where opts = opt cmn filtExprs :: Expression e => Bool -> Type -> Type -> [e] -> [e] filtExprs g a b | g = filterExprs a b diff --git a/MagicHaskeller/ProgramGenerator.lhs b/MagicHaskeller/ProgramGenerator.lhs --- a/MagicHaskeller/ProgramGenerator.lhs +++ b/MagicHaskeller/ProgramGenerator.lhs @@ -35,15 +35,15 @@ -- replacement of LISTENER. Now replaced further with |guess| -- listen = False - +-- | annotated 'Typed [CoreExpr]' type Prim = (Int, Type, Int, Typed [CoreExpr]) -- | ProgramGenerator is a generalization of the old @Memo@ type. class ProgramGenerator a where -- | |mkTrie| creates the generator with the default parameters. - mkTrie :: Common -> [Typed [CoreExpr]] -> a + mkTrie :: Common -> [[Typed [CoreExpr]]] -> a mkTrie cmn t = mkTrieOpt cmn t t - mkTrieOpt :: Common -> [Typed [CoreExpr]] -> [Typed [CoreExpr]] -> a + mkTrieOpt :: Common -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]] -> a mkTrieOpt cmn _ t = mkTrie cmn t -- error "This program generator does not take an optional primitive set." matchingPrograms, unifyingPrograms :: Search m => Type -> a -> m AnnExpr @@ -72,15 +72,33 @@ 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] +type Options = Opt [[Primitive]] retsTVar (_, TV tv, _, _) = True retsTVar _ = False +annotateTCEs :: Typed [CoreExpr] -> Prim +annotateTCEs tx@(_:::t) = (getArity t, getRet t, maxVarID t + 1, tx) + splitPrims :: [Typed [CoreExpr]] -> ([Prim],[Prim]) -splitPrims = partition retsTVar . map (\ tx@(_:::t) -> (getArity t, getRet t, maxVarID t + 1, tx)) . mergesortWithBy (\(x:::t) (y:::_) -> (x++y):::t) (\(_:::t) (_:::u) -> compare t u) +splitPrims = partition retsTVar . map annotateTCEs +splitPrimss :: [[Typed [CoreExpr]]] -> ([[Prim]],[[Prim]]) +splitPrimss = unzip . map splitPrims +{- +splitPrimss :: Search m => [[Typed [CoreExpr]]] -> (m Prim, m Prim) +splitPrimss pss = case unzip $ map splitPrims pss of (pssf, psss) -> (fromMx $ Mx pssf, fromMx $ Mx psss) +-} + +mapSum :: (MonadPlus m, Delay m) => (a -> m b) -> [[a]] -> m b +mapSum f = foldr (\xs y -> msum (map f xs) `mplus` delay y) mzero + + +-- avail$B$K$7$m(BType$B$K$7$m(Bapply$B$5$l$F$$$k!%(B +-- $B$@$+$i$3$=!$(BrunAnotherPS$BE*$K(BemptySubst$B$KBP$7$F ([Type] -> Type -> PriorSubsts m a) -> [Type] -> Type -> PriorSubsts m a applyDo fun avail ty = do subst <- getSubst fun (map (apply subst) avail) (apply subst ty) @@ -102,7 +120,7 @@ = do let (es, (arity,args,retty)) = fromBlah tok retty convertPS (ndelay arity) $ - fap behalf args (map (fromCE (reducer pg) lenavails arity) es) + fap behalf args (map (mkHead (reducer pg) lenavails arity) es) fromAvail :: [Type] -> [([CoreExpr], (Int,[Type],Type))] fromAvail = zipWith (\ n t -> ([X n], revSplitArgs t)) [0..] @@ -117,7 +135,7 @@ matchAssumptions pg lenavails reqty assumptions = do s <- getSubst let newty = apply s reqty - msum $ zipWith (\n t -> matchPS newty t >> return [fromCE (reducer pg) lenavails (getArity newty) (X n)]) [0..] assumptions + msum $ zipWith (\n t -> matchPS newty t >> return [mkHead (reducer pg) lenavails (getArity newty) (X n)]) [0..] assumptions -- match $B$N>l9g!$DL>o$O(Breqty$B$NJ}$@$1(Bapply subst$B$9$l$P$h$$!%(B -- not sure if this is more efficient than doing mguAssumptions and returning (). @@ -131,7 +149,7 @@ = do tvid <- reserveTVars numtvs mps (mapTV (tvid+) retty) reqret convertPS (ndelay arity) $ - funApSub lltbehalf behalf (mapTV (tvid+) ty) (map (fromCE (reducer pg) lenavails arity) xs) + funApSub lltbehalf behalf (mapTV (tvid+) ty) (map (mkHead (reducer pg) lenavails arity) xs) funApSub :: (Search m, Expression e) => (Type -> PriorSubsts m [e]) -> (Type -> PriorSubsts m [e]) -> Type -> [e] -> PriorSubsts m [e] funApSub = funApSubOp (<$>) funApSubOp op lltbehalf behalf (t:> ts) funs = do args <- lltbehalf t @@ -177,7 +195,7 @@ -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTV$B$H(Bapply$B$O(Bhylo-fusion$B$G$-$k$O$:$@$,!$>!!! SplicedPrims -- ^ target I/O pairs -> SplicedPrims -- ^ I/O pairs for background knowledge functions -> (a -> Bool) -- ^ test function -> IO () -quickStartC tgt bk pred = do session <- prepareAPI [] +quickStartC tgt bk pred = do session <- prepare tss <- getFilt session tgt bk pred pprs tss quickStartCF :: (Filtrable a, Typeable a) => @@ -64,7 +66,7 @@ -> SplicedPrims -- ^ I/O pairs for background knowledge functions -> (a -> Bool) -- ^ test function -> IO () -quickStartCF tgt bk pred = do session <- prepareAPI [] +quickStartCF tgt bk pred = do session <- prepare tss <- getFiltF session tgt bk pred pprs tss filterGet1_ :: (Typeable a) => @@ -138,7 +140,7 @@ -> Q [Dec] -- ^ I/O pairs for background knowledge functions -> (a -> Bool) -- ^ test function -> IO () -quickStart iops bk pred = do session <- prepareAPI [] +quickStart iops bk pred = do session <- prepare tss <- synthFilt session iops bk pred pprs tss quickStartF :: (Filtrable a, Typeable a) => @@ -146,11 +148,11 @@ -> Q [Dec] -- ^ I/O pairs for background knowledge functions -> (a -> Bool) -- ^ test function -> IO () -quickStartF iops bk pred = do session <- prepareAPI [] +quickStartF iops bk pred = do session <- prepare tss <- synthFiltF session iops bk pred pprs tss -batchExample = do session <- prepareAPI [] +batchExample = do session <- prepare let f = filterGetOne_ session batchWrite "example.dat" [ f [d| reverse [] = []; reverse [a] = [a]; reverse [a,b] = [b,a]; reverse [a,b,c] = [c,b,a] |] (\r -> r "abcd" == "dcba") , f [d| switch [] = []; switch [a] = [a]; switch [a,b] = [b,a]; switch [a,b,c] = [c,b,a]; switch [a,b,c,d] = [d,b,c,a]; |] (\s -> s "abcde" == "ebcda") diff --git a/MagicHaskeller/ShortString.hs b/MagicHaskeller/ShortString.hs --- a/MagicHaskeller/ShortString.hs +++ b/MagicHaskeller/ShortString.hs @@ -10,6 +10,11 @@ -- LC.cons' ¤À¤È¿ʬ¥À¥á +showBriefly :: ShortString a => a -> LC.ByteString +showBriefly = flip showsBriefly LC.empty +readBriefly :: ShortString a => C.ByteString -> Maybe a +readBriefly = fmap fst . readsBriefly + class ShortString a where showsBriefly :: a -> LC.ByteString -> LC.ByteString readsBriefly :: C.ByteString -> Maybe (a,C.ByteString) -- ReadS a -- Maybe ¤ÎÊý¤¬Â®¤¤? ¤Æ¤æ¡¼¤«¡¤parse error¤Î³ä¹ç¤Ï¤¹¤´¤¯¾¯¤Ê¤¤¤Ï¤º¤Ê¤Î¤Çerror¤È¤·¤Æcatch¤·¤¿Êý¤¬Â®¤¤¤Ï¤º¡¥¤È»×¤Ã¤¿¤±¤É¡¤lazy¤Ê¥Ç¡¼¥¿¤Ê¤Î¤ÇÀµ¤·¤¯catch¤Ç¤­¤Ê¤¤¤«¡¥ @@ -22,10 +27,13 @@ _ -> do (x, ds) <- readsBriefly cs (xs,es) <- readsBriefly ds return (x:xs, es) +instance ShortString Bool where + showsBriefly True = LC.cons 'T' + showsBriefly False = LC.cons 'F' instance ShortString CoreExpr where showsBriefly (Lambda ce) = (LC.cons '\\') . showsBriefly ce showsBriefly (X i) = (LC.cons 'X') . showsBriefly i - showsBriefly (Primitive i) = (LC.cons 'P') . showsBriefly i + showsBriefly (Primitive i b) = (LC.cons 'P') . showsBriefly i . showsBriefly b showsBriefly (c :$ e) = (LC.cons '$') . showsBriefly c . showsBriefly e readsBriefly cs = case C.uncons cs of -- Int(Nat)¤È1ʸ»ú¤á°ì½ï¤Ë1¥Ð¥¤¥È¤Ë¤Ç¤­¤Ê¤¤¤«?¤¢¤È¡¤lambda¤Ï³¤¯¤Î¤Ç¤Þ¤È¤á¤é¤ì¤½¤¦¡¥ Just ('\\',xs) -> do (ce,ys) <- readsBriefly xs @@ -33,7 +41,8 @@ Just ('X', xs) -> do (i, ys) <- readsBriefly xs return (X i, ys) Just ('P', xs) -> do (i, ys) <- readsBriefly xs - return (Primitive i, ys) + (b, zs) <- readsBriefly ys + return (Primitive i b, zs) Just ('$', xs) -> do (c, ys) <- readsBriefly xs (e, zs) <- readsBriefly ys return (c :$ e, zs) diff --git a/MagicHaskeller/TimeOut.hs b/MagicHaskeller/TimeOut.hs --- a/MagicHaskeller/TimeOut.hs +++ b/MagicHaskeller/TimeOut.hs @@ -1,6 +1,7 @@ -- -- (c) Susumu Katayama -- +{-# LANGUAGE CPP #-} module MagicHaskeller.TimeOut where import Control.Concurrent(forkIO, killThread, myThreadId, ThreadId, threadDelay, yield) @@ -36,7 +37,7 @@ #endif unsafeWithPTO :: Maybe Int -> a -> Maybe a -#ifdef CHTO +-- x #ifdef CHTO unsafeWithPTO pto a = unsafePerformIO $ wrapExecution ( maybeWithTO seq pto (return a) ) @@ -44,14 +45,15 @@ -> Maybe Int -> IO a -> IO (Maybe a) maybeWithTO sq mbt action = maybeWithTO' sq mbt (const action) newPTO t = return t -#else +{- x +-- x #else unsafeWithPTO _ = Just maybeWithTO :: c -> b -> IO a -> IO (Maybe a) maybeWithTO _ _ action = do a <- action return (Just a) newPTO = error "not implemented on this platform." -#endif - +-- x #endif +-} unsafeOpWithPTO :: Maybe Int -> (a->b->c) -> a -> b -> Maybe c unsafeOpWithPTO mto op l r = unsafeWithPTO mto (op l r)