MagicHaskeller (empty) → 0.8.5
raw patch · 34 files changed
+6168/−0 lines, 34 filesdep +arraydep +basedep +containerssetup-changed
Dependencies added: array, base, containers, random, template-haskell
Files
- Control/Monad/Search/Combinatorial.lhs +414/−0
- Data/Memo.hs +218/−0
- LICENSE +25/−0
- MagicHaskeller.cabal +26/−0
- MagicHaskeller.lhs +609/−0
- MagicHaskeller/Classification.hs +268/−0
- MagicHaskeller/Classify.hs +322/−0
- MagicHaskeller/ClassifyDM.hs +125/−0
- MagicHaskeller/ClassifyTr.hs +103/−0
- MagicHaskeller/Combinators.hs +12/−0
- MagicHaskeller/CoreLang.lhs +124/−0
- MagicHaskeller/DebMT.lhs +88/−0
- MagicHaskeller/Execute.hs +70/−0
- MagicHaskeller/ExprStaged.hs +164/−0
- MagicHaskeller/Expression.hs +193/−0
- MagicHaskeller/FakeDynamic.hs +57/−0
- MagicHaskeller/Instantiate.hs +401/−0
- MagicHaskeller/LibTH.hs +168/−0
- MagicHaskeller/MHTH.lhs +127/−0
- MagicHaskeller/MyCheck.hs +233/−0
- MagicHaskeller/MyDynamic.hs +39/−0
- MagicHaskeller/PriorSubsts.lhs +174/−0
- MagicHaskeller/ProgGen.lhs +175/−0
- MagicHaskeller/ProgGenSF.lhs +349/−0
- MagicHaskeller/ProgGenXF.lhs +343/−0
- MagicHaskeller/ProgramGenerator.lhs +518/−0
- MagicHaskeller/ReadDynamic.hs +22/−0
- MagicHaskeller/ReadTHType.lhs +82/−0
- MagicHaskeller/ReadTypeRep.hs +69/−0
- MagicHaskeller/T10.hs +99/−0
- MagicHaskeller/TimeOut.hs +94/−0
- MagicHaskeller/TyConLib.hs +68/−0
- MagicHaskeller/Types.lhs +384/−0
- Setup.hs +5/−0
+ Control/Monad/Search/Combinatorial.lhs view
@@ -0,0 +1,414 @@+-- +-- (c) Susumu Katayama 2009+--+Combinators for Combinatorial Search:+The first part is a slight hack on Spivey 2000.+The second part is my (Susumu's) original which by recomputation refrains producing thunks.+The third part defines DBound, found in Spivey 2006.++\begin{code}+{-# 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+import Control.Monad -- hiding (join) -- ... but still collided when using Hat.+#ifdef HOOD+import Observe+#endif+import Data.Monoid -- Matrix, and any (MonadPlus a) => a, should be a Monoid.++#ifdef QUICKCHECK+import Test.QuickCheck+import Data.List(sort)+#endif+import MagicHaskeller.T10(mergesortWithBy, mergesortWithByBot)++import Data.Array++-- import AList -- append list used as the Bag++-- instance (MonadPlus m) => Monoid (m a) where+instance Monoid (Matrix a) where+ mempty = mzero+ mappend = mplus+instance Monoid (Recomp a) where+ mempty = mzero+ mappend = mplus+instance Monad m => Monoid (RecompT m a) where+ mempty = mzero+ mappend = mplus++type Stream a = [a]++{-+type Bag a = AList a+cat = concatAL+toList = flattenAL+-}+type Bag a = [a]+cat = concat+toList = id++#ifdef QUICKCHECK+newtype Matrix a = Mx {unMx::Stream (Bag a)}+instance Show a => Show (Matrix a) where+ showsPrec _ (Mx xss) = ("Mx {unMx = "++) . shows (take 10 xss) . (" ...}"++)-- because we do not like to show infinite lists+#else+newtype Matrix a = Mx {unMx::Stream (Bag a)} deriving Show+#endif+#ifdef HOOD+instance Observable a => Observable (Matrix a) where+ observer (Mx a) = send "Mx" (return Mx << a)+#endif+instance Monad Matrix where+ return x = Mx (return x : nils)+ Mx x >>= f = Mx (jOIN (map (fmap (unMx.f)) x))+instance MonadPlus Matrix where+ mzero = Mx nils+ Mx xm `mplus` Mx ym = Mx (zipWith mappend xm ym)+nils :: Stream (Bag a)+nils = repeat mempty+p /\ q = \x -> (q x >>= p)+p \/ q = \x -> (p x `mplus` q x)+jOIN :: Stream (Bag (Stream (Bag a))) -> Stream (Bag a)+jOIN = map (cat.cat) . diag . map trans+-- jOIN = map (concat.concat)+{- $B$3$C$A$N(Bjoin$B$K$9$k$H!"(BHatMain$B$r(BGHC -O0$B$G$d$C$?$d$D$O(B+Reading the Library...done.+[<Main.main,Main.CAF><Main.main,Main.CAF><Search.jOIN,Search.CAF>Stack space overflow: current size 1048576 bytes.+$B$H$J$C$?!#(BStack overflow$B$OM}O@>eEvA3!J(BSpivey$B$b=q$$$F$k!K$@$,!"$J$s$G(BCAF$B$J$N!)(B $B$I$3$K(BCAF$B$,$"$k$s$8$c!)(B ...mzero$B$+!)!*!*(B+$B$^$"!"(BCAF$B$C$F$3$H$J$i(BGHC$B$H(BNHC$B$GF0:n$,0c$&$N$b$&$J$:$1$k$,!#!J(BNHC$B$@$H(BCAF$B$O4X?t07$$$@$C$?$H;W$&!#FCDj$N(BCAF$B$@$1$@$C$?$+$b!#!K(B+-}+diag :: Stream (Stream a) -> Stream (Bag a)+diag ((x:xs):xss) = return x : zipWith cons xs (diag xss)++cons a b = return a `mappend` b++trans :: Bag (Stream a) -> Stream (Bag a)+trans xss = fmap head xss : trans (fmap tail xss)+-- Actually I am not sure why this definition is better than "trans = foldr (zipWith (:)) (repeat [])"....+-- (but the correction really worked in the profiling result.)++-- not sure if this is really needed.+instance Functor Matrix where+ fmap f (Mx xss) = Mx (map (fmap f) xss)++instance Functor Recomp where+ fmap f (Rc xss) = Rc (\d -> fmap f (xss d))+instance Functor DBound where+ 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)++-- should be slightly more efficient than msum+msumMx xs = Mx (xs : nils)+-- msumRc xs = Rc (const xs) $B4V0c$$(B+msumRc = listToRc+listToRc l = Rc f where f 0 = l+ f _ = mempty++{-+-- m is usually IO or ST s+accumulate :: Monad m => Matrix (m a) -> m (Matrix a)+accumulate (Mx xss) = fmap Mx (sequence (sequence xss))+-}+\end{code}++\begin{code}+type DepthFst = [] -- ghc6.8 does not like "type DepthFst = Stream"+newtype Recomp a = Rc {unRc::Int->Bag a}+newtype RecompT m a = RcT {unRcT::Int -> m (Bag a)}+instance Monad Recomp where+ return x = Rc f where f 0 = return x+ f _ = mempty+ Rc f >>= g = Rc ( \n -> mconcat $ map (\i -> cat $ fmap (\a -> unRc (g a) (n-i)) (f i)) [0..n] )+-- Rc f >>= g = Rc (\n -> [ y | i <- [0..n], x <- f i, y <- unRc (g x) (n-i) ]) -- Bag a = [a]$B$N>l9g!%(B+-- Rc f >>= g = Rc (\n -> concat $ map (\i -> concat $ map (\a -> unRc (g a) (n-i)) (f i)) [0..n]) -- STRecomp$B$KAjEv$9$k=q$-J}!%$H$/$KCY$/$O$J$i$J$$(B....+instance Monad m => Monad (RecompT m) where+ return x = RcT f where f 0 = return [x]+ f _ = return []+ RcT f >>= g = RcT ( \n -> let+ hoge i = do xs <- f i+ xss <- mapM (\x -> unRcT (g x) (n-i)) xs+ return (concat xss)+ in do xss <- mapM hoge [0..n]+ return $ concat xss)++instance MonadPlus Recomp where+ mzero = Rc (const mempty)+ Rc f `mplus` Rc g = Rc (\i -> f i `mappend` g i)+instance Monad m => MonadPlus (RecompT m) where+ mzero = RcT (const $ return [])+ RcT f `mplus` RcT g = RcT (\i -> do xs <- f i -- f i $B$H(B g i$B$NN>J}$r<B9T$9$k$3$H$K$J$k$1$I!$(BIO$B$G;H$&>e$G4V0c$C$F$O$$$J$$!%(B+ ys <- g i+ return (xs++ys))++rcToMx :: Recomp a -> Matrix a+rcToMx (Rc f) = Mx (map f [0..])+{-+rcToMx (Rc f) = Mx (go 0)+ where go n = f n : go (n+1)+-}++mxToRc :: Matrix a -> Recomp a+mxToRc (Mx s) = Rc (s!!)++consMx :: Bag a -> Matrix a -> Matrix a+consMx xs (Mx xss) = Mx (xs : xss)++consRc :: Bag a -> Recomp a -> Recomp a+consRc xs (Rc f) = Rc g where g 0 = xs+ g n = f (n-1)++{-+-- mapDepth$B$,$"$l$P!$Dj5A$9$kI,MW$O$J$$!%(B+-- filterMx f (Mx xss) = Mx (map (filter f) xss)+filterMx f = mapDepth (filter f)+-}+++mapDepthDB :: (Bag (a,Int) -> Bag (b,Int)) -> DBound a -> DBound b+mapDepthDB f (DB g) = DB (f.g)++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$&<BAu(B NB: This is confusing.+zipDepthDB :: (Int -> 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)++zipDepth3Rc :: (Int -> Bag a -> Bag b -> Bag c) -> Recomp a -> Recomp b -> Recomp c+zipDepth3Rc f (Rc g) (Rc h) = Rc (\d -> f d (g d) (h d))++printMx (Mx xss) = pmx 0 xss+ where pmx n (xs:xss) = do putStrLn ("\ndepth = " ++ show n)+ mapM_ print (toList xs)+ pmx (n+1) xss+ pmx n [] = return ()+printNMx n (Mx xss) = printMx (Mx (take n xss))++-- join (liftM2 mtf mtx)$B$h$j$b(Bstrict+zipWithBF :: Monad m => (a -> b -> m c) -> m a -> m b -> m c+zipWithBF f xss yss = do x <- xss+ y <- yss+ (f $! x) $! y++scanl1BF :: Search m => m x -> m x+scanl1BF bf = bf `mplus` delay (scanl1BF bf)++scanlRc :: (Bag a -> Bag b -> Bag a) -> Bag a -> Recomp b -> Recomp a+scanlRc f xs rc = result where result = xs `consRc` zipDepth3Rc (\_ -> f) result rc++getDepth :: Recomp Int+getDepth = Rc (\d -> [d])++-- making delay apart to implement zipWithConsFMT.+class Delay m where+ delay :: m a -> m a+ delay = ndelay 1+ ndelay :: Int -> m a -> m a+ ndelay n x = iterate delay x !! n+instance Delay DepthFst where+ delay = id+ ndelay _ = id+instance Delay Recomp where+ delay (Rc f) = Rc g where g 0 = mempty+ g n = f (n-1)+ ndelay i (Rc f) = Rc g where g n | n < i = mempty+ | otherwise = f (n-i)+instance Delay Matrix where+ delay (Mx xm) = Mx (mempty:xm)+ ndelay 0 mx = mx+ ndelay i mx = delay $ ndelay (i-1) mx+instance Monad m => Delay (RecompT m) where+ delay (RcT f) = RcT g where g 0 = return mempty+ g n = f (n-1)+ ndelay i (RcT f) = RcT g where g n | n < i = return mempty+ | otherwise = f (n-i)++class (Delay m, MonadPlus m, Functor m) => Search m where+ fromRc :: Recomp a -> m a+ toRc :: m a -> Recomp a+ fromMx :: Matrix a -> m a+ toMx :: m a -> Matrix a+ fromDB :: DBound a -> m a+ -- | 'mapDepth' applies a function to the bag at each depth. + mapDepth :: (Bag a -> Bag b) -> m a -> m b+ -- | 'catBags' flattens each bag.+ catBags :: m (Bag a) -> m a+ catBags = mapDepth concat+ -- | 'mergesortDepthWithBy' converts bags to sets, by (possibly sorting each bag and) removing duplicates.+ -- Efficiency on lists with lots of duplicates is required.+ mergesortDepthWithBy :: (k->k->k) -- ^ Combiner, which is used when there are equivalent elements (compared by the comparer specified by the next argument).+ -- The return value of this combiner should also be equivalent to the two arguments.+ -> (k->k->Ordering) -- ^ Comparer+ -> m k -> m k+ mergesortDepthWithBy combiner comp = mapDepth (mergesortWithBy combiner comp)+ ifDepth :: (Int->Bool) -> m a -> m a -> m a+instance Search DepthFst where+ fromRc = fromMx . toMx+ toRc = listToRc+ fromMx = concat . unMx+ toMx = msumMx+ fromDB (DB f) = [x | d <- [0..], (x,_) <- f d ]+ mapDepth f = concat . map (f . (:[])) -- mapDepth /= id, because DepthFst is not a finite Bag but an infinite Stream.+ catBags = concat+ mergesortDepthWithBy _ _ = id+ ifDepth _ t _ = t+instance Search Recomp where+ fromRc = id+ toRc = id+ fromMx = mxToRc+ toMx = rcToMx+ fromDB = toRc+ mapDepth f (Rc g) = Rc (f.g)+ ifDepth pred (Rc t) (Rc f) = Rc fun+ where fun depth | pred depth = t depth+ | otherwise = f depth++instance (Functor m, Monad m) => Search (RecompT m) where+ fromRc (Rc f) = RcT (return . f)+ toRc = error "no toRc for RecompT"+ fromMx = fromRc . mxToRc+ toMx = error "no toMx for RecompT"+ fromDB = fromRc . toRc+ mapDepth f (RcT g) = RcT (\x -> fmap f (g x))+ ifDepth pred (RcT t) (RcT f) = RcT fun+ where fun depth | pred depth = t depth+ | otherwise = f depth++instance Search Matrix where+ fromRc = rcToMx+ toRc = mxToRc+ fromMx = id+ toMx = id+ fromDB = toMx+ mapDepth f (Mx xss) = Mx (map f xss)+ ifDepth pred (Mx ts) (Mx fs) = Mx $ zipWith3 chooser [0..] ts fs+ where chooser depth t f | pred depth = t+ | otherwise = f++#ifdef QUICKCHECK+instance Arbitrary a => Arbitrary (Matrix a) where+ arbitrary = liftM fromRc arbitrary -- Converting from Recomp makes sure that the outer list is infinite. +instance Arbitrary a => Arbitrary (Recomp a) where+ arbitrary = liftM Rc arbitrary+instance Arbitrary a => Arbitrary (DBound a) where+-- arbitrary = liftM fromRc arbitrary+ arbitrary = liftM fromRc arbitrary+-- Having only one of the above two is not enough to test the converter (like fromRc) used here!+-- |arbitrary = liftM DB arbitrary| is not enough, because the annotated Int cannot be greater than the argument Int.+#endif++instance Show (Recomp a) where+ showsPrec _ _ = ("<Recomp>"++)+instance Show (DBound a) where+ showsPrec _ _ = ("<DBound>"++)++\end{code}++\begin{code}+-- a$B$O$"$i$+$8$a(Bannotate$B$7$?$b$N$rMQ$$$k(B+categorizeDB :: DBound a -> Int -> Array Int [a]+categorizeDB (DB f) b = categorize b $ f b -- $B$3$NJU$OITMW(B+categorize b ts = accumArray (flip (:)) [] (0,b) $ map swap ts+uncategorizeDB :: (Int -> Array Int [a]) -> DBound a+uncategorizeDB f = DB $ \b -> uncategorize (f b) -- $B$3$l$bITMW(B+uncategorize ar = [ (x,i) | (i,xs) <- assocs ar, x <- xs ]++-- | shrinkDB can be used instead of mergesortDepthWithBy when you want to shrink each depth in different ways using different annotations.+shrinkDB :: (k->k->k) -> (k -> k -> Maybe Ordering) -> DBound k -> DBound k+shrinkDB combiner comparer = zipDepthDB $ shrink combiner comparer -- $B$3$l$bITMW(B+shrink combiner comparer = \b ts -> uncategorize $ fmap (mergesortWithByBot combiner comparer) $ categorize b ts++{- $B85!9$3$C$A$GDj5A$7$F$?$1$I!$(BzipDepthDB$B$r;H$C$?J}$,NI$5$=$&$J$N$G!%(B+-- a$B$O$"$i$+$8$a(Bannotate$B$7$?$b$N$rMQ$$$k(B+categorizeDB :: DBound a -> Int -> Array Int [a]+categorizeDB (DB f) b = accumArray (flip (:)) [] (0,b) $ map swap $ f b+uncategorizeDB :: (Int -> Array Int [a]) -> DBound a+uncategorizeDB f = DB $ \b -> [ (x,i) | (i,xs) <- assocs (f b), x <- xs ]++-- | shrinkDB can be used instead of mergesortDepthWithBy when you want to shrink each depth in different ways using different annotations.+shrinkDB :: (k->k->k) -> (k -> k -> Maybe Ordering) -> DBound k -> DBound k+-- shrinkDB combiner comparer db = uncategorizeDB (fmap (mergesortWithByBot combiner comparer) . categorizeDB db)+shrinkDB combiner comparer = uncategorizeDB . (.) (fmap (mergesortWithByBot combiner comparer)) . categorizeDB+-- Control.Monad.Instances$B$K(Binstance Functor (a->) where fmap = (.) $B$,Dj5A$5$l$F$$$k!%$I$C$A$G$b$$$$$O$:$@$1$I!$2<$NJ}$,e:No$+$J$H!%(B+-}++swap (b,x) = (x,b)++newtype DBound a = DB {unDB :: Int -> 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 MonadPlus DBound where+ mzero = DB $ \_ -> []+ DB p1 `mplus` DB p2 = DB $ \n -> 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<i then [] else p (n-i)+instance Search DBound where+ toRc (DB p) = Rc $ \n -> [ x | (x,0) <- p n ]+ fromRc (Rc p) = DB $ \n -> [ (x,n-m) | m <- [0..n], x <- p m ]+-- $B0J2<$N(B3$B$D$O8zN($bJQ$o$i$J$$$O$:!%(B($B@5$7$/F0$/$3$H$O(BquickCheck$B:Q$_(B)$B2<$N(B2$B$D$N%a%j%C%H$O(BRecomp$B$,$$$i$J$$!J$N$GO@J8$K:\$;$k>e$G(BRecomp$B$r>JN,$G$-$k!K$3$H!%??$sCf$h$j2<$,$$$$$N$OC1$KJ8;z?t$@$1!%(B+ -- toMx = toMx . toRc+ -- toMx (DB p) = Mx $ map (\n -> [ x | (x,0) <- p n ]) [0..]+ toMx (DB p) = Mx [ [ x | (x,0) <- p n ] | n <- [0..] ]+ fromMx (Mx xss) = DB $ \n -> concat $ zipWith (\r xs -> map (\x->(x,r)) xs) [n,n-1..0] xss+ fromDB = id+ mapDepth f (DB g) = DB $ \d -> case unzip $ g d of (xs, is) -> zip (f xs) is+ catBags (DB f) = DB (\d -> [ (x,i) | (xs,i) <- f d, x <- xs ])+ mergesortDepthWithBy combiner rel = mapDepthDB (mergesortWithBy (\ (k,i) (l,_) -> (combiner k l, i))+ (\ (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+#ifdef QUICKCHECK+-- 0$B$+$i$+(B1$B$+$i$+$G$d$d$3$7$$$N$G!$0l1~(BquickCheck$B$7$F$*$/$Y$7!%(B+prop_fromMxToMx, prop_fromRcToRc :: DBound Int -> Int -> Property+prop_fromMxToMx = \db d -> d>=0 ==> sort (unDB (fromMx (toMx db)) d) == sort (unDB db d) -- passed 100 tests+prop_fromRcToRc = \db d -> d>=0 ==> sort (unDB (fromRc (toRc db)) d) == sort (unDB db d) -- passed 100 tests++prop_toMxFromMx = \mx d -> (d>=0 && length (unMx mx) >= d) ==> take d (map sort (unMx (toMx (fromMx mx :: DBound Int)))) == take d (map sort (unMx mx)) -- passed 100 tests+prop_toRcFromRc = \rc d -> d>=0 ==> sort (unRc (toRc (fromRc rc :: DBound Int)) d) == sort (unRc rc d) -- passed 100 tests+#endif++-- Dunno if "Memoable" is a correct English. Or maybe I should use IsMemoOf?+class (Search n) => Memoable m n where -- $B$J$s$+(Bm$B$r(Bmonad$B$K$9$k$N$,LLE]$K$J$C$F$-$?$C$F$$$&$+!$$=$NI,MW$J$$$G$7$g!%(B+ tabulate :: n a -> m a+ applyMemo :: m a -> n a+instance Memoable Matrix Recomp where+ tabulate (Rc f) = Mx $ map f [0..]+ applyMemo (Mx xss) = Rc (xss!!)+instance Memoable DBMemo DBound where+ tabulate (DB f) = DBM $ map f [0..]+ applyMemo (DBM xss) = DB (xss!!)++newtype DBMemo a = DBM {unDBM :: Stream (Bag (a,Int))}+{-+instance Monad DBMemo where+ return x = tabulate $ return x -- $B%3%s%Q%$%kDL$k(B?+ -- = DBM $ map (\n->[(x,n)]) [0..]+ DBM p >>= f = DBM $ +-}+++\end{code}++\begin{code}+test'' = mconcat (unMx test')+test' = do x <- Mx [return x | x<-[1..]]+ y <- Mx [return y | y<-[1..]]+ guard (x*y==30)+ return (x,y)++main = print test''+\end{code}
+ Data/Memo.hs view
@@ -0,0 +1,218 @@+-- +-- (c) Susumu Katayama 2009+--+{-# OPTIONS -fglasgow-exts -cpp #-}+module Data.Memo where+import Data.Char(ord,chr)+import Data.Bits+import Data.Array++import Data.List(sort) -- just for testing the efficiency++import Language.Haskell.TH++-- This could be a separate module.+#if QUICKCHECK>=2+import Test.QuickCheck.Function+#endif+#ifdef QUICKCHECK+import Test.QuickCheck+#else+infixr 0 ==>+type Property = Bool+(==>) = (<=)+#endif+#if QUICKCHECK>=2+#else+type Function = (->)+getFunction = id+#endif++newtype MapUnit a = MU a -- equivalent to Control.Monad.Identity.Identity+memoUnit :: (() -> a) -> MapUnit a+memoUnit f = MU (f ())+appUnit :: MapUnit a -> (()->a)+appUnit (MU x) _ = x -- Should I write () instead of _ to make it strict?++data MapBool a = MB a a+memoBool :: (Bool->a) -> MapBool a+memoBool f = MB (f False) (f True)+appBool :: MapBool a -> (Bool -> a)+appBool (MB f t) False = f+appBool (MB f t) True = t++prop_inverseBool :: Bool -> Function Bool Int -> Bool+prop_inverseBool b f = appBool (memoBool (getFunction f)) b == getFunction f b++data MapOrdering a = MO a a a+memoOrdering :: (Ordering->a) -> MapOrdering a+memoOrdering f = MO (f LT) (f EQ) (f GT)+appOrdering :: MapOrdering a -> Ordering->a+appOrdering (MO l e g) LT = l+appOrdering (MO l e g) EQ = e+appOrdering (MO l e g) GT = g++data MapMaybe m a = MM a (m a)+memoMaybe :: ((b->a)->m a) -> (Maybe b -> a) -> MapMaybe m a+memoMaybe g f = MM (f Nothing) (g (\b -> f (Just b)))+appMaybe :: (m a->(b->a)) -> MapMaybe m a -> (Maybe b -> a)+appMaybe _ (MM n _) Nothing = n+appMaybe g (MM _ j) (Just x) = g j x+prop_inverseMaybe :: Maybe Ordering -> (Maybe Ordering -> Integer) -> Bool+prop_inverseMaybe mb f = appMaybe appOrdering (memoMaybe memoOrdering f) mb == f mb++data MapEither m n a = ME (m a) (n a)+memoEither :: ((b->a) -> m a) -> ((d->a) -> n a) -> (Either b d -> a) -> MapEither m n a+memoEither g h f = ME (g (\b -> f (Left b))) (h (\d -> f (Right d)))+appEither :: (m a -> (b->a)) -> (n a -> (d->a)) -> MapEither m n a -> (Either b d -> a)+appEither g _ (ME l _) (Left x) = g l x+appEither _ h (ME _ r) (Right x) = h r x+prop_inverseEither :: Either Int [Bool] -> (Either Int [Bool] -> Integer) -> Bool+prop_inverseEither e f = appEither appIntegral (appFiniteList appBool) (memoEither memoIntegral (memoFiniteList memoBool) f) e == f e++newtype MapPair m n a = MP (m (n a))+memoPair :: (forall e. (b->e) -> m e) -> (forall f. (d->f) -> n f) -> ((b,d) -> a) -> MapPair m n a+memoPair g h f = MP $ g (\b -> h (\d -> f (b,d)))+appPair :: (forall e. m e -> (b->e)) -> (forall f. n f -> (d->f)) -> MapPair m n a -> ((b,d) -> a)+appPair g h (MP m) (x,y) = h (g m x) y++type MapTriplet l m n = MapPair (MapPair l m) n+memoTriplet :: (forall e. (b->e) -> l e) ->+ (forall e. (c->e) -> m e) ->+ (forall e. (d->e) -> n e) -> ((b,c,d) -> a) -> MapTriplet l m n a+memoTriplet g h i f = memoPair (memoPair g h) i (\((x,y),z) -> f (x,y,z))+appTriplet :: (forall e. l e -> (b->e)) -> (forall e. m e -> (c->e)) -> (forall e. n e -> (d->e)) -> MapTriplet l m n a -> ((b,c,d) -> a)+appTriplet g h i m (x,y,z) = appPair (appPair g h) i m ((x,y),z)+prop_inverseTriplet :: (Int,[Bool],[Int]) -> ((Int,[Bool],[Int]) -> Integer) -> Bool+prop_inverseTriplet t f = appTriplet appIntegral (appList 5 appBool) (appList 5 appIntegral) (memoTriplet memoIntegral (memoList memoBool) (memoList memoIntegral) f) t == f t++-- | MapList m a is a memoization of |[b]->a|, where m c is the memoization of b->c. Because we cannot memoize functions taking infinite lists (and long lists practically), functions are silently recomputed if the length if its argument list is more than the length limit.+data MapList m b a = ML (MapFiniteList m a) ([b]->a)+data MapFiniteList m a = MFL {+ nilArrow :: a,+ consArrow :: m (MapFiniteList m a)+ }+memoList :: (forall c. (b->c) -> m c) -> ([b] -> a) -> MapList m b a+memoList g f = ML (memoFiniteList g f) f+appList10 = appList 10+appList5 = appList 5+appList3 = appList 3+appList1 = appList 1+appList :: Int -- ^ length limit+ -> (forall c. m c -> (b->c)) -> MapList m b a -> ([b]->a)+appList lenlim g (ML m f) xs | xs `isLongerThan` lenlim = f xs+ | otherwise = appFiniteList g m xs+memoFiniteList :: (forall c. (b->c) -> m c) -> ([b] -> a) -> MapFiniteList m a+memoFiniteList g f = MFL (f []) (g (\b -> memoFiniteList g (\bs -> f (b:bs))))+appFiniteList :: (forall c. m c -> (b->c)) -> MapFiniteList m a -> ([b]->a)+appFiniteList _ (MFL n _) [] = n+appFiniteList g (MFL _ c) (x:xs) = appFiniteList g (g c x) xs++xs `isLongerThan` n | n<0 = True+[] `isLongerThan` n = False+(x:xs) `isLongerThan` n = xs `isLongerThan` (n-1)++prop_inverseList :: [Int] -> (Function [Int] Integer) -> Bool+prop_inverseList xs f = appList 5 appIntegral (memoList memoIntegral (getFunction f)) xs == getFunction f xs+prop_inverseListB :: [Bool] -> (Function [Bool] Integer) -> Bool+prop_inverseListB xs f = appList 5 appBool (memoList memoBool (getFunction f)) xs == getFunction f xs++type MapInteger = MapLargeIntegral Integer+memoInteger :: (Integer->a) -> MapInteger a+memoInteger = memoLargeIntegral+appInteger :: MapInteger a -> Integer->a+appInteger = appLargeIntegral (fromIntegral (minBound::Int), fromIntegral (maxBound::Int))+data MapLargeIntegral i a = MLI (MapIntegral a) (i->a)+memoLargeIntegral :: Bits i => (i->a) -> MapLargeIntegral i a+memoLargeIntegral f = MLI (memoIntegral f) f+appLargeIntegral :: (Bits i, Ord i) => (i,i) -- ^ range+ -> MapLargeIntegral i a -> i->a+appLargeIntegral (minb,maxb) (MLI mi f) i | minb <= i && i <= maxb = appIntegral mi i+ | otherwise = f i+type MapInt = MapIntegral+memoInt :: (Int->a) -> MapInt a+memoInt = memoIntegral+appInt :: MapInt a -> Int->a+appInt = appIntegral+data MapIntegral a = MI {+ negArrow :: MapNat a,+ nonnegArrow :: MapNat a+ }+type MapNat = MapFiniteList MapBool+memoIntegral :: Bits i => (i -> a) -> MapIntegral a+memoIntegral f = MI (memoPosNat (\n -> f (-n))) (memoPosNat (\n -> f (n-1)))+memoPosNat f = memoFiniteList memoBool (\bs -> f (bitsToPosNat bs))+bitsToPosNat [] = 1+bitsToPosNat (b:bs) | b = gbs .|. 1+ | otherwise = gbs+ where gbs = bitsToPosNat bs `shiftL` 1+appIntegral :: Bits i => MapIntegral a -> (i->a)+appIntegral (MI n nn) i | signum i == -1 = appPosNat n (-i)+ | otherwise = appPosNat nn (i+1)+appPosNat m i = appFiniteList appBool m (posNatToBits i)+posNatToBits 1 = []+posNatToBits n = (n `testBit` 0) : posNatToBits (n `shiftR` 1)+-- Another option is just to use a list as MapNat, and not to memoize when the argument is huge. This might be better if it is unlikely such large keys are visited again.+-- Patricia tree cannot be used for building an infinite tree.+prop_inverseIntegral :: Integer -> (Function Integer Integer) -> Bool+prop_inverseIntegral i f = appLargeIntegral (-2^28,2^28) (memoLargeIntegral (getFunction f)) i == getFunction f i+prop_inversePosNat :: Int -> Function Int Int -> Property+prop_inversePosNat n f = n>0 ==> appPosNat (memoPosNat (getFunction f)) n == getFunction f n+prop_bitsToFromPosNat :: [Bool]->Bool+prop_bitsToFromPosNat is = posNatToBits (bitsToPosNat is::Integer) == is -- Integer¤Ç¤Ê¤¯Int¤Ë¤¹¤ë¤ÈÄ̤é¤Ê¤¤¡¥++memoIx10, memoIx3 :: (Integral i, Ix i) => (i->a) -> MapIx i a+memoIx10 = memoIx (0,10)+memoIx3 = memoIx (0,3)++data MapIx i a = MIx (Array i a) (i->a)+memoIx :: (Ix i) => (i,i) -> (i->a) -> MapIx i a+memoIx bnds f = MIx (listArray bnds (map f (range bnds))) f+appIx :: (Ix i) => MapIx i a -> i->a+appIx (MIx ar f) i | bounds ar `inRange` i = ar!i+ | otherwise = f i++type MapChar = MapIntegral+memoChar :: (Char->a) -> MapChar a+memoChar f = memoIntegral (\i -> f $ chr i)+appChar :: MapChar a -> (Char->a)+appChar mi c = appIntegral mi (ord c)+prp_inverseChar c f = appChar (memoChar f) c == (f c::Int)++type MapReal = MapPair MapIntegral MapIntegral+memoReal :: RealFloat r => (r -> a) -> MapReal a+memoReal f = memoPair memoIntegral memoIntegral (f . uncurry encodeFloat)+appReal :: RealFloat r => MapReal a -> r -> a+appReal mt r = appPair appIntegral appIntegral mt (decodeFloat r)++prop_inverseReal :: Double -> (Double->Int) -> Bool+prop_inverseReal r f = appReal (memoReal f) r == f r+++-- test code for seeing if memoization really works+heavy, memoizedHeavy :: Integer -> Integer+heavy n = 3^n `div` 3^(n-1)+memoHeavy = memoIntegral heavy+memoizedHeavy = appIntegral memoHeavy++heavy2, memoizedHeavy2 :: Integer -> Integer -> Integer+heavy2 m n = m^n `div` m^(n-1)+memoHeavy2 = memoIntegral ((.) memoIntegral heavy2)+memoizedHeavy2 = (.) appIntegral (appIntegral memoHeavy2)++memoizedHeavy2' :: Integer -> Integer -> Integer+memoHeavy2' = memoPair memoIntegral memoIntegral (uncurry heavy2)+memoizedHeavy2' = curry $ appPair appIntegral appIntegral memoHeavy2'++heavy3, memoizedHeavy3 :: Integer -> Integer -> Integer -> Integer+heavy3 l m n = l^n `div` m^(n-1)+-- memoHeavy3 = memoIntegral ((.) memoIntegral ((.) ((.) memoIntegral) heavy3))+memoHeavy3 = (memoIntegral . (.) (memoIntegral . (.) memoIntegral)) heavy3+-- memoizedHeavy3 = (.) ((.) appIntegral) ((.) appIntegral (appIntegral memoHeavy3))+memoizedHeavy3 = ((.) ((.) appIntegral . appIntegral) . appIntegral) memoHeavy3+++heavyList, memoizedHeavyList :: String -> String+heavyList xs = take 10 $ reverse $ sort $ take 1000000 $ cycle xs+memoHeavyList = memoFiniteList memoChar heavyList+memoizedHeavyList = appFiniteList appChar memoHeavyList
+ LICENSE view
@@ -0,0 +1,25 @@+Copyright (c) 2009, Susumu Katayama. +All rights reserved.++Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met:+- Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer.+ +- Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.+ +- The name of its author may not be used to endorse or promote products+ derived from this software without specific prior written permission. ++THIS SOFTWARE IS PROVIDED BY SUSUMU KATAYAMA "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL SUSUMU KATAYAMA BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ MagicHaskeller.cabal view
@@ -0,0 +1,26 @@+Name: MagicHaskeller+Version: 0.8.5+License: BSD3+License-File: LICENSE+Copyright: Copyright: (c) 2009 Susumu Katayama+Author: Susumu Katayama+Maintainer: Susumu Katayama <skata@cs.miyazaki-u.ac.jp>+Stability: experimental+Homepage: http://nautilus.cs.miyazaki-u.ac.jp/~skata/MagicHaskeller.html+Synopsis: Automatic inductive functional programmer by systematic search+Build-Type: Simple+Category: Language+-- Tested-with: ghc=6.8.2+Build-depends: template-haskell, base >= 3 && < 4, containers, array, random+Exposed-modules: MagicHaskeller, Control.Monad.Search.Combinatorial, MagicHaskeller.ProgGen, MagicHaskeller.ProgGenSF, MagicHaskeller.ProgGenXF, MagicHaskeller.Expression, MagicHaskeller.LibTH+Other-modules: MagicHaskeller.Types, MagicHaskeller.PriorSubsts, Data.Memo, MagicHaskeller.ClassifyTr, MagicHaskeller.Classification, + MagicHaskeller.CoreLang, MagicHaskeller.DebMT, MagicHaskeller.TyConLib,+ MagicHaskeller.FakeDynamic, MagicHaskeller.ReadTypeRep,+ MagicHaskeller.ReadTHType, MagicHaskeller.TimeOut, MagicHaskeller.Execute, MagicHaskeller.T10,+ MagicHaskeller.Instantiate, MagicHaskeller.Classify, MagicHaskeller.MHTH, MagicHaskeller.MyCheck,+ MagicHaskeller.ExprStaged, MagicHaskeller.Combinators, MagicHaskeller.ReadDynamic,+ MagicHaskeller.MyDynamic, MagicHaskeller.ClassifyDM, MagicHaskeller.ProgramGenerator+Extensions: CPP, TemplateHaskell+GHC-options: -O2 -fvia-C+cpp-options: -DCHTO+
+ MagicHaskeller.lhs view
@@ -0,0 +1,609 @@+-- +-- (c) Susumu Katayama 2009+--++\begin{code}+-- # prune++-- prune is supposed to prevent haddock from chasing imports, but seemingly it does not work.++{-# OPTIONS -fglasgow-exts -XTemplateHaskell -cpp #-}+module MagicHaskeller(+ -- * Re-exported modules+ -- | This library implicitly re-exports the entities from+ -- @module Language.Haskell.TH as TH@ and @module Data.Typeable@ from the Standard Hierarchical Library of Haskell.+ -- Please refer to their documentations on types from them --- in this documentation, types from TH are all qualified and the only type used from @module Typeable@ is Typeable.Typeable. Other types you had never seen should be our internal representation.+ module TH, module Typeable,++ -- * Setting up your synthesis+ -- | Before synthesis, you have to define at least one program generator algorithm (or you may define one once and reuse it for later syntheses).+ -- Other parameters are memoization depth and time out interval, which have default values.+ -- You may elect either to set those values to the \'global variables\' using \'@set@*\' functions (i.e. functions whose names are prefixed by @set@), or hand them explicitly as parameters.++ -- ** Class for program generator algorithms+ -- | Please note that @ConstrL@ and @ConstrLSF@ are obsoleted and users are expected to use the 'constrL' option in 'Option'.+ ProgramGenerator,+ ProgGen, ProgGenSF, ProgGenXF,++ -- ** Functions for creating your program generator algorithm+ -- | You can set your primitives like, e.g., @'setPrimitives' $('p' [| ( (+) :: Int->Int->Int, 0 :: Int, \'A\', [] :: [a] ) |])@,+ -- where the primitive set is consisted of @(+)@ specialized to type @Int->Int->Int@, @0@ specialized to type @Int@, + -- @ \'A\' @ which has monomorphic type @Char@, and @[]@ with polymorphic type @[a]@.+ -- As primitive components one can include any variables and constructors within the scope. + -- However, because currently ad hoc polymorphism is not supported by this library, you may not write+ -- @'setPrimitives' $('p' [| (+) :: Num a => a->a->a |])@.+ -- Also, you have to specify the type unless you are using a primitive component whose type is monomorphic and instance of 'Data.Typeable.Typeable'+ -- (just like when using the dynamic expression of Concurrent Clean), and thus+ -- you may write @'setPrimitives' $('p' [| \'A\' |])@,+ -- while you have to write @'setPrimitives' $('p' [| [] :: [a] |])@ instead of @'setPrimitives' $('p' [| [] |])@.+ p, setPrimitives, mkPG, mkPGSF, setPG,+ -- 'mkPG' and 'setPG' used to be called @mkMemo@ and @setMemo@ respectively (because the main ingredient of a program generator is a memoization table). ¤È¤¤¤¦¥³¥á¥ó¥È¤Ï¤½¤°¤ï¤Ê¤¯¤Ê¤Ã¤Æ¤¤¿¤Î¤Ç»ß¤á¤ë¡¥++ -- | Older versions prohibited data types holding functions such as @[a->b]@, @(Int->Char, Bool)@, etc. just for efficiency reasons.+ -- They are still available if you use 'mkMemo' and 'mkMemoSF' instead of 'mkPG' and 'mkPGSF' respectively, though actually this limitation does not affect the efficiency a lot.+ -- (NB: recently I noticed that use of 'mkMemo' or 'mkMemoSF' might not improve the efficiency of generating lambda terms at all, though when I generated combinatory expressions it WAS necessary.+ -- In fact, I mistakenly turned this limitation off, and 'mkMemo' and 'mkMemoSF' were equivalent to 'mkPG' and 'mkPGSF', but I did not notice that....)+ mkMemo, mkMemoSF,++ -- | @mkMemo075@ enables some more old good optimization options used until Version 0.7.5, including guess on the primitive functions.+ -- It is for you if you prefer speed, but the result can be non-exhaustive if you use it with your own LibTH.hs.+ -- Also, you need to use the prefixed |(->)| in order for the options to take effect. See LibTH.hs for examples.+ mkPG075, mkMemo075,++ -- | 'mkPGOpt' can be used along with its friends instead of 'mkPG' when the search should be fine-tuned.+ mkPGOpt, Options, Opt(..), options,++#ifdef HASKELLSRC+ -- *** Alternative way to create your program generator algorithm+ -- | 'load', 'loadPrimitives', and 'loadPG' provides an alternative scheme to create program generator algorithms.+ -- (But most likely they will become obsolete....)+ load, loadPrimitives, loadPG,+#endif++ -- ** Memoization depth+ setDepth,++ -- ** Time out+ -- | NB: 'setTimeout' and 'unsetTimeout' will be obsoleted. They are provided for backward compatibility, but+ -- not exactly compatible with the old ones in that their results will not affect the behavior of 'everything', etc., which explicitly take a 'ProgramGenerator' as an argument.+ -- Also, in the current implementation, the result of 'setTimeout' and 'unsetTimeout' will be overwritten by setPrimitives.+ -- Use 'timeout' option instead.+ --+ -- Because the library generates all the expressions including those with non-linear recursions, you should note that there exist some expressions which take extraordinarily long time. (Imagine a function that takes an integer n and increments 0 for 2^(2^n) times.)+ -- For this reason, time out is taken after 0.02+ -- second since each invocation of evaluation by default. This default behavior can + -- be overridden by the following functions.+ setTimeout, unsetTimeout,++ -- ** Defining functions automatically+ -- | In this case \"automatically\" does not mean \"inductively\" but \"deductively using Template Haskell\";)+ define, Everything, Filter, Every,++ -- * Generating programs+ -- | (There are many variants, but most of the functions here just filter 'everything' with the predicates you provide.)+ --+ -- Functions suffixed with \"F\" (like 'everythingF', etc.) are filtered versions, where their results are filtered to totally remove semantic duplications. In general they are equivalent to applying 'everyF' afterwards.+ -- (Note that this is filtration AFTER the program generation, unlike the filtration by using 'ProgGenSF' is done DURING program generation.)++ -- ** Quick start+ findOne, printOne, printAny,++ -- ** Incremental filtration+ -- | Sometimes you may want to filter further after synthesis, because the predicate you previously provided did not specify+ -- the function enough. The following functions can be used to filter expressions incrementally.+ filterFirst, filterFirstF, filterThen, filterThenF,++ -- ** Expression generators+ -- | These functions generate all the expressions that have the type you provide.+ getEverything, everything, everythingM, unifyable, matching, getEverythingF, everythingF, unifyableF, matchingF,++ -- ** Utility to filter out equivalent expressions+ everyF,++ -- ** Pretty printers+ pprs, printQ,++ -- * Internal data representation+ -- | The following types are assigned to our internal data representations.+ Primitive, HValue(HV),++ -- other stuff which will not be documented by Haddock+ unsafeCoerce#, {- unifyablePos, -} exprToTHExp, trToTHType -- , specializedPossi+#ifdef HASKELLSRC+ , module Language.Haskell.Syntax -- , pprintType+#endif+ ) where++import Data.Generics(everywhere, mkT, Data)++import Data.Array.IArray+import MagicHaskeller.CoreLang(CoreExpr(..), HValue(..), exprToTHExp, VarLib)+import Language.Haskell.TH as TH+#ifdef HASKELLSRC+import Language.Haskell.Syntax+import Language.Haskell.Pretty+import ReadType+#endif+import MagicHaskeller.TyConLib+import qualified Data.Map as Map+import Data.Char++import MagicHaskeller.Types as Types++import MagicHaskeller.ProgGen(ProgGen(PG))+import MagicHaskeller.ProgGenSF(ProgGenSF, PGSF)+-- import MagicHaskeller.ProgGenLF(ProgGenLF)+import MagicHaskeller.ProgGenXF(ProgGenXF)+import MagicHaskeller.ProgramGenerator+import Control.Monad.Search.Combinatorial -- This should all be exposed?+import Data.Typeable as Typeable+import System.IO.Unsafe(unsafePerformIO)+import Data.IORef+import GHC.Exts(unsafeCoerce#)+-- import Maybe(fromJust)+import System.IO+import System.Random(mkStdGen,StdGen)+import MagicHaskeller.MHTH++import MagicHaskeller.ReadTHType+import MagicHaskeller.ReadTypeRep(trToType, trToTHType)+import MagicHaskeller.MyDynamic+import MagicHaskeller.Expression+import MagicHaskeller.Classify+import MagicHaskeller.Classification(unsafeRandomTestFilter, Filtrable)+import MagicHaskeller.Instantiate(mkRandTrie)++\end{code}++\begin{code}++-- "MemoDeb" name should be hidden, or maybe I could rename it.++type Primitive = (HValue, TH.Exp, TH.Type)++-- | 'define' eases use of this library by automating some function definitions. For example, +--+-- > $( define ''ProgGen "Foo" 15 (p [| (1 :: Int, (+) :: Int -> Int -> Int) |]) )+--+-- is equivalent to +--+-- > memoFoo :: ProgGen+-- > memoFoo = mkPG (p [| (1 :: Int, (+) :: Int -> Int -> Int) |])+-- > everyFoo :: Everything+-- > everyFoo = everything 15 memoFoo+-- > filterFoo :: Filter+-- > filterFoo pred = filterThen pred everyFoo+--+-- If you do not think this function reduces the number of your keystrokes a lot, you can do without it.+define :: TH.Name -> String -> Integer -> TH.ExpQ -> TH.Q [TH.Dec]+define mn name depth pq = pq >>= \prims ->+ return [ SigD (mkName ("memo"++name)) (ConT mn),+ ValD (VarP (mkName ("memo"++name))) (NormalB (AppE (VarE (mkName "mkPG")) prims -- (VarE (mkName "prims"))+ )) [],+ SigD (mkName ("every"++name)) (ConT (mkName "Everything")),+ ValD (VarP (mkName ("every"++name))) (NormalB ((VarE (mkName "everything") `AppE` LitE (IntegerL depth)) `AppE` VarE (mkName ("memo"++name)))) [],+ SigD (mkName ("filter"++name)) (ConT (mkName "Filter")),+ ValD (VarP (mkName ("filter"++name))) (NormalB ((VarE (mkName "flip") `AppE` VarE (mkName "filterThen")) `AppE` VarE (mkName ("every"++name)))) [] ]+type Every a = [[(TH.Exp,a)]]+type Everything = Typeable a => Every a+type Filter = Typeable a => (a->Bool) -> IO (Every a)++{- Because the left hand side is not TH.Exp, we cannot splice directly there.+initialize name depth prims = [d| { $(return (VarE (mkName ("memo"++name)))) = mkPG $prims;+ $(return (VarE (mkName ("every"++name)))) :: Everything;+ $(return (VarE (mkName ("every"++name)))) = everything $(return (LitE (NumL depth))) $(return (VarE (mkName ("memo"++name)))); } |]+-}++{- It is unlikely that mkMTH will ever be used, and seemingly my version of haddock dislikes TH.+-- One could write, for example, $(mkMTH $15 [| ( 0::Int, succ, nat_para, [] ) |] ),+-- but I am not sure if this style using mkMTH will ever be used.+mkMTH :: TH.ExpQ -> TH.ExpQ -> TH.ExpQ+mkMTH n leq = [| mkMD $n $(m leq) |]+-}++-- Rather, one could write, e.g.,+-- mkMD 15 $(p [| ( 0::Int, succ::Int->Int, nat_para, [] :: [a]) |] )++-- | 'p' is used to convert your primitive component set into the internal form.+p :: TH.ExpQ -- ^ Quasi-quote a tuple of primitive components here.+ -> TH.ExpQ -- ^ This becomes @[Primitive]@ when spliced.+p eq = eq >>= \e -> case e of TupE es -> (return . ListE) =<< (mapM p' es)+ _ -> (return . ListE . return) =<< p' e -- This default pattern should also be defined, because it takes two (or more) to tuple!+p' :: TH.Exp -> TH.ExpQ+p' se@(SigE e ty) = do ee <- expToExpExp e+ et <- typeToExpType ty+ return $ TupE [ AppE (ConE (mkName "HV")) (AppE (VarE (mkName "unsafeCoerce#")) se), ee, et]+p' e = do ee <- expToExpExp e+ return $ TupE [ AppE (ConE (mkName "HV")) (AppE (VarE (mkName "unsafeCoerce#")) e), ee, AppE (VarE (mkName "trToTHType")) (AppE (VarE (mkName "typeOf")) e)]++-- nameToExpName :: TH.Name -> TH.Exp+-- nameToExpName = strToExpName . showName+-- strToExpName str = AppE (VarE (mkName "mkName")) (LitE (StringL str))++{- not used any longer+{- This should work in theory, but Language.Haskell.TH.pprint has a bug and it does not print parentheses....+pprintType (ForallT _ _ ty) = pprint ty+pprintType ty = pprint ty+-}+-- 'pprintType' is a workaround for the problem that @Language.Haskell.TH.pprint :: Type -> String@ does not print parentheses correctly.+-- (try @Language.Haskell.TH.runQ [t| (Int->Int)->Int |] >>= \e -> putStrLn (pprint e)@ in your copy of GHCi.)+-- The implementation here is not so pretty, but that's OK for my purposes. Also note that 'pprintType' ignores foralls.+pprintType (ForallT _ [] ty) = pprintType ty+pprintType (ForallT _ _ ty) = error "Type classes are not supported yet. Sorry...."+pprintType (VarT name) = pprint name+pprintType (ConT name) = pprint name+pprintType (TupleT n) = tuplename n+pprintType ArrowT = "(->)"+pprintType ListT = "[]"+pprintType (AppT t u) = '(' : pprintType t ++ ' ' : pprintType u ++ ")"+-- The problem of @Language.Haskell.TH.pprint :: Type -> String@ is now fixed at the darcs HEAD.+-}++primitivesp :: TyConLib -> [Primitive] -> [Typed [CoreExpr]]+primitivesp tcl ps+ = zipWith (\ n (_,_,ty) -> [Primitive n] ::: thTypeToType tcl ty) [0..] ps+primitivesToVL :: TyConLib -> [Primitive] -> VarLib+primitivesToVL tcl ps+ = listArray (0, length ps - 1) $ map (\ (HV x, e, ty) -> (e, unsafeToDyn tcl (thTypeToType tcl ty) x e)) ps++{-+mkPG :: Int -- ^ memoization depth. (Sub)expressions within this size are memoized, while greater expressions will be recomputed (to save the heap space).+ -> [Primitive] -> (Int, Memo)+mkPG n tups = (n, mkPG' tups)+-}++mkPG :: ProgramGenerator pg => [Primitive] -> pg+mkPG = mkPG' True+-- ^ 'mkPG' is defined as:+--+-- > mkPG prims = mkPGSF (mkStdGen 123456) (repeat 5) prims prims++mkMemo :: ProgramGenerator pg => [Primitive] -> pg+mkMemo = mkPG' False+mkPG' cont tups = case mkCommon options{contain=cont} tups of cmn -> mkTrie cmn (primitivesp (tcl cmn) tups)++-- | 'mkPGSF' and 'mkMemoSF' are provided mainly for backward compatibility. These functions are defined only for the 'ProgramGenerator's whose names end with @SF@ (i.e., generators with synergetic filtration).+-- For such generators, they are defined as:+--+-- > mkPGSF gen nrnds optups tups = mkPGOpt (options{primopt = Just optups, contain = True, stdgen = gen, nrands = nrnds}) tups+-- > mkMemoSF gen nrnds optups tups = mkPGOpt (options{primopt = Just optups, contain = False, stdgen = gen, nrands = nrnds}) tups++mkPGSF,mkMemoSF :: ProgramGenerator pg =>+ StdGen+ -> [Int] -- ^ number of random samples at each depth, for each type.+ -> [Primitive] + -> [Primitive] -> pg+mkPGSF = mkPGSF' True+mkMemoSF = mkPGSF' False+mkPGSF' cont gen nrnds optups tups = mkPGOpt (options{primopt = Just optups, contain = cont, stdgen = gen, nrands = nrnds}) tups+-- Currently only the pg==ConstrLSF case makes sense. ¤Ã¤Æ¤Î¤Ï¡¤optups¤Î¤ß¤Ë´Ø¤¹¤ëÏäǡ¤rnds¤Ï´Ø·¸¤Ê¤¤¡¥++mkPG075 :: ProgramGenerator pg => [Primitive] -> pg+mkPG075 = mkPGOpt (options{primopt = Nothing, contain = True, guess = True})+mkMemo075 :: ProgramGenerator pg => [Primitive] -> pg+mkMemo075 = mkPGOpt (options{primopt = Nothing, contain = False, guess = True})++mkPGOpt :: ProgramGenerator pg => Options -> [Primitive] -> pg+mkPGOpt opt prims = case mkCommon opt prims of cmn -> mkTrieOpt cmn (primitivesp (tcl cmn) primsOpt) (primitivesp (tcl cmn) prims)+ where primsOpt = case primopt opt of Nothing -> prims+ Just po -> po++-- this can be moved to somewhere near Common is defined (currently ProgramGenerator.lhs), when 'Primitive' is moved to some more adequate place.+-- ¼ÂºÝProgramGenerator.lhs¤ÇPrimitive¤ò°·¤¨¤ì¤Ð¤â¤Ã¤Èñ½ã²½¤Ç¤¤ë¤Ï¤º¡¥+mkCommon :: Options -> [Primitive] -> Common+mkCommon opts prims = let (_, _, ts) = unzip3 prims+ tyconlib = thTypesToTCL ts+ optunit = forget opts+ in Cmn {opt = optunit, tcl = tyconlib, vl = primitivesToVL tyconlib prims, rt = mkRandTrie (nrands opts) tyconlib (stdgen opts)}++-- | options for limiting the hypothesis space.+type Options = Opt [Primitive]++forget :: Opt a -> Opt ()+forget opt = case primopt opt of Nothing -> opt{primopt = Nothing}+ Just _ -> opt{primopt = Just ()}++setPG :: ProgGen -> IO ()+setPG = writeIORef refmemodeb++-- | @setPrimitives@ creates a @ProgGen@ from the given set of primitives using the current set of options, and sets it as the current program generator. +-- It used to be equivalent to @setPG . mkPG@ which overwrites the options with the default, but it is not now.+setPrimitives :: [Primitive] -> IO ()+setPrimitives tups = do PG (x,y,cmn) <- readIORef refmemodeb+ setPG $ mkPGOpt ((opt cmn){primopt=Nothing}) tups+-- setPrimitives tups = writeIORef refmemodeb (mkPG tups) -- This definition overwrites the old configuration.++#ifdef HASKELLSRC+-- | 'load' loads a component library file.+load :: FilePath+ -> TH.ExpQ -- ^ This becomes @([[HValue]], String)@ when spliced.+load fp = do str <- runIO $ readFile fp+ f str+-- | f is supposed to be used by load, but not hidden.+f :: String -> TH.ExpQ+f str = return (TupE [ f' $ readHsDecls (str++"\n"), LitE (StringL str)])+f' :: [HsDecl] -> TH.Exp+f' decls = ListE [ ListE $ map (\e -> AppE (ConE (mkName "HV")) (AppE (VarE (mkName "unsafeCoerce#")) (VarE (mkName (hsNameToName e))))) hsnames |+ HsTypeSig _loc hsnames hsqt@(HsQualType _context hsty) <- decls ]++primitives :: [[HValue]] -> TyConLib -> [HsDecl] -> [Typed [CoreExpr]]+primitives cnl tcl decls+ = zipWith (\ (exps,ty) hvs -> zipWith (\ e (HV x) -> Primitive e (unsafeToDyn tcl ty x e)) exps hvs ::: ty)+ [ (map (VarE . mkName . hsNameToName) hsnames, hsTypeToType tcl hsty) | HsTypeSig _loc hsnames hsqt@(HsQualType _context hsty) <- decls ]+ cnl++{- I once thought the following definition would be better, but on the second thought I was bothered because loadPG will become obsolete....+loadPG :: Int -- ^ memoization depth+ -> FilePath+ -> TH.ExpQ -- ^ This becomes 'Memo' when spliced.+loadPG n str = [| loadPG' n +-}+loadPG :: ProgramGenerator a => ([[HValue]], String) -> a+loadPG (cnl, str) = mkTrie tcl (primitives cnl tcl hsdecls)+ where tcl = extractTyConLib hsdecls+ hsdecls = readHsDecls str++loadPrimitives :: ([[HValue]], String) -> IO ()+loadPrimitives tup = writeIORef refmemodeb (loadPG tup)+#endif+++-- | 'setTimeout' sets the timeout in microseconds. Also, my implementation of timeout also catches inevitable exceptions like stack space overflow. Note that setting timeout makes the library referentially untransparent. (But currently @setTimeout 20000@ is the default!)+setTimeout :: Int -- ^ time in microseconds+ -> IO ()+setTimeout n = do pto <- newPTO n+ PG (x,y,cmn) <- readIORef refmemodeb+ writeIORef refmemodeb $ PG (x,y,cmn{opt = (opt cmn){timeout=Just pto}})+-- | 'unsetTimeout' disables timeout. This is the safe choice.+unsetTimeout :: IO ()+unsetTimeout = do PG (x,y,cmn) <- readIORef refmemodeb+ writeIORef refmemodeb $ PG (x,y,cmn{opt = (opt cmn){timeout=Nothing}})+{-# NOINLINE refdepth #-}+refdepth :: IORef Int+refdepth = unsafePerformIO (newIORef defaultDepth)+defaultDepth = 10++setDepth :: Int -- ^ memoization depth. (Sub)expressions within this size are memoized, while greater expressions will be recomputed (to save the heap space).+ -> IO ()+setDepth d = writeIORef refdepth d+-- ^ Currently the default depth is 10. You may want to lower the value if your computer often swaps, or increase it if you have a lot of memory.++{-# NOINLINE refmemodeb #-}+refmemodeb :: IORef ProgGen+refmemodeb = unsafePerformIO (newIORef defaultMD)+defaultMD = mkPG [] :: ProgGen++trsToTCL :: [TypeRep] -> TyConLib -- ReadType.extractTyConLib :: [HsDecl] -> TyConLib¤ò»²¹Í¤Ë¤Ç¤¤ë¡¥ -- ¤³¤Î2¹Ô¤È+trsToTCL trs+ = (Map.fromListWith (\new old -> old) [ tup | k <- [0..7], tup <- tcsByK ! k ], tcsByK)+ where tnsByK :: Array Kind [TypeName]+ tnsByK = accumArray (flip (:)) [] (0,7) ( trsToTCstrs trs ) -- ¤³¤³¤òÊѤ¨¤¿¡¥+ tcsByK :: Array Kind [(TypeName,Types.TyCon)]+ tcsByK = listArray (0,7) [ tnsToTCs (tnsByK ! k) | k <- [0..7] ]+ tnsToTCs :: [TypeName] -> [(TypeName,Types.TyCon)]+ tnsToTCs tns = zipWith (\ i tn -> (tn, i)) [0..] tns+-- x ¼ÂºÝ¤Ë¤Ï(->)¤ÏTyCon°·¤¤¤Ë¤Ï¤·¤Ê¤¤¤ó¤À¤±¤É¡¤¤Û¤ó¤Î¤Á¤ç¤Ã¤È¤À¤±ÌµÂ̤ˤʤë¤À¤±¤Ê¤Î¤Ç¤¤¤¤¤Ç¤·¤ç¡¥++trsToTCstrs :: [TypeRep] -> [(Int, String)] -- Int is the arity of the TyCon. There can be duplicates.+trsToTCstrs [] = []+trsToTCstrs (tr:ts) = case splitTyConApp tr of (tc,trs) -> (length trs, tyConString tc) : trsToTCstrs (trs++ts)+++-- Memo¤ägetEverything¼«ÂΤÏIORef¤ò»È¤ï¤º¤ËIO¤Ê¤·¤Ç¼ÂÁõ¤Ç¤¤ëÌõ¤Ç¡¤¤½¤Î°ÕÌ£¤Ç¤Ï¡¤IORef¤ò»È¤ï¤Ê¤¤Êý¤¬¤¤¤¤¤«¤â¡¥+-- x ¤Ä¤¤¤Ç¤Ë¤¤¤¦¤È¡¤1ÉäǤΥ¿¥¤¥à¥¢¥¦¥È¤òɽ¤¹PTO¡Ê¤ÎGLOBAL_VAR¡Ë¤âIO¤Ê¤·¤ÇÍѰդǤ¤ë¡¥¡ÊunsafePerformIO»È¤¦¤±¤É¡Ë++-- | 'getEverything' uses the \'global\' values set with @set*@ functions. 'getEverythingF' is its filtered version+getEverything :: Typeable a => IO (Every a)+getEverything = do depth <- readIORef refdepth+ memodeb <- readIORef refmemodeb+ return (everything depth memodeb)+getEverythingF :: Typeable a => IO (Every a)+getEverythingF =do depth <- readIORef refdepth+ memodeb <- readIORef refmemodeb+ return (everythingF depth memodeb)+{-+getEverything = result+ where ty = typeOf $ snd $ head $ head $ unsafePerformIO result+ result = do memodeb@(trie,prims,depth,tcl) <- readIORef refmemodeb+ return $ unMx $ toMx (fmap (\ e -> (exprToTHExp (error "unknown conlib") e, unsafeExecute e)) (matchingPrograms (trToType tcl ty) memodeb))+-}++-- | 'everything' generates all the expressions that fit the inferred type, and their representations in the 'TH.Exp' form.+-- It returns a stream of lists, which is equivalent to Spivey's @Matrix@ data type, i.e., that contains expressions consisted of n primitive components at the n-th element (n = 1,2,...).+-- 'everythingF' is its filtered version+everything, everythingF :: (ProgramGenerator pg, Typeable a) =>+ Int -- ^ memoization depth. + -> pg -- ^ program generator+ -> Every a+everything memodepth memodeb = et undefined memodepth memodeb (mxExprToEvery "MagicHaskeller.everything: type mismatch" memodeb)+everythingF memodepth memodeb = et undefined memodepth memodeb (mxExprFiltEvery "MagicHaskeller.everythingF: type mismatch" memodeb)+et :: (ProgramGenerator pg, Typeable a) =>+ a -- ^ dummy argument+ -> Int -- ^ memoization depth.+ -> pg -- ^ program generator+ -> (Types.Type -> Matrix AnnExpr -> Matrix (Exp, a))+ -> Every a+et dmy memodepth memodeb filt = unMx $ filt ty $ matchingPrograms ty (memodepth,memodeb)+ where ty = trToType (extractTCL memodeb) (typeOf dmy)+noFilter :: ProgramGenerator pg => pg -> Types.Type -> a -> a+noFilter _m _t = id++mxExprToEvery :: (Expression e, Search m, ProgramGenerator pg, Typeable a) => String -> pg -> Types.Type -> m e -> m (Exp, a)+mxExprToEvery msg memodeb _ = fmap (unwrapAE msg memodeb . toAnnExpr (reducer memodeb))+mxExprFiltEvery :: (Expression e, FiltrableBF m, ProgramGenerator pg, Typeable a) => String -> pg -> Types.Type -> m e -> m (Exp, a)+mxExprFiltEvery msg memodeb ty = fmap (unwrapAE msg memodeb) . randomTestFilter memodeb ty . fmap (toAnnExpr (reducer memodeb))++unwrapAE :: (ProgramGenerator pg, Typeable a) => String -> pg -> AnnExpr -> (Exp, a)+unwrapAE msg memodeb (AE e dyn) = (exprToTHExp (extractVL memodeb) e, fromDyn tcl dyn (error msg))+ where tcl = extractTCL memodeb++{-+̵¸Â¥ê¥¹¥È¤ò»È¤¦¤Ê¤é¡¤unsafeInterleaveIO¤¬É¬ÍפʤϤº¡¥¤½¤Î¾ì¹çIO¤ËÆò½¤¹¤ë¤³¤È¤Ë¤Ê¤ë¡¥+-}+everythingM :: (ProgramGenerator pg, Typeable a, Monad m, Functor m) =>+ Int -- ^ memoization depth. + -> pg -- ^ program generator+ -> Int -- ^ query depth+ -> m [(TH.Exp, a)]+everythingM = eM undefined+eM :: (ProgramGenerator pg, Typeable a, Monad m, Functor m) =>+ a -- ^ dummy argument+ -> Int -- ^ memoization depth. + -> pg -- ^ program generator+ -> Int+ -> m [(TH.Exp, a)]+eM dmy memodepth memodeb = result+ where tcl = extractTCL memodeb+ ty = trToType tcl $ typeOf dmy+ result = unRcT $ mxExprToEvery "MagicHaskeller.everythingM: type mismatch" memodeb undefined $ matchingPrograms ty (memodepth,memodeb)++strip :: m (Every a) -> a+strip = undefined++unifyable, matching, unifyableF, matchingF :: ProgramGenerator pg =>+ Int -- ^ memoization depth+ -> pg -- ^ program generator+ -> TH.Type -- ^ query type+ -> [[TH.Exp]]+-- ^ Those functions are like 'everything', but take 'TH.Type' as an argument, which may be polymorphic.+-- For example, @'printQ' ([t| forall a. a->a->a |] >>= return . 'unifyable' True 10 memo)@ will print all the expressions using @memo@ whose types unify with @forall a. a->a->a@.+-- (At first I (Susumu) could not find usefulness in finding unifyable expressions, but seemingly Hoogle does something alike, and these functions might enhance it.)+unifyable memodepth memodeb tht = unMx $ genExps noFilter unifyingPrograms memodepth memodeb tht+matching memodepth memodeb tht = unMx $ genExps noFilter matchingPrograms memodepth memodeb tht+-- unifyablePos memodepth memodeb tht = unMx $ toMx $ fmap (\(es,subst,mx) -> (map (pprintUC . exprToTHExp (extractVL memodeb)) es, subst, mx)) $ unifyingPossibilities (thTypeToType (extractTCL memodeb) tht) (memodepth,memodeb)+unifyableF memodepth memodeb tht = unMx $ genExps randomTestFilter unifyingPrograms memodepth memodeb tht+matchingF memodepth memodeb tht = unMx $ genExps randomTestFilter matchingPrograms memodepth memodeb tht+genExps filt rawGenProgs memodepth memodeb tht+ = case thTypeToType (extractTCL memodeb) tht of+ ty -> fmap (exprToTHExp (extractVL memodeb) . toCE) $+ filt memodeb ty $ fmap (toAnnExpr (reducer memodeb)) (rawGenProgs ty (memodepth,memodeb))+-- Another advantage of these functions is that you do not need to define @instance Typeable@ for user defined types.+-- ¤È»×¤Ã¤¿¤±¤É¡¤GHC¤Ç¤Ïderiving Typeable¤Ç´Êñ¤ËÄêµÁ¤Ç¤¤ë¤·¡¤Typeable¤¬ÄêµÁ¤Ç¤¤Ê¤¤·¿¤Ê¤ó¤Æ¤Ê¤µ¤½¤¦¡Êderiving Typeable¤·Ëº¤ì¤¿data type¤ò´Þ¤àdata¤¬¤½¤¦¡©¡Ë++-- specializedPossi memodepth memodeb tht = unMx $ toMx $ fmap show (specializedPossibleTypes (thTypeToType (extractTCL memodeb) tht) (memodepth,memodeb))++{-+wrappit :: (Search m, Functor m, Typeable a) => m CoreExpr -> [[(TH.Exp,a)]]+wrappit = unMx . toMx . fmap (\ e -> (exprToTHExp e, unsafeExecute e))+-}++-- | @'findOne' pred@ finds an expression 'e' that satisfies @pred e == True@, and returns it in 'TH.Exp'. +findOne :: Typeable a => (a->Bool) -> TH.Exp+findOne pred = unsafePerformIO $ findDo (\e _ -> return e) pred++{- x Ç°¤Î¤¿¤á¤ä¤Ã¤Æ¤ß¤¿¤±¤É¡¤¤ä¤Ã¤Ñ¥À¥á¤ä¤Í¡¥¤Æ¤æ¡¼¤«¡¤Recomp¤Î¤Þ¤Þ¤ä¤Ã¤Æ³Æ¿¼¤µ¤Ç¸«¤ë¼ê¤Ï¤¢¤ë¤«¤â¡¥+findAny :: Typeable a => (a->Bool) -> [TH.Exp]+findAny pred = unsafePerformIO $ findDo (\e r -> r >>= \es -> return (e:es)) pred+-}+-- | 'printOne' prints the expression found first. +printOne :: Typeable a => (a->Bool) -> IO ()+printOne pred = do expr <- findDo (\e _ -> return e) pred+ putStrLn $ pprintUC expr+-- | 'printAny' prints all the expressions satisfying the given predicate.+printAny :: Typeable a => (a->Bool) -> IO ()+printAny = findDo (\e r -> putStrLn (pprintUC e) >> r)++findDo :: Typeable a => (TH.Exp -> IO b -> IO b) -> (a->Bool) -> IO b+findDo op pred = do et <- getEverything+ md <- readIORef refmemodeb+ let mpto = timeout $ opt $ extractCommon md+ fp mpto (concat et)+ where fp mpto ((e,a):ts) = do -- hPutStrLn stderr ("trying" ++ pprintUC e)+ result <- maybeWithPTO seq (return (pred a)) mpto+ case result of Just True -> e `op` fp mpto ts+ Just False -> fp mpto ts+ Nothing -> hPutStrLn stderr ("timeout on "++pprintUC e) >> fp mpto ts+-- x ËÜÅö¤Ïrecomp¤Î¤Þ¤Þ¤Ç¤ä¤Ã¤¿Êý¤¬Â®¤¤¤Ï¤º¡¥++-- | 'filterFirst' is like 'printAny', but by itself it does not print anything. Instead, it creates a stream of expressions represented in tuples of 'TH.Exp' and the expressions themselves. +filterFirst :: Typeable a => (a->Bool) -> IO (Every a)+filterFirst pred = do et <- getEverything+ filterThen pred et+-- randomTestFilter should be applied after filterThen, because it's slower+filterFirstF :: (Typeable a, Filtrable a) => (a->Bool) -> IO (Every a)+filterFirstF pred = do et <- getEverything+ filterThenF pred et+filterThenF pred et = do+ fd <- filterThen pred et+ memodeb <- readIORef refmemodeb+ let mpto = timeout $ opt $ extractCommon memodeb+ return $ everyF mpto fd+{- refmemodeb ¤Ë¤¢¤ë¤â¤Î¤¬¼ÂºÝ¤Ë»È¤ï¤ì¤Æ¤¤¤ë¤â¤Î¤È¤Ï¸Â¤é¤Ê¤¤¡¥refmemodeb¤ò»È¤ï¤Ê¤¤¤È¤¤¤¦ÁªÂò¤â¤¢¤ë¤Î¤Ç¡¥+filterFirstF pred = do et <- getEverything+ filterThenF pred et+filterThenF pred ts = do+ fd <- filterThen pred ts+ let x=undefined+ _=pred x+ memodeb <- readIORef refmemodeb+ return $ unMx $ randomTestFilter memodeb (getType memodeb x) $ Mx et+getType :: Typeable a => a -> ProgGen -> Types.Type+getType ty memodeb = trToType (extractTCL memodeb) (typeOf ty)+-}+everyF :: (Typeable a, Filtrable a) =>+ Maybe Int -- ^ microsecs until timeout+ -> Every a -> Every a+everyF mto = unMx . unsafeRandomTestFilter mto . Mx ++-- | 'filterThen' may be used to further filter the results.+filterThen :: Typeable a => (a->Bool) -> Every a -> IO (Every a)+filterThen pred ts = do md <- readIORef refmemodeb+ let mpto = timeout $ opt $ extractCommon md+ return (map (fp mpto) ts)+ where fp _ [] = []+ fp mpto (ea@(e,a):ts) = case unsafePerformIO (maybeWithPTO seq (return (pred a)) mpto) of+ Just True -> ea : fp mpto ts+ _ -> fp mpto ts+{- if not doing timeout+filterThen pred ts = return (map fp ts)+ where fp [] = []+ fp (ea@(e,a):ts) = case pred a of+ True -> ea : fp ts+ _ -> fp ts+-}+{- x ¤¤¤í¤¤¤í¤ä¤Ã¤Æ¤ß¤¿¤±¤É¡¤¤ä¤Ã¤Ñɽ¼¨¤ÈÂåÆþ¤ò°ìÅ٤ˤä¤ë¤Î¤Ï̵Íý¡¥++++++... ¤Æ¤æ¡¼¤«¡¤++System.IO.Unsafe.unsafeInterleaveIO :: IO a -> IO a+¤ò»È¤¨¤Ð¤¤¤¤¤Ï¤º¡¥+++++filterThen pred ts = do mpto <- readIORef refpto+ return (fp mpto ts)+ where fp mpto (ea@(e,a):ts) = if unsafePerformIO (do mb <- maybeWithPTO (return (pred a)) mpto+ case mb of Just True -> do putStrLn $ pprintUC e+ return True+ _ -> return False)+ then ea : fp mpto ts+ else fp mpto ts+-}+{-+filterThen pred ts = do mpto <- readIORef refpto+ fp mpto ts+ where fp mpto (ea@(e,a):ts) = do mb <- maybeWithPTO (return (pred a)) mpto+ case mb of Just True -> do putStrLn $ pprintUC e+ rest <- fp mpto ts+ return (ea:rest)+ _ -> fp mpto ts+-}+-- utility functions to pretty print the results+-- | 'pprs' pretty prints the results to the console, using 'pprintUC'+pprs :: Every a -> IO ()+pprs = mapM_ (putStrLn . pprintUC . fst) . concat+-- | 'pprintUC' is like 'Language.Haskell.TH.pprint', but unqualifies (:) before pprinting in order to avoid printing "GHC.Types.:" which GHCi does not accept and sometimes annoys when doing some demo.+pprintUC :: (Ppr a, Data a) => a -> String+pprintUC = pprint . everywhere (mkT unqCons)+unqCons :: Name -> Name+unqCons n | show n == show '(:) = mkName ":" -- NB: n == '(:) would not work due to the definition of Eq Name.+ | otherwise = n+printQ :: (Ppr a, Data a) => Q a -> IO ()+printQ q = runQ q >>= putStrLn . pprintUC++\end{code}
+ MagicHaskeller/Classification.hs view
@@ -0,0 +1,268 @@+{-# OPTIONS_GHC -fglasgow-exts -cpp #-}+{-# LANGUAGE UndecidableInstances, OverlappingInstances, TemplateHaskell #-} +-- x #define TESTEQ++-- DBound$B$O$$$$$N!)(B++module MagicHaskeller.Classification -- (+ -- randomTestFilter, -- :: Filtrable a => (b->a) -> Matrix b -> Matrix b+ -- )+ where+import Prelude hiding ((/))+import System.Random+import MagicHaskeller.MyCheck+import Data.Char+import Data.List+import Control.Monad+import Control.Monad.Search.Combinatorial+import Data.Complex++import MagicHaskeller.MHTH+import MagicHaskeller.T10+import MagicHaskeller.Classify(diffSortedBy, diffSortedByBot)++class (Search m) => SStrategy m where+ sfilter :: Relation r =>+ (k->k->r) -> m ([k],e) -> m ([k],e)+ ofilter :: Relation r =>+ (k->k->r) -> m (k,e) -> m (k,e)++instance SStrategy Matrix where+ sfilter = sfilterMx+ ofilter = ofilterMx++instance SStrategy DBound where+ sfilter = sfilterDB+ ofilter = ofilterDB++arbitraries :: Arbitrary a => [a]+arbitraries = arbs 0 (mkStdGen 1)+arbs :: Arbitrary a => Int -> StdGen -> [a]+arbs n stdgen = case split stdgen of+ (g0,g1) -> f n g0 : arbs (n+1) g1+ where Gen f = arbitrary++(/~) :: [a] -> (a->a->Bool) -> [[a]]+[] /~ eq = []+(x:xs) /~ eq = case partition (x `eq`) xs of+ (same, diff) -> (x:same) : (diff /~ eq)+{-+$B$J$*!$>e5-(B(/)$B$*$h$S2<5-(Bnub$B$N>l9g!$L58B%j%9%H$G$b$$$1$k!%(B+*T10> let {[] / eq = []; (x:xs) / eq = case partition (x `eq`) xs of (same, diff) -> (x:same) : (diff / eq)}+*T10> cycle "hogeha" / (==)+["hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhh+(snip)+hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhInterrupted.+*T10> map head $ cycle "hogeha" / (==)+"hogeaInterrupted.+*T10> Data.List.nub $ cycle "hogeha"+"hogeaTerminated+(snip)+*T10> Data.List.nub $ repeat 'h'+"hTerminated+-}+++++-- ToDo: deal with timeout+++++-- complete set of representatives+nubSortBy :: (a->a->Ordering) -> [a] -> [a]+nubSortBy = mergesortWithBy const+nubSortByBot :: (a->a->Maybe Ordering) -> [a] -> [a]+nubSortByBot = mergesortWithByBot const+-- quotient set+(/<) :: [a] -> (a->a->Ordering) -> [[a]]+xs /< cmp = mergesortWithBy (++)+ (\x y -> head x `cmp` head y)+ (map return xs)+(/<?) :: [a] -> (a->a->Maybe Ordering) -> [[a]]+xs /<? cmp = mergesortWithByBot (++)+ (\x y -> head x `cmp` head y)+ (map return xs)+class Eq rel => Relation rel where+ -- remove duplicates, and sort if |rel==Ordering|+ fromListBy :: (k->k->rel) -> [k] -> [k]+ fromListBy cmp = map head . (/cmp)+-- used to pick up the shallowest expression in |DBound|+ fromListByDB :: (k->k->rel) -> [(k,Int)] -> [(k,Int)]+ fromListByDB rel ts =+ map (minimumBy (\x y -> compare (snd y) (snd x)))+ (ts / (\x y -> rel (fst x) (fst y)))+ -- \NB : |maximumBy| returns the last of the maxima,+ -- while |minimumBy| the first of the minima.+ -- quotient set+ (/) :: [k] -> (k->k->rel) -> [[k]]+ -- merge two lists, + appendWithBy :: (k->k->k) -> -- combiner+ (k->k->rel) -> [k] -> [k] -> [k]+ diffBy :: (k -> k -> rel) -> [k] -> [k] -> [k]+ -- counterpart of EQ+ cEQ :: rel+-- merge two quotient sets+appendQuotientsBy ::+ (Relation rel) =>+ (k -> k -> rel) -> [[k]] -> [[k]] -> [[k]]+appendQuotientsBy rel =+ appendWithBy (++) (\ (x:_) (y:_) -> x `rel` y)+-- merge two complete sets of representatives+appendRepresentativesBy ::+ (Relation rel) =>+ (k -> k -> rel) -> [k] -> [k] -> [k]+appendRepresentativesBy = appendWithBy const++instance Relation Bool where+ fromListBy = Data.List.nubBy+ (/) = (/~)+ appendWithBy = unionWithBy+ diffBy = Data.List.deleteFirstsBy+ cEQ = True+unionWithBy combiner eq [] ys = ys+unionWithBy combiner eq (x:xs) ys =+ case break (eq x) ys of+ (_, []) -> x : unionWithBy combiner eq xs ys+ (ts, h:ds) -> (x `combiner` h)+ : unionWithBy combiner eq xs (ts++ds)+instance Relation Ordering where+ fromListBy = nubSortBy+ fromListByDB rel =+ mergesortWithBy+ (\x y -> if snd x < snd y then y else x)+ (\x y -> fst x `rel` fst y)+ (/) = (/<)+ appendWithBy = mergeWithBy+ diffBy = diffSortedBy+ cEQ = EQ+instance Relation (Maybe Ordering) where+ fromListBy = nubSortByBot+ fromListByDB rel =+ mergesortWithByBot+ (\x y -> if snd x < snd y then y else x)+ (\x y -> fst x `rel` fst y)+ (/) = (/<?)+ appendWithBy = mergeWithByBot+ diffBy = diffSortedByBot+ cEQ = Just EQ++randomTestFilter :: (SStrategy m, Filtrable a) =>+ m (e,a) -> m (e,a)+randomTestFilter = filt . fmap (\ t@(_,a) -> (a,t))++unsafeRandomTestFilter :: (SStrategy m, Filtrable a) =>+ Maybe Int -- ^ microsecs until timeout+ -> m (e,a) -> m (e,a)+unsafeRandomTestFilter mto = unsafeFilt mto . fmap (\ t@(_,a) -> (a,t))++mapFst f (a,b) = (f a, b)++class Filtrable a where+ filt :: SStrategy m => m (a,e) -> m e+ filtFun :: (SStrategy m, Arbitrary b) =>+ m (b->a,e) -> m e+ unsafeFilt :: SStrategy m =>+ Maybe Int ->m (a,e) -> m e+ unsafeFiltFun :: (SStrategy m, Arbitrary b) =>+ Maybe Int -> m (b->a,e) -> m e++instance (Arbitrary a, Filtrable r) => Filtrable (a->r)+ where+ filt = filtFun+ filtFun = filt . fmap (mapFst uncurry)+ unsafeFilt mto = unsafeFiltFun mto+ unsafeFiltFun mto = unsafeFilt mto . fmap (mapFst uncurry)++#ifdef TESTEQ+instance Eq a => Filtrable a where+ filt = filtNullary (==)+ filtFun = filtUnary (==)+#else+instance Ord a => Filtrable a where+ filt = filtNullary compare+ filtFun = filtUnary compare+ unsafeFilt mto = filtNullary (unsafeOpWithPTO mto compare)+ unsafeFiltFun mto = filtUnary (unsafeOpWithPTO mto compare)+#endif+filtNullary :: (SStrategy m, Relation r) =>+ (k->k->r) -> m (k,e) -> m e+filtNullary op = fmap snd . ofilter op+filtUnary op = fmap snd . sfilter op .+ fmap (mapFst (flip map arbitraries))++instance (RealFloat a, Ord a) =>+ Filtrable (Complex a) where+ filt = filtNullary compareCx+ filtFun = filtUnary compareCx+ unsafeFilt mto = filtNullary (unsafeOpWithPTO mto compareCx)+ unsafeFiltFun mto = filtUnary (unsafeOpWithPTO mto compareCx)+compareCx :: (RealFloat a, Ord a) =>+ Complex a -> Complex a -> Ordering+(a:+b) `compareCx` (c:+d) = case compare a c of+ EQ -> compare b d+ o -> o+ofilterMx :: Relation r =>+ (k->k->r) -> Matrix (k,e) -> Matrix (k,e)+ofilterMx op (Mx xss)+ = let+ (k,_) `rel` (l,_) = k `op` l+ mapped = map (fromListBy rel) xss+ cumulative =+ scanl (appendRepresentativesBy rel)+ [] mapped+ in Mx $ zipWith (diffBy rel) mapped cumulative++ofilterDB :: Relation rel =>+ (k->k->rel) ->+ DBound (k,e) -> DBound (k,e)+ofilterDB cmp (DB f) = DB $+ \n -> fromListByDB (\(k,_) (l,_) -> cmp k l)+ (f n)++cumulativeRepresentatives ::+ Relation rel =>+ [a->a->rel] -> Matrix a -> Matrix a+cumulativeRepresentatives relations mx =+ fmap head (cumulativeQuotients relations mx)++representatives ::+ Relation rel =>+ [a->a->rel] -> Matrix a -> Matrix a+representatives relations mx = + unscanlByList relations $+ cumulativeRepresentatives relations mx+unscanlByList :: Relation r =>+ [k->k->r] -> Matrix k -> Matrix k+unscanlByList (_:rels) (Mx (yss@(xs:xss))) =+ Mx $ xs : zipWith3 diffBy rels xss yss++sfilterMx :: Relation r =>+ (k->k->r) -> + Matrix ([k],e) -> Matrix ([k],e)+sfilterMx rel = representatives (map (liftRelation rel) ns)+liftRelation :: Relation r =>+ (k->k->r) -> + Int -> ([k],e) -> ([k],e) -> r+liftRelation rel len (xs,_) (ys,_) = liftRel rel len xs ys+liftRel _ 0 _ _ = cEQ+liftRel rel len (x:xs) (y:ys) =+ case rel x y of+ c | c == cEQ -> liftRel rel (len-1) xs ys+ | otherwise -> c++sfilterDB :: Relation rel =>+ (k->k->rel) ->+ DBound ([k],e) -> DBound ([k],e)+sfilterDB rel (DB f) = DB $ \n ->+ fromListByDB (liftRelation rel (ns!!n))+ (f n)++cumulativeQuotients relations (Mx xss)+ = let yss:ysss = zipWith (/) xss relations+ in Mx $ scanl (\rec (r,z) ->+ appendQuotientsBy r (rec>>=(/r)) z)+ yss (zip (tail relations) ysss)++ns = [6..]
+ MagicHaskeller/Classify.hs view
@@ -0,0 +1,322 @@+-- +-- (c) Susumu Katayama 2009+--+{-# OPTIONS -XMagicHash -cpp #-}+module MagicHaskeller.Classify(randomTestFilter, filterBF, filterRc, filterDB -- , filterDBPos+ , ofilterDB, opreexecute, CmpBot -- used by ClassifyDM.hs+ , diffSortedBy, diffSortedByBot, FiltrableBF+ ) where++import Control.Monad.Search.Combinatorial+-- import Types(Subst) -- Subst¤Ëspecialize¤¹¤ëɬÍפϤʤ¤¤±¤É¡¥+import Data.Maybe+import Control.Monad(mplus)++import MagicHaskeller.Instantiate+import GHC.Exts(unsafeCoerce#)+-- import Data.Array((!))+import MagicHaskeller.Execute(unsafeExecute) -- :: CoreExpr -> a+import MagicHaskeller.TyConLib+import MagicHaskeller.Types+import MagicHaskeller.DebMT+import MagicHaskeller.MyDynamic+#ifdef CHTO+import System.IO.Unsafe+import MagicHaskeller.TimeOut+import Control.Concurrent(yield)+import MagicHaskeller.MHTH(maybeWithPTO)+import Data.IORef+#endif+import MagicHaskeller.T10(nlambda, mergesortWithBy, mergeWithBy, mergesortWithByBot, mergeWithByBot)++#ifdef DEBUG+import Test.QuickCheck+#endif++import MagicHaskeller.Expression++import MagicHaskeller.ProgramGenerator++import Language.Haskell.TH.Ppr+-- import ReadLambdaExpr(exprToTHExp)+-- import ToString++import System.IO+-- import Debug.Trace+trace str e = e+++-- randomTestFilter :: MemoDeb -> Matrix CoreExpr -> Matrix CoreExpr, but I do not like to import ProgGen.+-- randomTestFilter (_,_,tcl,rtrie) typ = toMx . filterDB' id tcl rtrie typ . fromMx+randomTestFilter md = filterBF (extractTCL md) (extractRTrie md) (timeout $ opt $ extractCommon md)+filterBF :: FiltrableBF m => TyConLib -> RTrie -> Maybe Int -> Type -> m AnnExpr -> m AnnExpr+filterBF tcl rtrie pto typ+ = case trace (show typ) $+ typeToRandomsOrd tcl rtrie typ of+ Nothing -> id+ Just ([], op) -> fmap snd . ofilter op . fmap opreexecute+-- Just (rnds,op) -> unscanl . fmap snd . repEqClsBy_simple op . fmap (spreexecute rnds) -- Feb. 10, 2007¤Înotes¤ÎºÇ¸å¤ÎÊդ껲¾È¡¥Matrix¤Î¾ì¹ç¤Í¡¥+ Just (rnds,op) -> fmap snd . sfilter (op,pto) . fmap (spreexecute (uncurryDyn (mkUncurry tcl) typ) rnds)+spreexecute uncurrier rnds e@(AE _ dyn) = let f = uncurrier dyn in (map (dynApp f) rnds, e)++opreexecute :: AnnExpr -> (Dynamic, AnnExpr)+opreexecute e@(AE _ dyn) = (dyn, e)++unscanl :: Ord e => Matrix e -> Matrix e+unscanl = unscanlBy compare++type CmpBot k = (k->k->Ordering, Maybe Int) -- Comparison that can return a bottom (i.e., either timeout or error).++class Search m => FiltrableBF m where+ sfilter :: CmpBot k -> m ([k],e) -> m ([k],e)+ ofilter :: (k->k->Ordering) -> m (k,e) -> m (k,e)+instance FiltrableBF Matrix where+ sfilter = sfilterMx+ ofilter = ofilterMx+instance FiltrableBF Recomp where+ sfilter = sfilterRc+ ofilter = ofilterRc+instance FiltrableBF DBound where+ sfilter = sfilterDB+ ofilter = ofilterDB++-- x ¤³¤Î[([k],e)]¤ÎÉôʬ¤Ï¡¤ËÜÅö¤Î¤È¤³¤íStreamTrie¤Ç¼ÂÁõ¤·¤¿Êý¤¬¸úΨŪ¤Ê¤Ï¤º¡¥++sfilterMx :: CmpBot k -> Matrix ([k],e) -> Matrix ([k],e)+-- sfilter op (Mx xss) = unscanlByList op $ foldr (mergeMxBy op) undefined (map (repEqClsBy op) xss)+-- x ¤³¤ì¤À¤È¡¤mergeMxBy¤¬¥×¥í¥°¥é¥à¥µ¥¤¥º¤Î¤³¤È¤òÃΤ餺¤ËºÇ½é¤Î1¸Ä¤Îkey¤ÎÈæ³Ó¤«¤é»Ï¤á¤Æ¤·¤Þ¤¦ ... ¤È»×¤Ã¤¿¤±¤É¼Â¤Ï¤½¤¦¤Ç¤â¤Ê¤¤¡¥mergeMxBy¤¬(Mx (_:ys))¤Î¤è¤¦¤ËÀèƬ¤òdrop¤¹¤ë¤Î¤¬¥Ý¥¤¥ó¥È¤Ç¡¤¤¿¤È¤¨¤Ð(map repEqClsBy xss) !! n¤ÏÀèƬ¤În¸Äʬ¤¬(·ë²Ì¤È¤·¤Æ)drop¤µ¤ì¤ë¤³¤È¤Ë¤Ê¤ë¡¥+-- x ¤ä¤Ã¤Ñ¥À¥á¡¥+-- x ¿ʬÌäÂê¤Ï¡¤eqClsBy¤Ï¿¼¤µ£²°Ê¹ß¤â¿¼¤µ£±¤Ëdepend¤·¤Æ¤¤¤Æ¡¤¤½¤¦¤Ê¤ë¤È¥µ¥¤¥º£²°Ê¹ß¤Î¥×¥í¥°¥é¥à¤¬...¤ß¤¿¤¤¤Ê´¶¤¸+sfilterMx op mx = trace "sfilterMx" $+ unscanlByList op $ repEqClsBy op mx++filterDB :: TyConLib -> RTrie -> Maybe Int -> Type -> DBound AnnExpr -> DBound AnnExpr+filterDB = filterBF+{-+filterDBPos :: TyConLib -> RTrie -> Type -> DBound (Possibility AnnExpr) -> DBound (Possibility AnnExpr)+filterDBPos tcl rtrie typ+ = case typeToRandomsOrd tcl rtrie typ of+ Nothing -> id+ Just ([], op) -> fmap snd . ofilterDBPos op . fmap (\(x,s,i) -> (map opreexecute x, s, i))+ Just (rnds,op) -> fmap snd . sfilterDBPos op . fmap (\(x,s,i) -> (fmap (spreexecuteNTO (uncurryDyn (mkUncurry tcl) typ) rnds) x, s, i))+-}+filterRc :: TyConLib -> RTrie -> Maybe Int -> Type -> Recomp AnnExpr -> Recomp AnnExpr+filterRc = filterBF++-- x ¤³¤Î[([k],e)]¤ÎÉôʬ¤Ï¡¤ËÜÅö¤Î¤È¤³¤íStreamTrie¤Ç¼ÂÁõ¤·¤¿Êý¤¬¸úΨŪ¤Ê¤Ï¤º¡¥++sfilterRc :: CmpBot k -> Recomp ([k],e) -> Recomp ([k],e)+-- sfilter op (Mx xss) = unscanlByList op $ foldr (mergeMxBy op) undefined (map (repEqClsBy op) xss)+-- x ¤³¤ì¤À¤È¡¤mergeMxBy¤¬¥×¥í¥°¥é¥à¥µ¥¤¥º¤Î¤³¤È¤òÃΤ餺¤ËºÇ½é¤Î1¸Ä¤Îkey¤ÎÈæ³Ó¤«¤é»Ï¤á¤Æ¤·¤Þ¤¦ ... ¤È»×¤Ã¤¿¤±¤É¼Â¤Ï¤½¤¦¤Ç¤â¤Ê¤¤¡¥mergeMxBy¤¬(Mx (_:ys))¤Î¤è¤¦¤ËÀèƬ¤òdrop¤¹¤ë¤Î¤¬¥Ý¥¤¥ó¥È¤Ç¡¤¤¿¤È¤¨¤Ð(map repEqClsBy xss) !! n¤ÏÀèƬ¤În¸Äʬ¤¬(·ë²Ì¤È¤·¤Æ)drop¤µ¤ì¤ë¤³¤È¤Ë¤Ê¤ë¡¥+-- x ¤ä¤Ã¤Ñ¥À¥á¡¥+-- x ¿ʬÌäÂê¤Ï¡¤eqClsBy¤Ï¿¼¤µ£²°Ê¹ß¤â¿¼¤µ£±¤Ëdepend¤·¤Æ¤¤¤Æ¡¤¤½¤¦¤Ê¤ë¤È¥µ¥¤¥º£²°Ê¹ß¤Î¥×¥í¥°¥é¥à¤¬...¤ß¤¿¤¤¤Ê´¶¤¸+sfilterRc op mx = trace "sfilter" $+ unscanlByListRc op $ repEqClsByRc op mx+{-+mergeReps :: (k->k->Ordering) -> Int -> [Matrix ([k],e)] -> Matrix ([k],e)+mergeReps op n ~(rs:rss) = trace "mergeReps" $+ mergeMxBy op n rs (mergeReps op (n+1) rss)+-}+++unscanlByList :: CmpBot k -> Matrix ([k],e) -> Matrix ([k],e)+unscanlByList op mx = case unMx mx of yss@(xs:xss) -> Mx (xs : zipWith3 (deleteListByList op) tcnrnds xss yss)++unscanlByListMx :: CmpBot k -> Matrix ([k],e) -> Matrix ([k],e)+unscanlByListMx op mx = zipDepth3Mx (\dep -> deleteListByList op (fcnrnd (1+dep))) mx (delay mx)++unscanlByListRc :: CmpBot k -> Recomp ([k],e) -> Recomp ([k],e)+unscanlByListRc op rc = zipDepth3Rc (\dep -> deleteListByList op (fcnrnd (1+dep))) rc (delay rc)+++deleteListByList cmp len xs ys = dlbBot (liftCompareBot len cmp) xs ys++comparers :: Int -> CmpBot a -> [([a],e) -> ([a],e) -> Maybe Ordering]+comparers m cmp = liftCompareBot m cmp : comparers (m+1) cmp++liftCompare :: Int -> (a->a->Ordering) -> ([a],e) -> ([a],e) -> Ordering+liftCompare m cmp (xs,_) (ys,_) = liftCmp m cmp xs ys+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 len cmp (x:xs) (y:ys) = trace "liftCmp" $+ case cmp x y of+ EQ -> trace "just eq" $+ liftCmp (len-1) cmp xs ys+ c -> trace "otherwise" + c++liftCompareBot :: Int -> CmpBot a -> ([a],e) -> ([a],e) -> Maybe Ordering+liftCompareBot m cmp (xs,_) (ys,_) = liftCmpBot m cmp xs ys+liftCmpBot :: Int -> CmpBot a -> [a] -> [a] -> Maybe Ordering+#ifdef CHTO+liftCmpBot len (cmp,pto) xs ys = unsafePerformIO $+ maybeWithPTO seq (return $ liftCmp len cmp xs ys) pto+{-+ | otherwise = liftCmpBot' len cmp xs ys+liftCmpBot' 0 _ _ _ = Just EQ+liftCmpBot' _ _ [] _ = Nothing+liftCmpBot' _ _ (_:_) [] = Nothing+liftCmpBot' len cmp (x:xs) (y:ys) = trace "liftCmpBot" $+ case unsafePerformIO $ maybeWithTO pto $ return $ cmp x y of+ Just EQ -> trace "just eq" $+ liftCmpBot' (len-1) cmp xs ys+ c -> trace "otherwise" + c+-}+#else+liftCmpBot len (cmp,_pto) xs ys = Just $ liftCmp len cmp xs ys+#endif+-- dlb = deleteListBy++dlbBot cmps xs ys = diffSortedByBot cmps xs ys+dlb cmps xs ys = diffSortedBy cmps xs ys+{-+dlbBot cmps xs ys = diffSortedByBot cmps (mergesortWithByBot undefined cmps xs) (mergesortWithByBot undefined cmps ys)+dlb cmps xs ys = diffSortedBy cmps (mergesortWithBy undefined cmps xs) (mergesortWithBy undefined cmps ys)+-}+diffSortedBy _ [] _ = []+diffSortedBy _ vs [] = vs+diffSortedBy op vs@(c:cs) ws@(d:ds) = case op c d of EQ -> diffSortedBy op cs ds+ LT -> c : diffSortedBy op cs ws+ GT -> diffSortedBy op vs ds+diffSortedByBot _ [] _ = []+diffSortedByBot _ vs [] = vs+diffSortedByBot op vs@(c:cs) ws@(d:ds) = case op c d of+ Just EQ -> diffSortedByBot op cs ds+ Just LT -> c : diffSortedByBot op cs ws+ Just GT -> diffSortedByBot op vs ds+ Nothing -> c : diffSortedByBot op cs ds -- I just do not know what is the best solution here, but when timeout happens, I temporarily believe @c@, and skip d.+++{-+repEqClsBy_simple :: (k->k->Ordering) -> Matrix ([k],e) -> Matrix ([k],e)+repEqClsBy_simple cmp (Mx xss) = Mx $ zipWith (\dep ys -> mergesortWithByBot const (liftCompareBot dep cmp) $ filterEligibles dep ys) cnrnds $ scanl1_recompute (++) xss+scanl1_recompute :: (a -> a -> a) -> [a] -> [a]+scanl1_recompute f xs = [ foldl1 f $ take i xs | i <- [1..] ]+-}++repEqClsBy_simple :: CmpBot k -> Matrix ([k],e) -> Matrix ([k],e)+repEqClsBy_simple cmp mx = Mx $ zipWith (\dep ys -> mergesortWithByBot const (liftCompareBot dep cmp) ys) cnrnds $ unMx $ scanl1BF mx++repEqClsByMx :: CmpBot k -> Matrix ([k],e) -> Matrix ([k],e)+repEqClsByMx cmp mx = zipDepthMx (\dep ys -> let n = fcnrnd dep in mergesortWithByBot const (liftCompareBot n cmp) ys) $ scanl1BF mx++repEqClsByRc :: CmpBot k -> Recomp ([k],e) -> Recomp ([k],e)+repEqClsByRc cmp mx = zipDepthRc (\dep ys -> let n = fcnrnd dep in mergesortWithByBot const (liftCompareBot n cmp) ys) $ scanl1BF mx++eqClsBy_naive :: CmpBot a -> Matrix ([a],b) -> Matrix [([a],b)]+eqClsBy_naive cmp (Mx xss) = Mx $ zipWith (\dep ys -> ys /// liftCompareBot dep cmp) cnrnds $ scanl1 (++) xss++{- ¿¾¯¸úΨ²½¤·¤è¤¦¤«¤È¤â»×¤Ã¤¿¤±¤É¡¤¤È¤ê¤¢¤¨¤º¤ÏËÜÅö¤Ënaive¤Ë¤ä¤ë+eqClsBy_naive cmp mx = scanl (mergeBy cmp) (eqClsByFstNs cmp mx)++scanlx cmp [a0,a1,...] = [a0, mergeBy +-}+++{-+ncmp = 5+fcnrnd = (1+ncmp+)+-}+fcnrnd n | n <= 5 = 5+ | otherwise = n+1+cnrnds = map fcnrnd [0..]+tcnrnds = tail cnrnds++-- repEqClsBy cmp = [([k]¤ÎºÇ½é¤Î1¸Ä¤Î¤ß¤ò¸«¤¿¤È¤¤ÎƱÃÍÎàʬ²ò¤ÎÂåɽ¸µ¤¿¤Á), ([k]¤ÎºÇ½é¤Î2¸Ä¤Î¤ß¤ò¸«¤¿¤È¤¤ÎƱÃÍÎàʬ²ò¤ÎÂåɽ¸µ¤¿¤Á), ([k]¤ÎºÇ½é¤Î3¸Ä¤Î¤ß¤ò¸«¤¿¤È¤¤ÎƱÃÍÎàʬ²ò¤ÎÂåɽ¸µ¤¿¤Á), ....]+repEqClsBy :: CmpBot k -> Matrix ([k],e) -> Matrix ([k],e)+repEqClsBy cmp = trace "repEqClsBy" . + fmap head . eqClsBy cmp+-- eqClsBy¤Î·ë²Ì¤Î¿¼¤µnÈÖÌܤˤϡ¤[k]¤ÎºÇ½é¤În¸Ä¤òcmp¤ÇÈæ³Ó¤·¤¿¤È¤¤ÎƱÃÍ´Ø·¸¤Ë¤è¤ëƱÃÍÎàʬ²ò¤¬Æþ¤Ã¤Æ¤¤¤ë¡¥+-- x ¿¼¤µ1¤Ç¥µ¥¤¥º1¤Ê¤ä¤Ä¤é¤òƱÃÍÎàʬ²ò : ¿¼¤µ1¤Ç¤Îʬ²ò·ë²Ì¤ò2ʸ»úÌܤÇƱÃÍÎàʬ²ò¤·¤¿¥ä¥Ä¤È¡¤¥µ¥¤¥º2¤Î¤ä¤Ä¤é¤ò2ʸ»úʬ¸«¤ÆƱÃÍÎàʬ²ò¤·¤¿¤ä¤Ä¤é¤ò¥Þ¡¼¥¸ : ¿¼¤µ2¤Ç¤Îʬ²ò·ë²Ì¤ò3ʸ»úÌܤÇƱÃÍÎàʬ²ò¤·¤¿Åۤȡ¤....+eqClsBy :: CmpBot a -> Matrix ([a],b) -> Matrix [([a],b)]+eqClsBy cb@(cmp,_) mx = Mx $+ scanl (\xs (n,ys) -> mergeBy (liftCompareBot n cb) (eqClsByNth cmp n xs) ys) ecb0 $ zip tcnrnds ecbs+{- scanl¤Î1¹Ô¤ÎÂå¤ï¤ê¤Ë¤³¤Ã¤Á¤ò»È¤Ã¤Æ¤¿¡¥+ let result = ecb0 : zipWith3 (\n xs ys -> mergeBy (liftCompareBot n cmp) (eqClsByNth n xs) ys) (tail cnrnds) result ecbs+ in result+-}+ where Mx (ecb0:ecbs) = eqClsByFstNs cb mx+-- n-2ÈÖÌܤÎequivalence¤Ç¤Îquotient set¤ò¸µ¤Ë¡¤n-1ÈÖÌܤÎequivalence¤ÇºÙʬ¡¥¤à¤·¤í¡¤refine¤È¤¤¤¦´Ø¿ô¤òÄêµÁ¤·¤¿Êý¤¬¤è¤¤?+eqClsByNth :: (a->a->Ordering) -> Int -> [[([a],e)]] -> [[([a],e)]]+eqClsByNth cmp n = concatMap ((/// (\ (xs,_) (ys,_) -> Just $ cmp (xs!!(n-1)) (ys!!(n-1)))))++eqClsByFstNs :: CmpBot a -> Matrix ([a],b) -> Matrix [([a],b)]+eqClsByFstNs cmp (Mx tss) = Mx $ zipWith eqClsByFstN cnrnds tss+ where eqClsByFstN n = (/// liftCompareBot n cmp)++isLongEnough 0 _ = True+isLongEnough _ [] = False+isLongEnough n (x:xs) = isLongEnough (n-1) xs++-- This used to be used as a preprocessor of sorting, but such use turned out to be no use for efficiency and make timeout-related discussion more complicated. Search filterEligibles in notes.+filterEligibles :: Int -> [([k],e)] -> [([k],e)]+#ifdef CHTO+filterEligibles n = filter (isLongEnough n . fst)+#else+filterEligibles _ = id+#endif++mergeBy :: (k -> k -> Maybe Ordering) -> [[k]] -> [[k]] -> [[k]]+mergeBy cmp = mergeWithByBot (++) (\x y -> head x `cmp` head y)+-- ¤³¤ÎÊÕ(mergeBy)¤Î¥Í¡¼¥ß¥ó¥°¤â¤¤¤Þ¤¤¤Á++{-+mergeMxBy :: (k->k->Ordering) -> Int -> Matrix ([k],e) -> Matrix ([k],e) -> Matrix ([k],e)+mergeMxBy op len (Mx ~(xs:xss)) (Mx yss) = Mx (xs : zipWith3 (\i xs ys -> mergeBy (\ (ks,_) (ls,_) -> liftCmp i op ks ls) i (filterEligibles i xs) (filterEligibles i ys)) [len..] xss yss)+-- merge¤Ïtrie¤Ë¤ª¤±¤ëunionBy¤ß¤¿¤¤¤Ê´¶¤¸¡¥+mergeBy :: (k->k->Ordering) -> Int -> [k] -> [k] -> [k]+mergeBy op len xs ys = foldl (insertBy (\x y -> op x y == EQ)) xs ys+insertBy :: (k->k->Bool) -> [k] -> k -> [k]+insertBy op xs y = case filter (op y) xs of [] -> y:xs -- ÀèƬ¤ËµÕ½ç¤Ë²Ã¤¨¤ÆOK¤À¤Ã¤¿¤È¤Ï»×¤¦¤Î¤À¤¬¡¤°ì±þµ¤¤òÉÕ¤±¤ë+ _ -> xs+-}++sfilterDB :: CmpBot k -> DBound ([k],e) -> DBound ([k],e)+sfilterDB cmp (DB f) = DB $ \n -> mergesortWithByBot (\x@(_,i) y@(_,j) -> if i<j then y else x) (\(k,_) (l,_) -> liftCompareBot (fcnrnd n) cmp k l) (f n)+ofilterDB :: (k->k->Ordering) -> DBound (k,e) -> DBound (k,e)+ofilterDB cmp (DB f) = DB $ \n -> mergesortWithBy const (\((k,_),_) ((l,_),_) -> cmp k l) (f n)++ofilterRc :: (k->k->Ordering) -> Recomp (k,e) -> Recomp (k,e)+ofilterRc cmp rc = let sorted = mergesortDepthWithBy const op rc+ cumulative = scanlRc (mergeWithBy const op) [] sorted+ in zipDepth3Rc (\_ -> diffSortedBy op) sorted cumulative+ where op (k,_) (l,_) = cmp k l++ofilterMx :: (k->k->Ordering) -> Matrix (k,e) -> Matrix (k,e)+ofilterMx cmp (Mx xss) = let sorted = map (mergesortWithBy const op) xss+ cumulative = scanl (mergeWithBy const op) [] sorted+ in Mx $ zipWith (diffSortedBy op) sorted cumulative+ where op (k,_) (l,_) = cmp k l+{- ¤³¤Ã¤Á¤ÎÄêµÁ¤À¤È¡¤sorted¤Ç¤Ï¤Ê¤¯cumulative¤«¤é[]:cumulative¤ò°ú¤¯¤Î¤Ç¡¤¤Á¤ç¤Ã¤ÈÈó¸úΨ+ofilterMx cmp (Mx xss) = unscanlBy op $ Mx $ scanl1 (mergeWithBy const op) $ map (mergesortWithBy const op) xss+ where op (k,_) (l,_) = cmp k l+-}+{-+ofilterMx cmp (Mx xss) = unscanlBy op $ Mx $ map (map head . (/// (\x y -> Just (op x y)))) $ scanl1 (++) xss+ where op (k,_) (l,_) = cmp k l+-}+unscanlBy :: (k->k->Ordering) -> Matrix k -> Matrix k+unscanlBy op (Mx yss@(xs:xss)) = Mx (xs : zipWith (diffSortedBy op) xss yss)++-- quotient set+(///) :: [a] -> (a->a->Maybe Ordering) -> [[a]]+ts /// cmp = mergesortWithByBot (++) (\x y -> head x `cmp` head y) $ map return ts+++#ifdef DEBUG+-- Properties++-- prop_sfilter = \x y i j hoge -> i /= j ==> (head $ unMx $ sfilter compare $ Mx ([([i],x),([j],y)]:hoge)) == sortBy (\k l -> compare (fst k) (fst l)) [([i],x),([j],y)::([Int],Int)]+prop_sfilter_exhaustive = \yss -> all longenough (concat yss) && unique (concat yss) && length yss < 6 ==> let xss = map (map (\x -> (x,()))) yss in length (concat $ take 10 $ unMx $ sfilter (compare,Nothing) $ Mx (xss ++ repeat [])) == length (concat xss :: [([Int],())])++-- example: quickCheck (prop_sfilter 10 :: Propsf Int)+type Propsf a = [[[a]]] -> Property+prop_sfilter :: Ord a => Int -> Propsf a+prop_sfilter m = \yss -> length yss < m && all longenough (concat yss) ==> let xss = map (map (\x -> (x,()))) yss in (concat xss /// liftCompareBot m (compare,Nothing)) == (concat (take m (unMx $ sfilter (compare,Nothing) (Mx (xss ++ repeat [])))) /// liftCompareBot m (compare,Nothing))++unique [] = True+unique (x:xs) = all (/=x) xs && unique xs+longenough ks = length ks > 3+ncmp+#endif
+ MagicHaskeller/ClassifyDM.hs view
@@ -0,0 +1,125 @@+-- +-- (c) Susumu Katayama 2009+--+module MagicHaskeller.ClassifyDM(filterDM, filterList, filterListDB, filterDMlite, spreexecuteDM) where -- , filterDMTI) where++import Control.Monad.Search.Combinatorial+import Data.Maybe++import MagicHaskeller.Instantiate+import MagicHaskeller.Types+import MagicHaskeller.TyConLib+import MagicHaskeller.DebMT+import MagicHaskeller.MyDynamic+#ifdef CHTO+import System.IO.Unsafe+import MagicHaskeller.TimeOut+import MagicHaskeller.MHTH(unsafeWithPTO)+import Data.IORef+#endif+import MagicHaskeller.T10(mergesortWithBy, mergesortWithByBot)+import MagicHaskeller.PriorSubsts+import MagicHaskeller.Classify(opreexecute, ofilterDB, CmpBot) -- ofilterDB ¤Ï¤³¤Ã¤Á¤ÇÄêµÁ¤µ¤ì¤Æ¤¤¤Æ¤â¤¤¤¤¤è¤¦¤Ê¤â¤Î¡¥++import MagicHaskeller.Expression++import MagicHaskeller.ProgramGenerator(Opt(..), Common(..))++select :: DBound ([[Dynamic]], AnnExpr) -> DBound ([Dynamic], AnnExpr)+-- select (DB f) = DB $ \n -> map (\((xss,ae),i) -> (((xss!!n), ae),i)) $ f n+select = zipDepthDB $ \d -> map (\((xss,ae),i) -> (((xss!!d), ae),i))++spreexecuteDM :: (Dynamic->Dynamic) -> [[Dynamic]] -> AnnExpr -> ([[Dynamic]], AnnExpr)+spreexecuteDM uncurrier rnds e@(AE _ dyn) = let f = uncurrier dyn in (map ({- forceList . -} map (dynApp f)) rnds, e)++sprDM :: (Dynamic->Dynamic) -> [[Dynamic]] -> AnnExpr -> Int -> ([Dynamic], AnnExpr)+sprDM unc rnds e db = case spreexecuteDM unc rnds e of (xss, ae) -> (xss!!db, ae)++forceList :: [a] -> [a]+forceList [] = []+forceList xs@(y:ys) = y `seq` forceList ys `seq` xs++-- filterList is convenient if inter-depth filtration is unnecessary (e.g. when you want to do complementary filtration).+filterList :: Common -> Type -> Int -> [AnnExpr] -> [AnnExpr]+filterList cmn typ db+ = case typeToRandomsOrdDM (nrands $ opt cmn) (tcl cmn) (rt cmn) typ of+ Nothing -> id+ Just ([], op) -> -- fmap snd . ofilterDB op . fmap opreexecute+ mergesortWithBy const (\(AE _ k) (AE _ l) -> op k l)+ Just (rndss,op) -> -- fmap snd . sfilterDM (nrands $ opt cmn) op . select . fmap (spreexecuteDM (uncurryDyn (mkUncurry $ tcl cmn) typ) rndss)+ map snd .+ mergesortWithByBot const+ (nthCompareBot (nrands $ opt cmn) db (op, timeout $ opt cmn)) .+ map (\ae -> sprDM (uncurryDyn (mkUncurry $ tcl cmn) typ) rndss ae db)+filterListDB :: Common -> Type -> [AnnExpr] -> DBound [AnnExpr]+filterListDB cmn typ aes+ = DB $ \db -> [(filterList cmn typ db aes,db)]++filterDM :: Common -> Type -> DBound AnnExpr -> DBound AnnExpr+filterDM cmn typ+ = case typeToRandomsOrdDM (nrands $ opt cmn) (tcl cmn) (rt cmn) typ of+ Nothing -> id+ Just ([], op) -> -- fmap snd . ofilterDB op . fmap opreexecute+ mapDepthDB $ mergesortWithBy const (\((AE _ k),_) ((AE _ l),_) -> op k l)+ Just (rndss,op) -> -- fmap snd . sfilterDM (nrands $ opt cmn) op . select . fmap (spreexecuteDM (uncurryDyn (mkUncurry $ tcl cmn) typ) rndss)+ zipDepthDB (\d -> map (\((_dyns,ae),i) -> (ae,i)) .+ mergesortWithByBot (\x@(_,i) y@(_,j) -> if i<j then y else x)+ (\(k,_) (l,_) -> nthCompareBot (nrands $ opt cmn) d (op, timeout $ opt cmn) k l) .+ map (\(ae,i) -> (sprDM (uncurryDyn (mkUncurry $ tcl cmn) typ) rndss ae d, i)))+-- depth bound(¤Ä¤Þ¤ê¡¤Int->[(a,Int)]¤Ë¤ª¤±¤ë°ú¿ô¤ÎInt)¤ÎÂå¤ï¤ê¤Ë¡¤depth bound¤«¤é¤Îµ÷Î¥(¤Ä¤Þ¤ê¡¤Int->[(a,Int)]¤Ë¤ª¤±¤ëInt->[(a,¤³¤³¤ÎInt)])¤ò»È¤Ã¤Ænrnds¤Î²¿ÈÖÌܤ«¤ò·è¤á¤ë¤â¤Î¡¥+-- filterDM¤È°ã¤Ã¤Æ¡¤Æ±¤¸depth bound¤Ç¤â°ã¤¦Íð¿ô¤ò»È¤¦¤Î¤Ç¡¤filterListƱÍÍdepth¤ò¸Ù¤¤¤Àfiltration¤¬¤Ç¤¤º¡¤·ë²Ì¤Ï¤¤¤Þ¤¤¤Á¡¥+-- ¤¿¤À¤·¡¤dynamic¤Ê´Ø¿ô¼«ÂΤò¥á¥â²½¤¹¤ì¤Ð¡¤³ÊÃʤ˥á¥â¤Ë¥Ò¥Ã¥È¤·¤ä¤¹¤¯¤Ê¤ë¤Ï¤º¡¥+filterDMlite :: Common -> Type -> DBound AnnExpr -> DBound AnnExpr+filterDMlite cmn typ+ = case typeToRandomsOrdDM (nrands $ opt cmn) (tcl cmn) (rt cmn) typ of+ Nothing -> id+ Just ([], op) -> -- fmap snd . ofilterDB op . fmap opreexecute+ mapDepthDB $ mergesortWithBy const (\((AE _ k),_) ((AE _ l),_) -> op k l)+ Just (rndss,op) -> -- fmap snd . sfilterDM (nrands $ opt cmn) op . select . fmap (spreexecuteDM (uncurryDyn (mkUncurry $ tcl cmn) typ) rndss)+ zipDepthDB (\d -> map (\((_dyns,ae),i) -> (ae,i)) .+ shrink const (\k l -> nthCompareBot (nrands $ opt cmn) d (op, timeout $ opt cmn) k l) d .+ 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 n cmp (x:xs) (y:ys) = case cmp x y of EQ -> listCmp (n-1) cmp xs ys+ c -> c++nthCompareBot :: [Int] -> Int -> CmpBot a -> ([a],e) -> ([a],e) -> Maybe Ordering+nthCompareBot nrnds m cmp (xs,_) (ys,_) = listCmpBot (nrnds !! m) cmp xs ys+listCmpBot :: Int -> CmpBot a -> [a] -> [a] -> Maybe Ordering+#ifdef CHTO+listCmpBot len (cmp,pto) xs ys = unsafeWithPTO pto $ listCmp len cmp xs ys+#else+listCmpBot len cmp xs ys = Just $ listCmp len cmp xs ys+#endif+++sfilterDM :: [Int] -> CmpBot k -> DBound ([k],e) -> DBound ([k],e)+-- sfilterDM nrnds cmp (DB f) = DB $ \n -> mergesortWithByBot (\x@(_,i) y@(_,j) -> if i<j then y else x) (\(k,_) (l,_) -> nthCompareBot nrnds n cmp k l) (f n)+sfilterDM nrnds cmp = zipDepthDB $ \d -> mergesortWithByBot (\x@(_,i) y@(_,j) -> if i<j then y else x) (\(k,_) (l,_) -> nthCompareBot nrnds d cmp k l)+{-+uniqDM :: (k->k->Ordering) -> DBound ([[k]],e) -> DBound ([[k]],e)+uniqDM cmp (DB f) = DB $ \n -> uniqByBot (\x@(_,i) y@(_,j) -> if i<j then y else x) (\(k,_) (l,_) -> nthCompareBot n cmp k l) (f n)++uniqByBot combiner op = ubb+ where ubb (x:xs@(y:ys)) = case x `op` y of Nothing -> ubb ys+ Just EQ -> ubb (combiner x y : ys)+ Just LT -> x : ubb xs+ Just GT -> y : ubb (x:ys)+ ubb x = x++filterDMTI :: TyConLib -> RTrie -> Type -> DBoundT (PriorSubsts []) AnnExpr -> DBoundT (PriorSubsts []) AnnExpr+filterDMTI tcl rtrie typ+ = case typeToRandomsOrdDM tcl rtrie typ of+ Nothing -> id+ Just ([], op) -> fmap snd . ofilterDBTI op . fmap opreexecute+ Just (rndss,op) -> fmap snd . sfilterDMTI op . fmap (spreexecuteDM (uncurryDyn (mkUncurry tcl) typ) rndss)++ofilterDBTI :: Functor f => (k->k->Ordering) -> DBoundT f (k,e) -> DBoundT f (k,e)+ofilterDBTI cmp (DBT f) = DBT $ \n -> fmap (mergesortWithBy (\x@(_,i) y@(_,j) -> if i<j then y else x) (\((k,_),_) ((l,_),_) -> cmp k l))+ (f n)+sfilterDMTI :: (k->k->Ordering) -> DBoundT (PriorSubsts []) ([[k]],e) -> DBoundT (PriorSubsts []) ([[k]],e)+sfilterDMTI cmp (DBT f) = DBT $ \n -> fmap (mergesortWithByBot (\x@(_,i) y@(_,j) -> if i<j then y else x) (\(k,_) (l,_) -> nthCompareBot n cmp k l))+ (f n)+-}
+ MagicHaskeller/ClassifyTr.hs view
@@ -0,0 +1,103 @@+-- +-- (c) Susumu Katayama 2009+--+module MagicHaskeller.ClassifyTr where+import MagicHaskeller.T10+import Control.Monad.Search.Combinatorial+import Control.Monad+import MagicHaskeller.MHTH(unsafeWithPTO)++-- Just for filterTr+import MagicHaskeller.MyDynamic+import MagicHaskeller.Instantiate+import MagicHaskeller.Expression+import MagicHaskeller.ProgramGenerator(Opt(..), Common(..))+import MagicHaskeller.Types+import MagicHaskeller.ClassifyDM(spreexecuteDM)+++import Debug.Trace++filterTr :: Common -> Type -> Matrix AnnExpr -> (Stream (Forest ([Dynamic], AnnExpr)), Stream (Forest ([Dynamic], AnnExpr)), Matrix AnnExpr)+filterTr cmn typ+ = case typeToRandomsOrdDM nrnds (tcl cmn) (rt cmn) typ of+ Nothing -> \x -> (undefined, undefined, x)+ Just ([], op) -> \x -> (undefined, undefined, mapDepth (mergesortWithBy const (\(AE _ k) (AE _ l) -> op k l)) x)+ Just (rndss,op) -> -- trace ("take 1 rndss = "++show (take 1 rndss)) $ -- nrndss¤òɽ¼¨¤·¤è¤¦¤È¤¹¤ë¤Èbehaviour¤¬ÊѤï¤ë¡¥+ -- trace ("ty = "++show typ++" and take 10 nrands = "++show (take 10 $ nrands $ opt cmn)) $+ let finrndss = zipWith take nrnds rndss+ unsafeCmp ks ls = unsafeWithPTO (timeout $ opt cmn) (bagCmp op ks ls)+ in mkTip unsafeCmp . fmap (spreexecuteDM (uncurryDyn (mkUncurry $ tcl cmn) typ) finrndss)+ where nrnds = nrands $ opt cmn+bagCmp :: (a->a->Ordering) -> [a] -> [a] -> Ordering+bagCmp _ [] [] = EQ+bagCmp cmp (x:xs) (y:ys) = case cmp x y of EQ -> bagCmp cmp xs ys+ c -> c+-- other cases should not happen++type Forest k = [Tree k]+data Tree k = Tr k (Forest k) deriving Show++prop_mkTip mx = let mxx = fmap (\(f,e) -> (map f [0..], e)) mx+ (_,_,res) = mkTip (\ks ls -> Just (compare ks ls)) mxx+ in take 10 (unMx res) == take 10 (unMx res)++mkTip :: -- Show expr =>+ (key->key->Maybe Ordering) -> Matrix (Stream key, expr) -> (Stream (Forest (key, expr)), Stream (Forest (key, expr)), Matrix expr)+mkTip cmp mx = let fs = mkForests cmp mx+ cmpFst (x,_) (y,_) = cmp x y+ acc = accumulateForests cmpFst fs+ filtered = fmap snd $ difference cmpFst fs ([]:acc)+ in (fs, acc, filtered)+++mkForests :: (k->k->Maybe Ordering) -> Matrix (Stream k, r) -> Stream (Forest (k,r))+mkForests cmp (Mx xss) = map (mkForest cmp) xss+{-+mkForests :: Show r => (k->k->Ordering) -> Matrix (Stream k, r) -> Stream (Forest (k,r))+mkForests cmp (Mx xss) = map (\xs -> trace ("before filtration"++ show (map snd xs)) $+ mkForest cmp xs) xss+-}+mkForest :: (k->k->Maybe Ordering) -> [(Stream k,r)] -> Forest (k,r) -- Stream k¤Ê¤Î¤Ç¡¤[(Stream k,r)]¤ò¤¢¤é¤«¤¸¤á¥½¡¼¥È¤Ç¤¤Ê¤¤¤³¤È¤ËÃí°Õ¡¥+mkForest cmp = map (\(k,ts@((_,r):_)) -> Tr (k, r) (mkForest cmp ts)) . mergesortWithByBot (\(k,xs) (_,ys) -> (k,xs++ys)) (\(k,_) (l,_) -> cmp k l) . map (\(k:ks, r) -> (k,[(ks,r)]))+-- ¤â¤¦°ì¤Ä¤Î¼ÂÁõÊýË¡: ¤É¤Ã¤Á¤¬¸úΨŪ¤«¤Ï? mkForest cmp [(ks,r)]¤Ï[mkTree cmp ks r]¤ß¤¿¤¤¤Ëspecialize¤·¤¿¤â¤Î¤òÍÑ°Õ¤·¤¿Êý¤¬¤¤¤¤¤«¤â¡¥+-- mkForest cmp = map (\(Tr k ts@(Tr (_,r) _ : _)) -> Tr (k, r) ts) . mergesortWithBy (\(Tr k xs) (Tr _ ys) -> Tr k (mergeForests xs ys)) (\(Tr (k,_) _) (Tr (l,_) _) -> cmp k l) . map (\(k:ks, r) -> (k, mkForest cmp [(ks,r)]))+++accumulateForests :: (k->k->Maybe Ordering) -> Stream (Forest k) -> Stream (Forest k)+accumulateForests cmp forests = cumulatives+ where cumulatives = zipWith (mergeForests cmp) ([]:cumulatives) forests+-- merge¤Ã¤Æ¤Î¤ÏmonoidŪ¤Ë¤Ïmappend¤Ê¥ï¥±+mergeForests :: (k->k->Maybe Ordering) -> Forest k -> Forest k -> Forest k+mergeForests _ [] trs = trs+mergeForests _ tls [] = tls+mergeForests cmp tls@((tl@(Tr kl fl)) : rls)+ trs@((tr@(Tr kr fr)) : rrs)+ = case cmp kl kr of Just LT -> tl : mergeForests cmp rls trs+ Just GT -> tr : mergeForests cmp tls rrs+ _ -> Tr kl (mergeForests cmp fl fr) : mergeForests cmp rls rrs++difference :: (k->k->Maybe Ordering) -> Stream (Forest k) -> Stream (Forest k) -> Matrix k+-- difference :: Show x => ((k,x)->(k,x)->Ordering) -> Stream (Forest (k,x)) -> Stream (Forest (k,x)) -> Matrix (k,x)+difference cmp mx cumulative+ = -- mapDepth (\xs -> trace ("after filtration" ++ show (map snd xs)) xs)$+ foldr (\x y -> x `mplus` delay y) undefined $ zipWith (diff cmp) mx cumulative+diff :: (k->k->Maybe Ordering) -> Forest k -> Forest k -> Matrix k+diff _ [] _ = mzero+diff _ tls [] = foldr1 mplus $ map flattenTr tls+diff cmp tls@((tl@(Tr kl fl)) : rls)+ trs@( Tr kr fr : rrs)+ = case cmp kl kr of Just LT -> flattenTr tl `mplus` diff cmp rls trs+ Just EQ -> delay (removeFirstOfFirst (diff cmp fl fr)) `mplus` diff cmp rls rrs+ _ -> diff cmp tls rrs+flattenTr :: Tree k -> Matrix k+flattenTr (Tr k f) = [k] `consMx` removeFirstOfFirst (msum $ map flattenTr f)++removeFirstOfFirst mx@(Mx ([]:xss)) = mx+removeFirstOfFirst (Mx ((_:xs):xss)) = Mx $ xs:xss -- ¤³¤ì¤¬Ä¹»Ò¤ò¼è¤ê½ü¤¯+++{-+*MagicHaskeller.ClassifyTr> case mkTip compare (Mx (((repeat 1, 1):(repeat 1, 2):[]) : repeat [])) of (_,_,x) -> x+Mx {unMx = [[1],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],+-}
+ MagicHaskeller/Combinators.hs view
@@ -0,0 +1,12 @@+-- +-- (c) Susumu Katayama 2009+--+module MagicHaskeller.Combinators where+import MagicHaskeller.ExprStaged+import Language.Haskell.TH+import Debug.Trace+finiteHVss = $(do dss <- mapM (\lenavails -> mapM (\arity -> hdmnTHEQ arity lenavails) [0..maxArity]) [0..maxLenavails]+ return $ ListE $ map ListE dss)+finiteHVsss = $(do dsss <- mapM (\debindex -> mapM (\lenavails -> mapM (\arity -> aimnTHEQ debindex arity lenavails) [0..maxArity]) [debindex+1..maxLenavails]) [0..maxDebindex]+ -- trace (pprint $ ListE $ map (ListE . map ListE) dsss) $+ return $ ListE $ map (ListE . map ListE) dsss)
+ MagicHaskeller/CoreLang.lhs view
@@ -0,0 +1,124 @@+-- +-- (c) Susumu Katayama 2009+--+CoreLang.lhs+extracted haskell-src-free stuff that can be used with Hat.+(This looks like Bindging.hs....)++\begin{code}+{-# OPTIONS -cpp -fglasgow-exts -XExistentialQuantification #-}+-- workaround Haddock invoked from Cabal unnecessarily chasing imports. (If cpp fails, haddock ignores the remaining part of the module.)+#ifndef __GLASGOW_HASKELL__+-- x #hoge+#endif+++module MagicHaskeller.CoreLang where+import Language.Haskell.TH+import Data.Array++import Debug.Trace++import MagicHaskeller.MyDynamic++import Data.Char(chr,ord)++#ifdef FORCE+import Control.Parallel.Strategies+#endif+-- required to make sure expressions are ready, so we can measure the exact time consumed to execute the expressions before time out.++import Data.Bits+import Data.HashTable(hashInt, prime)++infixl :$+++data CoreExpr = S | K | I | B | C | S' | B' | C'+ | Lambda CoreExpr | X Int -- de Bruijn notation+ | Tuple Int+ | Primitive Int+ | CoreExpr :$ CoreExpr+ deriving (Read, Eq, Show, Ord)+-- required to make sure expressions are ready, so we can measure the exact time consumed to execute the expressions before time out.+#ifdef FORCE+instance NFData CoreExpr where+ rnf (Lambda e) = rnf e+ rnf (X i) = rnf i+ rnf (Tuple i) = rnf i+ rnf (Primitive _) = () -- ºÇ¸å¤Î¥Ñ¥¿¡¼¥ó¤Ë¥Þ¥Ã¥Á¤¹¤ë¤Î¤Ç¤³¤ì¤ÏÍפé¤Ê¤«¤Ã¤¿¤«¡¥+ rnf (c :$ d) = rnf c `seq` rnf d+ rnf e = ()+#endif++{- unused due to inefficiency+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++0 `interleave` 0 = 0+i `interleave` j = (j `interleave` (i `shiftR` 1)) * 2 + (i `mod` 2)+-- Integer¤Ç¤Ê¤¯Int¤ò»È¤¦¾ì¹ç¡¤»»½Ñ±¦¥·¥Õ¥ÈshiftR¤Ç¤Ê¤¯ÏÀÍý±¦¥·¥Õ¥È¤ò»È¤¦É¬Íפ¬¤¢¤ë...¤Î¤Ï¤¤¤¤¤±¤É¡¤¤Ê¤¼¥é¥¤¥Ö¥é¥ê¤ËÏÀÍý±¦¥·¥Õ¥È¤¬¤Ê¤¤?+logShiftR1 n = (n `clearBit` 0) `rotateR` 1 +-}++instance Enum CoreExpr where+ 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+m #* c = fromIntegral (hashInt m) + (c `mod` fromIntegral prime)++newtype HValue = HV (forall a. a)+instance Eq Dynamic where+ a == b = True+instance Ord Dynamic where+ compare a b = EQ+instance Read Dynamic where+ readsPrec _ str = [(error "Dynamics cannot be read.", str)]+instance Ord Exp where+ compare (VarE n0) (VarE n1) = n0 `compare` n1+ compare (VarE n0) _ = LT+ compare (ConE n0) (VarE n1) = GT+ compare (ConE n0) (ConE n1) = n0 `compare` n1+ compare (ConE n0) _ = LT+ compare (AppE _ _) (VarE _) = GT+ compare (AppE _ _) (ConE _) = GT+ compare (AppE e0 f0) (AppE e1 f1) = case compare e0 e1 of EQ -> compare f0 f1+ c -> c+ compare (AppE _ _) _ = LT++ compare a b = show a `compare` show b -- ĶÃÙ¤½¤¦....+instance Read Exp where+ readsPrec _ str = [(error "ReadS Exp is not implemented yet", str)]+++type VarLib = Array Int (Exp,Dynamic)++-- x Âè1°ú¿ô¤Îpl¤ÏArray Con String¤Ê¤ó¤À¤±¤É¡¤¤â¤¦Á´ÉôPrimitive¤ò»È¤¦¤³¤È¤Ë¤Ê¤Ã¤¿¤Î¤ÇÉÔÍס¥+-- exprToTHExp converts CoreLang.CoreExpr into Language.Haskell.TH.Exp+exprToTHExp :: VarLib -> CoreExpr -> Exp+exprToTHExp vl e = x2hsx (ord 'a'-1) e+ where x2hsx dep (Lambda e) = -- trace "Lambda" $+ case x2hsx (dep+1) e of LamE pvars expr -> LamE (pvar:pvars) expr+ expr -> LamE [pvar] expr+ where pvar = VarP $ mkName [chr (dep+1)]+ x2hsx dep (X n) = VarE (mkName [chr (dep - n)]) -- X n¤ÏX 0, X 1, ....+-- x2hsx _ (Qualified con) = VarE (mkName (pl ! con))+ x2hsx _ (Primitive n) = fst (vl ! n)+ x2hsx dep (Primitive n :$ e0 :$ e1)+ = case fst (vl!n) of e@(VarE name) | head (nameBase name) `elem` "!@#$%&*+./<=>?\\^|-~"+ -> InfixE (Just $ x2hsx dep e0) e (Just $ x2hsx dep e1)+ e@(ConE name) | namestr == ":" -> case hsx1 of ListE hsxs -> ListE (hsx0 : hsxs)+ ConE n | nameBase n == "[]" -> ListE [hsx0]+ _ -> InfixE (Just hsx0) e (Just hsx1)+ | head namestr == ':' -> InfixE (Just hsx0) e (Just hsx1)+ where hsx0 = x2hsx dep e0+ hsx1 = x2hsx dep e1+ namestr = nameBase name+ e -> (e `AppE` x2hsx dep e0) `AppE` x2hsx dep e1+ x2hsx dep (e0 :$ e1) = x2hsx dep e0 `AppE` x2hsx dep e1+ x2hsx _ e = error ("exprToTHExp: converting" ++ show e)++\end{code}
+ MagicHaskeller/DebMT.lhs view
@@ -0,0 +1,88 @@+-- +-- (c) Susumu Katayama 2009+--++\begin{code}+{-# OPTIONS -cpp #-}+module MagicHaskeller.DebMT where+import MagicHaskeller.Types as Types+import MagicHaskeller.TyConLib+import Control.Monad++-- import CoreLang+import Control.Monad.Search.Combinatorial+import MagicHaskeller.PriorSubsts+import Data.Array++import MagicHaskeller.T10((!?))+++-- type MemoTrie = MapType (Matrix Possibility)+type Possibility e = (Bag e, Subst, Int)+data MapType a+ = MT {+ tvMT :: [a],+ tcMT :: [a],+ genMT :: [a], -- "forall" stuff+ taMT :: MapType (MapType a),+ funMT :: MapType (MapType a)+ }+{-+mapMT :: (Type -> a -> b) -> MapType a -> MapType b -- takes the index as an argument, like mapFM, but currently only the structures of the types are considered. +mapMT f (MT v e c g a u) = MT+ (maps (\tvid -> f (TV tvid)) v)+ (maps (\tcid -> f (TC tcid)) c)+ (maps (\tcid -> f (TC (-tcid-1))) c)+ (mapMT' 1 (\t0 -> mapMT (\t1 -> f (TA t0 t1))) a)+ (mapMT (\t0 -> mapMT (\t1 -> f (t1 :-> t0))) u)+mapMT' :: Kind -> (Type -> a -> b) -> MapType a -> MapType b+mapMT' k f (MT v e c g a u) = MT+ (maps (\tvid -> f (TV tvid)) v)+ (maps (\tcid -> f (TC tcid)) c)+ (maps (\tcid -> f (TC (-tcid-1))) c)+ (mapMT' (k+1) (\t0 -> mapMT (\t1 -> f (TA t0 t1))) a)+ (error "mapMT' : kind error")+maps :: (Int -> a -> b) -> [a] -> [b]+maps f xs = zipWith f [0..] xs+-- emptyMT = MT [] [] [] [] emptyMT emptyMT+-}++{- can be used to identify where "index too large" error is caused, even when +RTS -xc does not work.+[] !!?? n = error "(!!??): too large index."+(x:xs) !!?? 0 = x+(x:xs) !!?? n = xs !!?? (n-1)+-}++lookupMT :: MapType a -> Type -> a+-- lookupMT :: MonadPlus m => MapType (m a) -> Type -> (m a)+lookupMT mt (TV tv) = tvMT mt !! tv+lookupMT mt (TC tc) | tc < 0 = genMT mt !! (-1-tc)+ | otherwise = tcMT mt !! tc+lookupMT mt (TA t0 t1) = lookupMT (lookupMT (taMT mt) t0) t1+lookupMT mt (t0:->t1) = lookupMT (lookupMT (funMT mt) t0) t1+++retrieve :: Decoder -> Subst -> Subst+-- retrieve deco sub = let news = [ (decodeVar deco i, decode deco ty) | (i, ty) <- sub ] in trace ("sub = " ++ show sub ++ " and news = " ++ show news ++ " and deco = " ++ show deco) news+retrieve deco sub = [ (decodeVar deco i, decode deco ty) | (i, ty) <- sub ]++decode :: Decoder -> Type -> Type+decode deco t = mapTV (decodeVar deco) t+decodeVar (Dec tvs margin) tv = case tvs !? tv of Nothing -> tv+margin+ Just ntv -> ntv++encode :: Type -> Int -> (Type, Decoder)+encode = Types.normalizeVarIDs+++mkMT :: TyConLib -> (Type->a) -> MapType a+mkMT tcl f = mkMT' tcl 0 f+mkMT' :: TyConLib -> Kind -> (Type->a) -> MapType a+mkMT' tcl k f = MT tvTree tcTree genTree taTree funTree where+ tcs = snd tcl ! k+ tvTree = [ f (TV i) | i <- [0..] ]+ tcTree = [ f (TC i) | i <- [0..] ]+ genTree = [ f (TC i) | i <- [-1,-2..] ]+ taTree = mkMT' tcl (k+1) (\t0 -> mkMT tcl (\t1 -> f (TA t0 t1)))+ funTree = if k==0 then mkMT tcl (\t0 -> mkMT tcl (\t1 -> f (t0 :-> t1))) else error "mkMT': the kind of functions must always be *"+\end{code}
+ MagicHaskeller/Execute.hs view
@@ -0,0 +1,70 @@+-- +-- (c) Susumu Katayama 2009+--+{-# OPTIONS -XMagicHash #-}+module MagicHaskeller.Execute(unsafeExecute, unDeBruijn) where+import System.IO.Unsafe(unsafeInterleaveIO)+import MagicHaskeller.CoreLang+import GHC.Exts(unsafeCoerce#)+import Control.Concurrent(yield, ThreadId, throwTo)+import Control.Exception+import Control.Monad(mplus)+import MagicHaskeller.TyConLib+import Data.Array((!))++import MagicHaskeller.MyDynamic++import Language.Haskell.TH hiding (Type)++unDeBruijn e = undeb 0 e++undeb dep (Lambda e) = lambda (dep+1) (undeb (dep+1) e)+undeb dep (X n) = X (dep-n)+undeb dep (e0 :$ e1) = undeb dep e0 :$ undeb dep e1+undeb dep e = e++-- well, B' is not so efficient.+lambda :: Int -> CoreExpr -> CoreExpr+lambda v e | v `isFreeIn` e = K :$ e+lambda v (X n) = I+lambda v (f :$ x :$ y)+ | v `isFreeIn` f = if v `isFreeIn` x+ then B' :$ f :$ x :$ (lambda v y)+ else if v `isFreeIn` y+ then C' :$ f :$ (lambda v x) :$ y+ else S' :$ f :$ (lambda v x) :$ (lambda v y)+lambda v (x :$ y)+ | v `isFreeIn` x = B :$ x :$ lambda v y+ | v `isFreeIn` y = C :$ lambda v x :$ y+ | otherwise = S :$ lambda v x :$ lambda v y+v `isFreeIn` (f :$ x) = v `isFreeIn` f && v `isFreeIn` x+v `isFreeIn` (X n) = v /= n+v `isFreeIn` _ = True++-- checks if there is a free variable. usually used after unDeBruijn is applied and before tiExpression is applied. +-- $B$H;W$C$?$N$@$,!$(BtiExpression$B$,FbIt$G(BunDeBruijn$B$r8F$s$G$k!%(B+-- $B$d$C$Q(BtiExpression$B$G(Bfail$B;H$C$F%a%C%;!<%81?$s$@J}$,$h$$!)(B+freeVar :: CoreExpr -> Maybe String+freeVar (Lambda e) = freeVar e+freeVar (e0 :$ e1) = freeVar e0 `mplus` freeVar e1+freeVar _ = Nothing++-- Use haddock-2.2.2. Later (and much earlier) versions of haddock do not like quasi-quotes. See http://www.nabble.com/build-problems-on-Hackage-td21848164.html+unsafeExecute :: VarLib -> CoreExpr -> Dynamic+unsafeExecute vl e = exe (unDeBruijn e) where+ exe (e0 :$ e1) = dynAppErr "apply" (exe e0) (exe e1)+ exe (Primitive n) = snd (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 |])+ exe B = $(dynamic [|defaultTCL|] [| (.) :: (c->a) -> (b->c) -> b -> a |])+ exe C = $(dynamic [|defaultTCL|] [| flip :: (b->c->a) -> c -> b -> a |])+ exe S' = $(dynamic [|defaultTCL|] [| sprime :: (a->b->c)->(d->a)->(d->b)->d->c |])+ exe B' = $(dynamic [|defaultTCL|] [| bprime :: (a->b->c)-> a ->(d->b)->d->c |])+ exe C' = $(dynamic [|defaultTCL|] [| cprime :: (a->b->c)->(d->a)->b->d->c |])+ exe foo = error (show foo ++ " : unknown combinator")+-- readType assumes the tcl is undefined, so it cannot be used when type constructors other than -> are used.+s = \f g x -> f x (g x)+sprime = \f g h x -> f (g x) (h x)+bprime = \f g h x -> f g (h x)+cprime = \f g h x -> f (g x) h
+ MagicHaskeller/ExprStaged.hs view
@@ -0,0 +1,164 @@+-- +-- (c) Susumu Katayama 2009+--+{-# OPTIONS -O -fglasgow-exts #-}+module MagicHaskeller.ExprStaged where+import MagicHaskeller.CoreLang+import MagicHaskeller.MyDynamic+-- import ReadType+import Data.Array+import MagicHaskeller.Types as Types+import MagicHaskeller.Execute(unDeBruijn)+import Debug.Trace+import GHC.Exts(unsafeCoerce#)+import Language.Haskell.TH hiding (Con)+import MagicHaskeller.MHTH++-- The following two are used only by printTable(s) for debugging.+import MagicHaskeller.TyConLib(defaultTCL, tuplename)+import MagicHaskeller.ReadTHType(typeToTHType)++see i j = pprint $ e2THE $ mkCE i j+seeType i j = unDeBruijn $ mkCE i j++sees i j k = pprint $ e2THE $ mkCE_LambdaBoundHead i j k+seesType i j k = unDeBruijn $ mkCE_LambdaBoundHead i j k++e2THE = exprToTHExp (error "exprToTHExp: vl required")+++printTables = mapM_ putStrLn [ shows i $ (' ':) $ shows m $ (' ':) $ shows n $ ("\t("++) $ pprint (aimnTHE i m n) ++ ") :: " ++ pprintType (MagicHaskeller.ReadTHType.typeToTHType MagicHaskeller.TyConLib.defaultTCL $ aimnty i m n)+ | i <- [0..2], m <- [0..2], n <- [i+1..3] ]++printTable = mapM_ putStrLn [ shows m $ (' ':) $ shows n $ ("\t("++) $ pprint (hdmnTHE m n) ++ ") :: " ++ pprintType (MagicHaskeller.ReadTHType.typeToTHType MagicHaskeller.TyConLib.defaultTCL $ hdmnty m n)+ | m <- [0..2], n <- [0..2] ]+++-- pprintType is copied (and improved a little) from MagicHaskeller.lhs. I think I reported the bug and sent a patch to ghc-bugs, but it seems it is not fixed yet.... Here HEAD means the head of my copy.++-- 'pprintType' is a workaround for the problem that @Language.Haskell.TH.pprint :: Type -> String@ does not print parentheses correctly.+-- (try @Language.Haskell.TH.runQ [t| (Int->Int)->Int |] >>= \e -> putStrLn (pprint e)@ in your copy of GHCi.)+-- The implementation here is not so pretty, but that's OK for my purposes. Also note that 'pprintType' ignores foralls.+pprintType (ForallT _ [] ty) = pprintType ty+pprintType (ForallT _ _ ty) = error "Type classes are not supported yet. Sorry...."+pprintType (VarT name) = pprint name+pprintType (ConT name) = pprint name+pprintType (TupleT n) = tuplename n+pprintType ArrowT = "(->)"+pprintType ListT = "[]"+pprintType (AppT (AppT ArrowT t) u) = '(' : pprintType t ++ " -> " ++ pprintType u ++ ")"+pprintType (AppT t u) = '(' : pprintType t ++ ' ' : pprintType u ++ ")"+-- The problem of @Language.Haskell.TH.pprint :: Type -> String@ is now fixed at the darcs HEAD.++++{-+-- $B4pK\E*$K(BCoreExpr$B$+$i(BDynamic$B$rI=$9(BTH.Exp$B$r:n$k!%(B+-- unsafeExecute ce$B$H(B $(exprToExpDynamic ce)$B$H$N0c$$$O!$8e<T$O&K<0$r%W%m%0%i%`Cf$KE=$jIU$1$k$N$G!$B?$/$N(Bprimitive combinators$B$r=hM}$9$k%3%9%H$,$+$+$i$J$$$C$F$3$H!%(BSupercombinator$B$K$h$k<BAu$_$?$$$J$b$N!%(B+exprToExpDynamic :: Language.Haskell.TH.Type -> CoreExpr -> ExpQ+exprToExpDynamic ty ce+ = case -- trace ("ce = "++pprint (exprToTHExp ce)) $+ e2THE ce of+ the ->+-- the -> case tiExpression tl (error ("exprToExpDynamic: tcl required. unDeBruijn ce = "++show (unDeBruijn ce)++",\n and the = "++pprint the)) $ unDeBruijn ce of+ do thee <- expToExpExp the -- $B<B$O$3$3$,0lHV;~4V$,$+$+$k5$$,$9$k$N$@$,!$%G%P%C%0>pJs$7$+$J$$$N$G!$(BREALDYNAMIC$B$G$J$$>l9g$O$J$s$H$+$G$-$k$+$b!%(B+ thty <- MHTH.typeToExpType ty $B$3$l$@$H!$(Bsplice$B$7$?7k2L$,(BTH.Type$B$K$J$C$F$7$^$&!%(B+ return ((((VarE 'unsafeToDyn) `AppE` thty)+ `AppE` the)+ `AppE` thee)+-}+mkVName :: Char -> Int -> Q Language.Haskell.TH.Name+mkVName c i = newName (c : show i)+mkVNames :: Char -> Int -> Q [Language.Haskell.TH.Name]+mkVNames c n = mapM (mkVName c) [0..n-1]+mkEs, mkAs, mkXs :: Int -> Q [Language.Haskell.TH.Name]+mkEs = mkVNames 'e'+mkAs = mkVNames 'a'+mkXs = mkVNames 'x'+mkHd = newName "hd"++hdmnTHEQ :: Int -> Int -> ExpQ+hdmnTHEQ m n = return $ (VarE 'unsafeCoerce#) `AppE` hdmnTHE m n+{-+hdmnTHEQ m n = do hd <- mkHd+ mes <- mkEs m+ mxs <- mkXs m+ nas <- mkAs n+ let lambdas = LamE (map VarP (hd : mes ++ nas))+ appa1an var = foldl AppE (VarE var) $ map VarE nas+ return $ (VarE 'unsafeCoerce#) `AppE` lambdas (foldl AppE (VarE hd) (map appa1an mes))+-}+aimnTHEQ :: Int -> Int -> Int -> ExpQ+aimnTHEQ i m n = return $ (VarE 'unsafeCoerce#) `AppE` aimnTHE i m n+{-+aimnTHEQ i m n = do+ mes <- mkEs m+ nas <- mkAs n+ let lambdas = LamE (map VarP (mes ++ nas))+ appa1an var = foldl AppE (VarE var) $ map VarE nas+ return $ (VarE 'unsafeCoerce#) `AppE` lambdas (foldl AppE (VarE (nas!!i)) (map appa1an mes))+-}++hdmnTHE :: Int -> Int -> Exp+hdmnTHE m n = e2THE (mkCE n m)+aimnTHE :: Int -> Int -> Int -> Exp+aimnTHE i m n = e2THE (mkCE_LambdaBoundHead i n m)++-- copied from ExecuteAPI $B$F$f!<$+!$(BmkCE_LambdaBoundHead$B$G$O(Bde Bruijn index$B$r;H$C$F$$$k$,!$(BExecuteAPI.aimn$B$O5U8~$-$K(Bindex$B$r3d$jEv$F$F$$$k$N$G!$$=$N$^$^;}$C$F$-$F$O%@%a!%(B+hdmnty :: Int -> Int -> Types.Type+hdmnty m n = hdty Types.:-> foldr (Types.:->) (foldr (Types.:->) tvr nas) (map (\r -> foldr (Types.:->) r nas) mrs)+ where hdty = foldr (Types.:->) tvr mrs+ mrs = take m tvrs+ nas = take n tvas+aimnty :: Int -> Int -> Int -> Types.Type+aimnty i m n = foldr (Types.:->) (foldr (Types.:->) tvr nas) (map (\r -> foldr (Types.:->) r nas) mrs)+ where hdty = foldr (Types.:->) tvr mrs+ mrs = take m tvrs+ nas = case splitAt (n-i-1) tvas of (tk,_:dr) -> tk ++ hdty : take i dr -- hdmnty$B$H$N0c$$$O$3$3$@$1(B+mkTV :: Int -> Types.Type+mkTV = Types.TV+tvrs = map mkTV [1,3..]+tvas = map mkTV [2,4..]+tvr = mkTV 0+++-- $B0J2<$N?tCM$O!$$I$N%5%$%:$^$GD>@\(Bsupercombinator$B$rMQ0U$9$k$+$rI=$9!%(B+-- $B$3$NHO0O$K<}$^$i$J$$>l9g$G$b!$(Bprimitive combinators$B$G%;%3%;%3$7$J$1$l$P$J$i$J$$$H$$$&Lu$G$O$J$$(B+maxArity, maxLenavails :: Int+maxArity = 4+maxLenavails = 8 -- $B4pK\E*$K2?2s4X?t9g@.$9$k$+$NLdBj$J$N$G!$$?$H$($P(B13$B$H$+$J$i(B8+5$B$H9M$($F(B2$B2s9g@.$7$F$b$=$s$J$K8zN($OMn$A$J$$!$$H;W$&!%(B+maxDebindex = maxLenavails-1+-- maxArity = 0+-- maxLenavails = 0++mkCE :: Int -- ^ length of avails+ -> Int -- ^ arity of the head function+ -> CoreExpr+mkCE 0 _ = Lambda (X 0)+mkCE lenavail 0 = napply (lenavail+1) Lambda (X lenavail)+mkCE lenavail arity+ = let vs = map X $ reverse [0..lenavail-1]+ fs = map X $ reverse [lenavail..lenavail+arity-1]+ ce = X (lenavail+arity)+ in napply (arity+1+lenavail) Lambda (foldl (:$) ce $ fmap (\f -> foldl (:$) f vs) fs)+napply 0 f x = x+napply n f x = f (napply (n-1) f x)++{-+usage: (dynss !! length avail !! (arity_of_head)) `dynApp` (dynamic_head_as_ce) `dynApp` (dynamic_as_result_of_recursive_call_as_f) `dynApp` ... `dynApp` (dynamic_as_result_of_recursive_call_as_h)++[ [ \ce -> ce , \ce -> \f -> ce f, \ce -> \f g -> ce f g, \ce -> \f g h -> ce f g h, ... ],+ [ \ce -> (\e-> ce), \ce -> \f -> (\e-> ce (f e)), \ce -> \f g -> (\e-> ce (f e) (g e)), \ce -> \f g h -> (\e -> ce (f e) (g e) (h e)), ... ],+ [ \ce -> (\e b-> ce), \ce -> \f -> (\e b-> ce (f e b)), \ce -> \f g -> (\e b-> ce (f e b) (g e b)), \ce -> \f g h -> (\e b-> ce (f e b) (g e b) (h e b)), ... ],+ ... ]+-}++-- mkCE$B$G(B\ce->$B$r$H$C$F(Bce$B$r(BX debindex$B$K$9$k$@$1!%(B+mkCE_LambdaBoundHead debindex lenavails arity+ = let vs = map X $ reverse [0..lenavails-1]+ fs = map X $ reverse [lenavails..lenavails+arity-1]+ ce = X debindex+ in napply (arity+lenavails) Lambda (foldl (:$) ce $ fmap (\f -> foldl (:$) f vs) fs)+-- $B$F$f!<$+!$(Bce$B$r:G8e$K;}$C$F$/$k$h$&$K$9$l$PE}9g$G$-$kLu$M!%(B+-- mkCE_LambdaBoundHead debindex lenavails arity = (mkCE lenavails (arity+1) :$ (Lambda $ X 0)) :$ (napply lenavails Lambda $ X debindex)+
+ MagicHaskeller/Expression.hs view
@@ -0,0 +1,193 @@+-- +-- (c) Susumu Katayama 2009+--+module MagicHaskeller.Expression(module MagicHaskeller.Expression, module MagicHaskeller.ExprStaged, CoreExpr) where+import MagicHaskeller.CoreLang+import MagicHaskeller.MyDynamic+import MagicHaskeller.Execute+-- import Reduce+import MagicHaskeller.Types+import MagicHaskeller.ExprStaged+import MagicHaskeller.Combinators++import MagicHaskeller.T10+import Control.Monad+import Data.Array((!), array)+import MagicHaskeller.ReadDynamic+import MagicHaskeller.TyConLib(defaultTCL, TyConLib)+-- import Debug.Trace++import MagicHaskeller.Instantiate(RTrie, uncurryDyn, uncurryTy, mkUncurry, mkCurry, curryDyn)+import MagicHaskeller.DebMT++-- AnnExpr remembers each Dynamic corresponding to the CoreExpr.+data AnnExpr = AE CoreExpr Dynamic deriving Show+instance Eq AnnExpr where+ a == b = toCE a == toCE b+instance Ord AnnExpr where+ compare a b = compare (toCE a) (toCE b)++-- MemoExpr further memoizes each dynamic function.+data MemoExpr = ME CoreExpr Dynamic -- memo table+ Dynamic -- memoized function+aeToME :: TyConLib -> RTrie -> Type -> AnnExpr -> MemoExpr+aeToME tcl (_,_,_,_,mtdd) ty@(_:->_) (AE ce dyn)+ = case lookupMT mtdd argty of (m,a) -> let me@(ME _ memo _) = ME ce (dynApp m udyn) (curryDyn cur ty $ dynApp a memo)+ in me -- make sure to use the memo table in the datatype by using letrec, or the table will be recomputed.+ where argty:->_ = uncurryTy tcl ty+ unc = mkUncurry tcl+ udyn = uncurryDyn unc ty dyn+ cur = mkCurry tcl+aeToME _ _ _ (AE ce dyn) = ME ce undefined dyn -- non-functional case++meToAE :: MemoExpr -> AnnExpr+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?+ toCE :: e -> CoreExpr+ mapCE :: (CoreExpr -> CoreExpr) -> e -> e -- $B$3$l$bJQ!%(B+ (<$>) :: e -> e -> e+ appEnv :: Int -> e -> e -> e+ toAnnExpr :: (CoreExpr->Dynamic) -> e -> AnnExpr+ toAnnExprWind :: (CoreExpr->Dynamic) -> Type -> e -> AnnExpr+ toAnnExprWindWind :: (CoreExpr->Dynamic) -> Type -> e -> AnnExpr+ fromAnnExpr :: AnnExpr -> e+ reorganize :: Monad m => ([Type] -> m [e]) -> [Type] -> m [e]+ reorganizeId :: ([Type] -> [e]) -> [Type] -> [e] -- reorganize for Id monad+instance Expression CoreExpr where+ fromCE _ _ _ = id+ toCE = id+ mapCE = id+ (<$>) = (:$)+ appEnv _ = (:$)+ toAnnExpr reduce e = AE e (reduce e)+ toAnnExprWind reduce ty e = AE e (reduce $ windType ty e)+ toAnnExprWindWind reduce ty e = let we = windType ty e in AE we (reduce we)+ fromAnnExpr (AE ce _) = ce+ reorganize = reorganizer+ reorganizeId = reorganizerId+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'.+ toCE (AE ce _) = ce+ 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)+ toAnnExpr _ = id+ toAnnExprWind _ _ = id+ toAnnExprWindWind _ ty (AE ce d) = AE (windType ty ce) d+ fromAnnExpr = id+ reorganize = id+ reorganizeId = id+windType :: Type -> CoreExpr -> CoreExpr+windType (a:->b) e = Lambda (windType b e)+windType _ e = e++-- Sn = \f g x1 .. xn -> f x1 .. xn (g x1 .. xn)+dynSn lenavails = dynApp (getDyn lenavails 2) dynI++getDyn, mkDyn :: Int -> Int -> Dynamic+getDyn lenavails arity+-- | arity<=maxArity = case lenavails `divMod` maxLenavails of (d,m) -> napply d (dynApp (dynApp dynB (finiteDynar!(maxLenavails,arity)))) (finiteDynar!(m,arity)) -- $B$J$s$+0c$&$_$?$$!%(B+ | lenavails<=maxLenavails && arity<=maxArity = -- trace (show (lenavails,arity)++show (maxLenavails,maxArity)) $+ finiteDynar ! (lenavails,arity)+ | otherwise = dynss !! lenavails !! arity++dynss :: [[Dynamic]]+dynss = [ [ mkDyn i j | j <- [0..] ] | i <- [0..] ]+mkDyn 0 _ = dynI+{-+mkDyn lenavails 0 = unsafeExecute (B :$ K) `dynApp` mkDyn (lenavails-1) 0 +mkDyn lenavails arity = unsafeExecute $ mkCE lenavails arity +-}+-- mkDyn lenavails arity = napply lenavails (dynApp (dynB `dynApp` x arity)) dynI+mkDyn lenavails arity = dynApp (dynB `dynApp` x arity) (getDyn (lenavails-1) arity)++-- #ifdef TEMPLATE_HASKELL+-- x n | n<=maxArity = finiteDynar ! (1,n) -- $B$J$s$+0c$&$_$?$$!%(B+-- #else+x 0 = dynK+x 1 = dynB+x 2 = dynS'+-- x 3 = unsafeToDyn (readType "(a->b->c->r)->(x->a)->(x->b)->(x->c)->x->r") x3 ()+-- #endif+x n = napply n (dynApp dynB) dynS `dynApp` x (n-1)++finiteDynar = array ((0,0),(maxLenavails,maxArity)) [ ((lenavails,arity), finiteDynss!!lenavails!!arity) | arity<-[0..maxArity], lenavails<-[0..maxLenavails] ]+finiteDynarr = array ((0,0,0),(maxDebindex,maxLenavails,maxArity)) [ ((debindex,lenavails,arity), finiteDynsss!!debindex!!(lenavails-debindex-1)!!arity) | arity<-[0..maxArity], debindex<-[0..maxDebindex], lenavails<-[debindex+1..maxLenavails] ]++finiteDynss = zipWith3 (zipWith3 (unsafeToDyn defaultTCL)) [ [ hdmnty arity lenavails | arity <- [0..maxArity] ] | lenavails <- [0..maxLenavails] ]+ finiteHVss+ [ [ hdmnTHE arity lenavails | arity <- [0..maxArity] ] | lenavails <- [0..maxLenavails] ]+finiteDynsss = zipWith3 (zipWith3 (zipWith3 (unsafeToDyn defaultTCL)))+ [ [ [ aimnty debindex arity lenavails | arity <- [0..maxArity] ] | lenavails <- [debindex+1..maxLenavails] ] | debindex <- [0..maxDebindex] ]+ finiteHVsss+ [ [ [ aimnTHE debindex arity lenavails | arity <- [0..maxArity] ] | lenavails <- [debindex+1..maxLenavails] ] | debindex <- [0..maxDebindex] ]++getDyn_LambdaBoundHead, mkDyn_LambdaBoundHead :: Int -> Int -> Int -> Dynamic+getDyn_LambdaBoundHead debindex lenavails arity+ | debindex<=maxDebindex && lenavails<=maxLenavails && arity<=maxArity = -- trace (show (debindex,lenavails,arity)++show (maxDebindex,maxLenavails,maxArity)) $+ finiteDynarr ! (debindex,lenavails,arity) -- $B$3$C$A$NJ}$,8zN(E*$J$s$@$1$I!$%G%P%C%0Cf$@$10l;~E*$K!%(B+ -- finiteDynsss !! debindex !! (lenavails-debindex-1) !! arity+ | otherwise = dynsss !! debindex !! lenavails !! arity++dynsss :: [[[Dynamic]]]+dynsss = [ [ [ mkDyn_LambdaBoundHead i j k | k <- [0..] ] | j <- [0..] ] | i <- [0..] ]+mkDyn_LambdaBoundHead debindex lenavails arity = (getDyn lenavails (arity+1) `dynApp` dynI) `dynApp` select lenavails debindex+ where+ -- select lenavails debindex = unsafeExecute (napply lenavails Lambda $ X debindex)+ select lenavails debindex = napply (lenavails-1-debindex) (dynApp dynK) $ napply debindex (dynApp dynBK) dynI+dynBK = dynApp dynB dynK++-- dynF = dynApp dynC dynK++-- moved from ProgramGenerator.lhs++-- reorganize :: ([Type] -> PriorSubsts BF [CoreExpr]) -> [Type] -> PriorSubsts BF [CoreExpr]+-- $B$H$7$F;H$o$l$k$N$@$,!$FC$K(Bexport$B$5$l$kLu$G$b$J$$$N$G$$$A$$$A(Bspecialize$B$7$J$$!%(B+reorganizer :: Monad m => ([Type] -> m [CoreExpr]) -> [Type] -> m [CoreExpr]+reorganizer fun avail+ = case cvtAvails avail of+ (newavail, argss) ->+ do agentExprs <- fun newavail+ return [ result | e <- agentExprs, result <- replaceVars 0 e argss ]++reorganizerId :: ([Type] -> [CoreExpr]) -> [Type] -> [CoreExpr]+reorganizerId fun avail+ = case cvtAvails avail of+ (newavail, argss) ->+ [ result | e <- fun newavail, result <- replaceVars 0 e argss ]+replaceVars :: Int -> CoreExpr -> [[Int]] -> [CoreExpr]+replaceVars dep e@(X n) argss = case argss !? (n - dep) of Nothing -> [e]+ Just xs -> map (\ m -> X (m + dep)) xs+replaceVars dep (Lambda e) argss = map Lambda (replaceVars (dep+1) e argss)+replaceVars dep (f :$ e) argss = liftM2 (:$) (replaceVars dep f argss) (replaceVars dep e argss)+replaceVars dep e argss = [e]++cvtAvails = unzip . tkr10 . annotate++-- annotate$B$O(BsplitAvails$B$NA0=hM}$H$7$F$b;H$($k!%(B+annotate :: [Type] -> [(Type,Int)]+annotate ts = zipWith (,) ts [0..]+{-+annotate ts = an 0 ts+ where an n [] = []+ an n (t:ts) = (t,n) : an (n+1) ts+prop_annotate = \ts -> annotate ts == zipWith (,) ts [0..]+-}+++-- Moved from T10+-- uniqSorter :: (Ord e) => [(e,Int)] -> [(e,Int)]+uniqSorter :: (Expression e) => [(e,Int)] -> [(e,Int)]+uniqSorter = annUniqSort -- swapUniqSort -- id -- uniqSort -- annUniqSort++uniqSort :: 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))
+ MagicHaskeller/FakeDynamic.hs view
@@ -0,0 +1,57 @@+-- +-- (c) Susumu Katayama 2009+--+{-# OPTIONS -XMagicHash -XExistentialQuantification -XPolymorphicComponents #-}+module MagicHaskeller.FakeDynamic(+ Dynamic,+ fromDyn,+ fromDynamic,+ dynApply,+ dynApp,+ dynAppErr,+ dynType,+ unsafeFromDyn, -- :: Dynamic -> a+ unsafeToDyn, -- :: Type -> a -> Dynamic+ aLittleSafeFromDyn -- :: Type -> Dynamic -> a+ -- I (susumu) believe this is enough, provided unsafeFromDyn does not invoke typeOf for type checking. (Otherwise there would be ambiguity error.)+ ) where++import Data.Typeable++import GHC.Exts++import MagicHaskeller.Types+import MagicHaskeller.TyConLib+import Control.Monad++infixl `dynApp`++newtype Dynamic = Dynamic (forall a. a)++unsafeFromDyn :: Dynamic -> a+unsafeFromDyn (Dynamic v) = v++unsafeToDyn :: TyConLib -> Type -> a -> e -> Dynamic+unsafeToDyn _ tr a e = Dynamic (unsafeCoerce# a)++aLittleSafeFromDyn :: Type -> Dynamic -> a+aLittleSafeFromDyn _ (Dynamic o) = o++fromDyn :: Typeable a => TyConLib -> Dynamic -> a -> a+fromDyn tcl (Dynamic o) dflt = o+fromDynamic :: MonadPlus m => Type -> Dynamic -> m a+fromDynamic tr (Dynamic o) = return o++instance Show Dynamic where+ showsPrec _ _ = showString "<< FakeDynamic >>"++dynApply :: Dynamic -> Dynamic -> Maybe Dynamic+dynApply f x = Just (dynApp f x)++dynApp :: Dynamic -> Dynamic -> Dynamic+dynApp (Dynamic f) (Dynamic x) = Dynamic ((unsafeCoerce# f) x)+dynAppErr :: String -> Dynamic -> Dynamic -> Dynamic+dynAppErr _ f x = dynApp f x++dynType :: Dynamic -> Type+dynType _ = error "FakeDynamic.dynType: if you want to know the type, use PolyDynamic instead."
+ MagicHaskeller/Instantiate.hs view
@@ -0,0 +1,401 @@+-- +-- (c) Susumu Katayama 2009+--+{-# OPTIONS -fglasgow-exts -cpp #-}+module MagicHaskeller.Instantiate(mkRandTrie, RTrie, -- arbitraries,+ uncurryDyn, uncurryTy, mkUncurry, typeToOrd, typeToRandomsOrd, typeToRandomsOrdDM, mkCurry, curryDyn+ , typeToArb -- exported just for testing Classification.tex+ ) where++import MagicHaskeller.CoreLang+import qualified Data.Map as Map+import MagicHaskeller.MyCheck+import System.Random+import MagicHaskeller.Types+import Control.Monad.Search.Combinatorial+import Data.Array((!))+import MagicHaskeller.TyConLib+import MagicHaskeller.DebMT+import Data.List hiding (insert)+import Control.Monad+import qualified Data.IntMap as IntMap++import MagicHaskeller.MyDynamic+-- import Data.Typeable++import MagicHaskeller.ReadDynamic(dynI)++import Data.Memo++import MagicHaskeller.T10+-- import ReadTypeRep(typeToTR)++import Language.Haskell.TH hiding (Type)+-- import Debug.Trace+trace _ e = e++type Order = Maybe ([Dynamic], PackedOrd)++type ExpResult = ([Dynamic],CoreExpr)+mkUncurry :: TyConLib -> Dynamic+mkUncurry tcl =+ $(dynamic [|tcl|] [| uncurry :: (a->b->c)->((,) a b)->c |])++uncurryDyn :: Dynamic -> Type -> Dynamic -> Dynamic+uncurryDyn unc (_ :-> b@(_:->_)) f = dynAppErr "while uncurrying." unc (uncurryDyn unc b f)+uncurryDyn _ _ x = x++mkCurry :: TyConLib -> Dynamic+mkCurry tcl =+ $(dynamic [|tcl|] [| curry :: ((,) a b -> c)-> a->b->c |])++curryDyn :: Dynamic -> Type -> Dynamic -> Dynamic+curryDyn cur (_ :-> b@(_:->_)) f = dynAppErr "while currying." cur (curryDyn cur b f)+curryDyn _ _ x = x++{-+varsInts (TA t u) = TA (varsInts t) (varsInts u)+varsInts (u:->t) = varsInts u :-> varsInts t+varsInts (TV +-}+uniqueVars (TA t u) = TA (uniqueVars t) (uniqueVars u)+uniqueVars (u:->t) = uniqueVars u :-> uniqueVars t+uniqueVars (TV _) = TV 0+uniqueVars tc = tc++-- uniqueVars ¤Ïmemoize¤·¤Ê¤¤¾ì¹ç¤Ï¤ä¤Ã¤Æ¤â¤·¤ç¤¦¤¬¤Ê¤¤¤·¡¤memoize¤¹¤ë¾ì¹ç¤Ïsynergetic¤È¤½¤¦¤Ç¤Ê¤¤¤Î¤ÈξÊý¤Ç¤ä¤ë¤Ù¤¤Ç¤Ï?+++-- memoize¤·¤Ê¤¤¾ì¹ç+typeToRandomsOrd :: TyConLib -> RTrie -> Type -> Order+typeToRandomsOrd tcl = ttro (\(cmap,maps,_,_,_) -> argTypeToRandoms tcl cmap maps) tcl+typeToRandomsOrdDM :: [Int] -> TyConLib -> RTrie -> Type -> Maybe ([[Dynamic]], PackedOrd)+typeToRandomsOrdDM nrnds tcl = ttro (\(cmap,maps,_,_,_) -> argTypeToRandomss nrnds tcl cmap maps) tcl++{-+-- memoize¤¹¤ë¾ì¹ç+typeToRandomsOrd :: TyConLib -> RTrie -> Type -> Order+typeToRandomsOrd tcl rtrie = ttro (\(_,_,(mtrands,_)) -> lookupMT mtrands) tcl rtrie . uniqueVars+typeToRandomsOrdDM :: TyConLib -> RTrie -> Type -> Maybe ([[Dynamic]], PackedOrd)+typeToRandomsOrdDM tcl rtrie = ttro (\(_,_,(_,mtrands)) -> lookupMT mtrands) tcl rtrie . uniqueVars+-}++ttro :: (RTrie -> Type -> Maybe [a]) -> TyConLib -> RTrie -> Type -> Maybe ([a], PackedOrd)+ttro attr tcl rtrie@(cmap,_,_,_,_) (a1:->rest)+ = let (a,r) = uncurryTy' tcl a1 rest+ in do cmp <- typeToCompare tcl cmap r+ rnds <- attr rtrie a+ return (rnds, cmp)+ttro attr tcl (cmap, _, _, _, _) t+ = do cmp <- typeToCompare tcl cmap t+ return ([], cmp)++++dynToCompare :: TyConLib -> Dynamic -> (Dynamic -> Dynamic -> Ordering)+dynToCompare tcl dyn d0 d1 = fromDyn tcl (dynApp (dynApp dyn d0) d1) (error "dynToCompare: type mismatch")+--dynToCompare tcl dyn d0 d1 = aLittleSafeFromDyn (readType' tcl "Ordering") (dynApp (dynApp dyn d0) d1)++-- °ú¿ô¤Î·¿¤¬³ÎÄꤷ¤Æ¤âÊÖ¤êÃͤη¿¤¬³ÎÄꤷ¤Ê¤¤¾ì¹ç¡§¤¿¤È¤¨¤Ðundefined¤äerror¤È¤«¡¥¤³¤Î¤Ø¤ó¤ò¤Á¤ã¤ó¤Ètake care¤·¤È¤«¤Ê¤¤¤È¡¤¤à¤ê¤ä¤êInt¤ËÊÑ´¹¤¹¤ë¤³¤È¤Ë¤Ê¤ë¡¥...¤Þ¤¢¤¤¤Ã¤«¡©+-- procUndef = Just ([], mkHV (\_ _ -> True))++-- | 'uncurryTy' converts @a->b->c->d->e->r@ into @((((a,b),c),d),e)->r@+-- Note that @Arbitrary (a,b,c,d,e)@ is not defined in @Test.QuickCheck@.+uncurryTy :: TyConLib -> Type -> Type+uncurryTy tcl (a:->b) = case uncurryTy' tcl a b of (c,r) -> c:->r+uncurryTy _ t = t+uncurryTy' :: TyConLib -> Type -> Type -> (Type,Type)+uncurryTy' tcl a (b:->r) = uncurryTy' tcl (pair tcl a b) r+uncurryTy' tcl a r = (a,r)++pair tcl a b = (TA (TA (TC (tuple tcl 2)) a) b)+{-+tuple¤ËÂбþ¤¹¤ë¤ä¤Ä¤Ê¤¤¤·¡¤¤ä¤Ã¤ÑTH.Type¤Ë°ìöÊÑ´¹¤·¤¿Êý¤¬¤è¤¤¡© ¤¢¤ë¤¤¤Ï¡¤Types.Type¤ÇTuple¤òÆÃÊ̻뤹¤ë¤«¡¥¤Þ¤¢¡¤Î§Â®Ãʳ¬¤Ç¤Ï¤Ê¤¤¤Î¤Ç"(,)"¤ß¤¿¤¤¤Ê´¶¤¸¤Ç¤ä¤Ã¤Æ¤â¤¤¤¤¤±¤É¡¥+¤¿¤À¡¤tcl¤Ë"(,)"¤È¤«¤¬´Þ¤Þ¤ì¤Ê¤¤¾ì¹ç¤Ï¡© ñ¤ËdefaultTyCons¤ËÆþ¤ì¤Æ¤ª¤±¤Ð¤¤¤¤¤«¡¥¤¿¤À¡¤Arbitrary¤Ï(,,,)¤Þ¤Ç¤·¤«ÄêµÁ¤µ¤ì¤Æ¤¤¤Ê¤¤¡¥++$(support [t| forall a b c. ((Int,Integer,Char), ([a], Maybe a), (Either a b, (a,b))) |])+¤ß¤¿¤¤¤Ë½ñ¤¯¤ÈtypeToOrd¤ätypeToRandoms¤¬À¸À®¤µ¤ì¤Æ¤¯¤ì¤ë¤ÈÊØÍø¡¥+¤Þ¤¢¤È¤ê¤¢¤¨¤º¤Ï¸Â¤é¤ì¤¿·¿¤À¤±¤Ç¤ä¤Ã¤Æ¤â¤¤¤¤¤±¤É¡¥++¤Æ¤æ¡¼¤«¡¤Ord¤Ê·¿¤ÈArbitrary¤Ê·¿¤ÏÊ̤ʤΤǡ¤supportOrd, supportArb¤Î£²¤Ä¤òÍÑ°Õ¤·¤Æ¤ª¤¯¤«¡¥+++¤Æ¤æ¡¼¤«¡¤Dynamic¤Ï¤É¤¦¤è¡© Ʊ¤¸¤³¤È¤«+-}++type PackedOrd = Dynamic -> Dynamic -> Ordering+type Cmp a = a->a->Ordering++type Maps = (ArbMap, ArbMap, StdGen, StdGen) -- used if we do not memoize+type Tries = (MapType (Maybe [Dynamic]), MapType (Maybe [[Dynamic]])) -- used if we memoize++type RTrie = (CmpMap, Maps, MemoMap,+ Tries, MapType (Dynamic,Dynamic))++mkRandTrie :: [Int] -> TyConLib -> StdGen -> RTrie+mkRandTrie nrnds tcl gen+ = let arbtup = mkArbMap tcl+ coarbtup = mkCoarbMap tcl+ (g0,g1) = split gen+ maps = (arbtup, coarbtup, g0, g1)+ cmap = mkCmpMap tcl+ mmap = mkMemoMap tcl+ in (cmap, maps, mmap,+ (mkMT tcl (argTypeToRandoms tcl cmap maps), mkMT tcl (argTypeToRandomss nrnds tcl cmap maps)),+ (mkMT tcl (typeToMemo mmap)))+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+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+nubByCmp cmp = nubBy (\a b -> cmp a b == EQ)++type MapTC a = IntMap.IntMap (IntMap.IntMap a)+type CmpMap = (MapTC Dynamic, Dynamic)+++mkMap :: TyConLib -> [[(String,a)]] -> MapTC a+mkMap tcl@(mapNameTyCon,_) mcts = IntMap.fromAscList $ zip [0..] $ map (IntMap.fromList . map (\ (name, dyn) -> (mapNameTyCon Map.! name, dyn))) mcts+mkCmpMap :: TyConLib -> CmpMap+mkCmpMap tcl = (mkMap tcl [mct0, mct1, mct2],+ cmpChar)+ where+ cmpChar = $(dynamic [|tcl|] [| compare :: Char -> Char -> Ordering |])+ mct0, mct1, mct2 :: [(String,Dynamic)]+ mct0 = [("Int", $(dynamic [|tcl|] [| compare :: Int -> Int -> Ordering |])),+ ("Integer", $(dynamic [|tcl|] [| compare :: Integer -> Integer -> Ordering |])),+ ("Char", cmpChar),+ ("Bool", $(dynamic [|tcl|] [| compare :: Bool -> Bool -> Ordering |])),+ ("Double", $(dynamic [|tcl|] [| compare :: Double -> Double -> Ordering |])),+ ("Float", $(dynamic [|tcl|] [| compare :: Float -> Float -> Ordering |])),+ ("()", $(dynamic [|tcl|] [| compare :: () -> () -> Ordering |])),+ ("Ordering",$(dynamic [|tcl|] [| compare :: Ordering-> Ordering-> Ordering |]))]+ mct1 = [("Maybe", $(dynamic [|tcl|] [| compareMaybe :: (a -> a -> Ordering) -> Maybe a -> Maybe a -> Ordering |])),+ ("[]", $(dynamic [|tcl|] [| compareList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering |]))]+ mct2 = [("Either", $(dynamic [|tcl|] [| compareEither:: (a -> a -> Ordering) ->+ (b -> b -> Ordering) -> Either a b -> Either a b -> Ordering |])),+ ("(,)", $(dynamic [|tcl|] [| comparePair :: (a -> a -> Ordering) ->+ (b -> b -> Ordering) -> (a,b) -> (a,b) -> Ordering |]))]+-- ("Array", unsafeToDyn (readType' tcl "Cmp a -> Cmp b -> Cmp (Array a b)") (\cmp0 cmp1 x y -> compareList (comparePair cmp0 cmp1) (assocs x) (assocs y)))]+-- tto (TA (TA (TA (TC tc) t) u) v) = case (ar ! 3) !! tc of ("(,,)",_) -> packCmp (\ (x0,x1,x2) (y0,y1,y2) -> compareTup (pair tcl (pair tcl t u) v) ((x0,x1),x2) ((y0,y1),y2))+-- _ -> Nothing+compareMaybe _ Nothing Nothing = EQ+compareMaybe _ Nothing _ = LT+compareMaybe _ _ Nothing = GT+compareMaybe cmp (Just x) (Just y) = cmp x y+compareList _ [] [] = EQ+compareList _ [] _ = LT+compareList _ _ [] = GT+compareList cmp (x:xs) (y:ys) = case cmp x y of EQ -> compareList cmp xs ys+ c -> c+compareEither cmp0 cmp1 (Left x) (Left y) = cmp0 x y+compareEither cmp0 cmp1 (Left _) _ = LT+compareEither cmp0 cmp1 _ (Left _) = GT+compareEither cmp0 cmp1 (Right x) (Right y) = cmp1 x y+comparePair cmp0 cmp1 (x0,x1) (y0,y1) = case cmp0 x0 y0 of EQ -> cmp1 x1 y1+ c -> c++typeToCompare :: TyConLib -> CmpMap -> Type -> Maybe (Dynamic -> Dynamic -> Ordering)+typeToCompare tcl cmap ty = do cmp <- typeToOrd cmap ty+ return (dynToCompare tcl cmp)+typeToOrd :: CmpMap -> Type -> Maybe Dynamic+typeToOrd (cmpmap,cmpchar) ty = tto 0 ty+ where tto k (TA t u) = liftM2 dynApp (tto (k+1) t) (tto 0 u) -- Higher-order kinds break everything.+ tto _ (_:->_) = Nothing -- error "Functions in containers are not allowed." -- note that ty is (part of) the return type, so this means higher-order datatype is returned.+ tto 0 (TV _) = Just cmpchar -- same as the Char case+ tto _ (TV _) = Nothing -- ¤³¤ì¤Ë¤Ä¤¤¤Æ¤Ï°ìÈÌŪ¤Ê¤ä¤ê¤«¤¿¤Ï¤Ê¤µ¤½¤¦¡¥+ tto k (TC tc) = do guard (tc >= 0)+ imap <- IntMap.lookup k cmpmap+ IntMap.lookup tc imap+ tto _ _ = Nothing+type ArbMap = (MapTC Dynamic, Dynamic, Dynamic)++mkArbMap :: TyConLib -> ArbMap+mkArbMap tcl@(mapNameTyCon,_) = (mkMap tcl [mct0, mct1, mct2, mct3],+ arbChar, -- same as the Char case+ $(dynamic [|tcl|] [| arbitraryFun :: (a -> Gen b -> Gen b) -> Gen b -> Gen (a->b) |])+ )++ where+ arbChar = $(dynamic [|tcl|] [| arbitraryChar :: Gen Char |])+ mct0, mct1, mct2, mct3 :: [(String,Dynamic)]+ mct0 = [("Int", $(dynamic [|tcl|] [| arbitraryInt :: Gen Int |])),+ ("Char", arbChar),+ ("Integer", $(dynamic [|tcl|] [| arbitraryInteger :: Gen Integer |])),+ ("Bool", $(dynamic [|tcl|] [| arbitraryBool :: Gen Bool |])),+ ("Double", $(dynamic [|tcl|] [| arbitraryDouble :: Gen Double |])),+ ("Float", $(dynamic [|tcl|] [| arbitraryFloat :: Gen Float |])),+ ("()", $(dynamic [|tcl|] [| arbitraryVoid :: Gen () |])),+ ("Ordering",$(dynamic [|tcl|] [| arbitraryOrdering:: Gen Ordering|]))]+ mct1 = [("Maybe", $(dynamic [|tcl|] [| arbitraryMaybe :: Gen a -> Gen (Maybe a) |])),+ ("[]", $(dynamic [|tcl|] [| arbitraryList :: Gen a -> Gen [a] |]))]+ mct2 = [("Either", $(dynamic [|tcl|] [| arbitraryEither :: Gen a -> Gen b -> Gen (Either a b) |])),+ ("(,)", $(dynamic [|tcl|] [| arbitraryPair :: Gen a -> Gen b -> Gen (a, b) |]))]+ mct3 = [("(,,)", $(dynamic [|tcl|] [| arbitraryTriplet :: Gen a -> Gen b -> Gen c -> Gen (a,b,c) |]))]++typeToArb :: ArbMap -> ArbMap -> Type -> Maybe Dynamic+typeToArb arbtup@(arbmap,arbchar,arbfun) coarbtup@(coarbmap,coarbchar,coarbfun) ty = tta 0 ty+ where+ tta 0 ty@(t :-> u) = do coarb <- typeToCoarb arbtup coarbtup t+ arb <- tta 0 u+ return (-- trace ("t = "++show t++" and u = "++show u ++ " and coarb = "++show coarb) $+ dynApp (dynApp arbfun coarb) arb)+ tta 0 (TV _) = Just arbchar -- same as the Char case+ tta _ (TV _) = Nothing -- ¤³¤ì¤Ë¤Ä¤¤¤Æ¤Ï°ìÈÌŪ¤Ê¤ä¤ê¤«¤¿¤Ï¤Ê¤µ¤½¤¦¡¥+ tta k (TC tc)+ = do guard (tc >= 0)+ imap <- IntMap.lookup k arbmap+ IntMap.lookup tc imap+ tta k (TA t0 t1) = do arb0 <- tta (k+1) t0+ arb1 <- tta 0 t1+ return (-- trace ("t0 = "++show t0++" and t1 = "++show t1) $+ dynApp arb0 arb1)+ tta _ _ = Nothing+mkCoarbMap :: TyConLib -> ArbMap+mkCoarbMap tcl@(mapNameTyCon,_) = (mkMap tcl [mct0, mct1, mct2, mct3],+ coarbChar, -- same as the Char case+ $(dynamic [|tcl|] [| coarbitraryFun :: Gen a -> (b -> Gen x -> Gen x) -> (a->b) -> Gen x -> Gen x |])+ )+ where coarbChar = $(dynamic [|tcl|] [| coarbitraryChar :: Char -> Gen x -> Gen x |])+ mct0, mct1, mct2, mct3 :: [(String,Dynamic)]+ mct0 = [("Int", $(dynamic [|tcl|] [| coarbitraryInt :: Int -> Gen x -> Gen x |])),+ ("Char", coarbChar),+ ("Integer", $(dynamic [|tcl|] [| coarbitraryInteger :: Integer -> Gen x -> Gen x |])),+ ("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 |])),+ ("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 |]))]+ mct2 = [("Either", $(dynamic [|tcl|] [| coarbitraryEither :: (a -> Gen x -> Gen x) ->+ (b -> Gen x -> Gen x) -> Either a b -> Gen x -> Gen x |])),+ ("(,)", $(dynamic [|tcl|] [| coarbitraryPair :: (a -> Gen x -> Gen x) ->+ (b -> Gen x -> Gen x) -> (a, b) -> Gen x -> Gen x |]))]+ mct3 = [("(,,)", $(dynamic [|tcl|] [| coarbitraryTriplet:: (a -> Gen x -> Gen x) ->+ (b -> Gen x -> Gen x) ->+ (c -> Gen x -> Gen x) -> (a,b,c) -> Gen x -> Gen x |]))]+typeToCoarb :: ArbMap -> ArbMap -> Type -> Maybe Dynamic+typeToCoarb arbtup@(arbmap,arbchar,arbfun) coarbtup@(coarbmap,coarbchar,coarbfun) ty = ttc 0 ty+ where -- ttc :: Type -> Maybe (Coarb Dynamic)+ ttc 0 ty@(t :-> u) = do arb <- typeToArb arbtup coarbtup t+ coarb <- ttc 0 u+ return (dynApp (dynApp coarbfun arb) coarb)+ ttc 0 (TV _) = Just coarbchar -- same as the Char case+ ttc _ (TV _) = Nothing+ ttc k (TC tc)+ = do guard (tc >= 0)+ imap <- IntMap.lookup k coarbmap+ IntMap.lookup tc imap+ ttc k (TA t0 t1) = do arb0 <- ttc (k+1) t0+ arb1 <- ttc 0 t1+ return (-- trace ("arb0 = "++show arb0++"arb1 = "++show arb1) $+ dynApp arb0 arb1)+ ttc _ _ = Nothing -- ¤á¤ó¤É¤¯¤µ¤¤¤Î¤Ç¼è¤ê¹ç¤¨¤º¡¥++++type MemoMap = (IntMap.IntMap (IntMap.IntMap (Dynamic,Dynamic)), (Dynamic,Dynamic))+mkMemoMap :: TyConLib -> MemoMap+mkMemoMap tcl@(mapNameTyCon,_) = (mkMap tcl [mct0, mct1, mct2, mct3],+ memoAppChar)+ where memoAppChar = ( $(dynamic [|tcl|] [| memoChar :: (Char->a) -> MapChar a |]), + $(dynamic [|tcl|] [| appChar :: MapChar a -> (Char->a) |]) )+ mct0, mct1, mct2, mct3 :: [(String,(Dynamic,Dynamic))]+ mct0 = [("Int", ($(dynamic [|tcl|] [| memoIx3 :: (Int->a) -> MapIx Int a |]),+ $(dynamic [|tcl|] [| appIx :: MapIx Int a -> (Int->a) |]))),+ ("Char", memoAppChar),+ ("Integer", ($(dynamic [|tcl|] [| memoInteger :: (Integer->a) -> MapInteger a |]),+ $(dynamic [|tcl|] [| appInteger :: MapInteger a -> (Integer->a) |]))),+ ("Bool", ($(dynamic [|tcl|] [| memoBool :: (Bool->a) -> MapBool a |]),+ $(dynamic [|tcl|] [| appBool :: MapBool a -> (Bool->a) |]))),+ ("Ordering",($(dynamic [|tcl|] [| memoOrdering :: (Ordering->a) -> MapOrdering a |]),+ $(dynamic [|tcl|] [| appOrdering :: MapOrdering a -> (Ordering->a) |]))),+ ("()", ($(dynamic [|tcl|] [| memoUnit :: (()->a) -> MapUnit a |]),+ $(dynamic [|tcl|] [| appUnit :: MapUnit a -> (()->a) |]))),+ ("Double", ($(dynamic [|tcl|] [| memoReal :: (Double->a) -> MapReal a |]),+ $(dynamic [|tcl|] [| appReal :: MapReal a -> (Double->a) |]))),+ ("Float", ($(dynamic [|tcl|] [| memoReal :: (Float->a) -> MapReal a |]),+ $(dynamic [|tcl|] [| appReal :: MapReal a -> (Float->a) |])))]+ mct1 = [("[]", ($(dynamicH [|tcl|] 'memoList [t| forall m b a. (forall c. (b->c) -> m c) -> ([b] -> a) -> MapList m b a |]), -- use an undefined type, because forall is not supported. (But then does this work? I don't think so....) ¤Ç¤â¡¤Ã±¤Ëforall¤ò¼è¤Ã¤Æinfinite type¤òµö¤»¤ÐOK¤Ã¤Æµ¤¤â¤¹¤ë¡¥¤É¤¦¤è¡©+ $(dynamicH [|tcl|] 'appList1 [t| forall m b a. (forall c. m c -> (b->c)) -> MapList m b a -> ([b]->a) |]))),+ ("Maybe", ($(dynamic [|tcl|] [| memoMaybe :: ((b->a)->m a) -> (Maybe b->a) -> MapMaybe m a |]),+ $(dynamic [|tcl|] [| appMaybe :: (m a->(b->a)) -> MapMaybe m a -> (Maybe b -> a) |])))]+ mct2 = [("Either", ($(dynamic [|tcl|] [| memoEither :: ((b->a) -> m a) ->+ ((d->a) -> n a) ->+ (Either b d -> a) -> MapEither m n a |]),+ $(dynamic [|tcl|] [| appEither :: (m a -> (b->a)) ->+ (n a -> (d->a)) ->+ MapEither m n a -> (Either b d -> a) |]))),+ ("(,)", ($(dynamicH [|tcl|] 'memoPair [t| forall m n b d a.+ (forall e. (b->e) -> m e) ->+ (forall f. (d->f) -> n f) ->+ ((b,d) -> a) -> MapPair m n a |]),+ $(dynamicH [|tcl|] 'appPair [t| forall m n b d a.+ (forall e. m e -> (b->e)) ->+ (forall f. n f -> (d->f)) ->+ MapPair m n a -> ((b,d) -> a) |])))]+ mct3 = [("(,,)", ($(dynamicH [|tcl|] 'memoTriplet [t| forall l m n b c d a.+ (forall f. (b->f) -> l f) ->+ (forall e. (c->e) -> m e) ->+ (forall e. (d->e) -> n e) ->+ ((b,c,d) -> a) -> MapTriplet l m n a |]),+ $(dynamicH [|tcl|] 'appTriplet [t| forall l m n b c d a.+ (forall e. l e -> (b->e)) ->+ (forall e. m e -> (c->e)) ->+ (forall e. n e -> (d->e)) ->+ MapTriplet l m n a -> ((b,c,d) -> a) |])))]+memoLength = 10+typeToMemo :: MemoMap -> Type -> (Dynamic,Dynamic)+typeToMemo memotup@(memomap,memochar) ty = case ttc 0 ty of Nothing -> (dynI,dynI) -- ¥á¥â¤Ç¤¤Ê¤¤¾ì¹ç¡¥¥Æ¥¹¥È¤¹¤ë¤È¤¤Ï¼è¤ê¹ç¤¨¤ºÁ´Éô(dynI,dynI)¤Ë¤·¤Æ¤â¤¤¤¤¤«¤â¡¥+ Just t -> t+ where ttc 0 (t:->u) = Nothing+ ttc 0 (TV _) = Just memochar+ ttc _ (TV _) = Nothing+ ttc k (TC tc) | tc < 0 = Nothing+ | otherwise = do imap <- IntMap.lookup k memomap+ IntMap.lookup tc imap+ ttc k (TA t0 t1) = do (m0,a0) <- ttc (k+1) t0+ (m1,a1) <- ttc 0 t1+ return (dynApp m0 m1, dynApp a0 a1)+ ttc _ _ = Nothing+-- Test.QuickCheck.Gen¤ÏRandom.StdGen¸ÂÄê¤Ç¡¤¤½¤ì°Ê³°¤ÎRandomGen g => g¤Ç¤Ï¥À¥á¤ß¤¿¤¤¡¥+-- Test.QuickCheck.generate¤ÎÄêµÁ¤¬¤Á¤ç¤Ã¤ÈÊѤÀ¤È»×¤¦¡¥usable¤À¤È¤Ï»×¤¦¤±¤É¡¥++type Arb a = StdGen -> [a]++arbitrariesByDyn :: TyConLib -> Dynamic -> Arb Dynamic+arbitrariesByDyn tcl arb = arbsByDyn tcl arb 0+arbsByDyn :: TyConLib -> Dynamic -> Int -> StdGen -> [Dynamic]+arbsByDyn tcl arbDyn depth stdgen = zipWith (genAppDyn tcl arbDyn) [depth..] (gens stdgen)++genAppDyn :: TyConLib -> Dynamic -> Int -> StdGen -> Dynamic+genAppDyn tcl arbDyn size stdgen = dynApp $(dynamic [|tcl|] [| (\(Gen f) -> f size stdgen) :: Gen a -> a |] ) arbDyn++{- ¼ÂºÝ¤â¤¦»È¤ï¤ì¤Æ¤¤¤Ê¤¤¤·¡¥´Ö°ã¤¨¤Æ¤³¤Ã¤Á¤òÊÔ½¸¤·¤Á¤ã¤¦¤Î¤Ç¡¤±£¤¹¡¥+arbitrariesBy :: Gen a -> Arb a+arbitrariesBy arb = arbsBy arb 0+arbsBy :: Gen a -> Int -> StdGen -> [a]+arbsBy (Gen f) n stdgen = case split stdgen of (g0,g1) -> f n g0 : arbsBy arb (n+1) g1++arbitraries :: Arbitrary a => Arb a+arbitraries = arbitrariesBy arbitrary+-}++++-- nrnds¤Ï¼Â¤Ïsize¤ò·è¤á¤ë¤¿¤á¤Ë¤·¤«»È¤ï¤ì¤Æ¤¤¤Ê¤¤¡¥ÆÀ¤é¤ì¤ë¤Î¤ÏStream (Bag Dynamic)¤Ç¤Ï¤Ê¤¯Stream (Stream Dynamic)+arbitrariessByDyn :: [Int] -> TyConLib -> Dynamic -> StdGen -> [[Dynamic]]+arbitrariessByDyn nrnds tcl arb gen = abd nrnds tcl arb 0 gen+-- abd _ _ arb depth gen = zipWith (arbsByDyn arb) [depth..] (gens gen) -- Íð¿ô¥µ¥¤¥º¤ò¾®¤µ¤¤Ãͤ«¤éÁý¤ä¤·¤Æ¤¤¤¯¾ì¹ç+abd nrnds tcl arb depth gen = zipWith (arbsByDyn' nrnds tcl arb) [depth..] (gens gen) -- Íð¿ô¥µ¥¤¥º¤ò°ìÄê¤Ë¤¹¤ë¾ì¹ç+arbsByDyn' nrnds tcl arbDyn depth stdgen = map (genAppDyn tcl arbDyn size) (gens stdgen)+ where size = max depth (nrnds !! depth)+gens gen = case split gen of (g0,g1) -> g0 : gens g1
+ MagicHaskeller/LibTH.hs view
@@ -0,0 +1,168 @@+-- +-- (c) Susumu Katayama 2009+--+-- This file is supposed to be used with Version 0.8.5 of MagicHaskeller.+-- For previous versions, try:+-- darcs get http://nautilus.cs.miyazaki-u.ac.jp/~skata/ somedirectoryname+-- and retrieve an older version via some darcs command.+{-# OPTIONS -XTemplateHaskell -XNoMonomorphismRestriction -fglasgow-exts #-}+module MagicHaskeller.LibTH(module MagicHaskeller.LibTH, module MagicHaskeller) where++import MagicHaskeller+import System.Random(mkStdGen)++initialize, init075 :: IO ()+initialize = do setPrimitives (list ++ nat ++ natural ++ mb ++ bool ++ $(p [| (hd :: (->) [a] (Maybe a), (+) :: Int -> Int -> Int, (+) :: Integer -> Integer -> Integer) |]))+ setDepth 10+-- MagicHaskeller version 0.8 ignores the setDepth value and always memoizes.++init075 = do setPG $ mkMemo075 (list ++ nat ++ natural ++ mb ++ bool ++ $(p [| ((+) :: Int -> Int -> Int, (+) :: Integer -> Integer -> Integer) |] ))+ setDepth 10++-- Specialized memoization tables. Choose one for quicker results.+mall, mlist, mlist', mnat, mlistnat, mnat_nc :: 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'+mnat = mkPG (nat ++ $(p [| (+) :: Int -> Int -> Int |]))+mnatural = mkPG (natural ++ $(p [| (+) :: Integer -> Integer -> Integer |]))+mlistnat = mkPG (list ++ nat ++ $(p [| (+) :: Int -> Int -> Int |]))+mlistnatural = mkPG (list ++ natural ++ $(p [| (+) :: Integer -> Integer -> Integer |]))++mnat_nc = mkMemo (nat ++ $(p [| (+) :: Int -> Int -> Int |]))++hd :: [a] -> Maybe a+hd [] = Nothing+hd (x:_) = Just x++-- Prefixed (->) means that the parameter can be matched as an assumption when 'constrL' option is True. Also, this info is used when 'guess' option is True. For example of maybe :: a -> (b->a) -> (->) (Maybe b) a, +-- Gamma |- A Gamma,B |- A+-- ---------------------------maybe+-- Gamma, Maybe B |- A+-- rather than+-- Gamma |- A Gamma,B |- A Gamma |- Maybe B+-- -----------------------------------------------maybe+-- 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, rich, rich', debug :: [Primitive]+mb = $(p [| ( Nothing :: Maybe a, Just :: a -> Maybe a, maybe :: a -> (b->a) -> (->) (Maybe b) 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 paramorphism+nat_para :: Integral i => i -> a -> (i -> a -> a) -> a+nat_para i x f = np (abs i) -- Version 0.8 does not deal with partial functions very well.+ where np 0 = x+ np i = let i' = i-1+ in f i' (np i')++list' = $(p [| ([] :: [a], (:) :: a -> [a] -> [a], foldr :: (b -> a -> a) -> a -> (->) [b] a) |] )+list = $(p [| ([] :: [a], (:) :: a -> [a] -> [a], list_para :: (->) [b] (a -> (b -> [b] -> a -> a) -> a)) |] )++-- List paramorphism+list_para :: [b] -> a -> (b -> [b] -> a -> a) -> a+list_para [] x f = x+list_para (y:ys) x f = f y ys (list_para ys x f)++bool = $(p [| (True, False, iF :: (->) Bool (a -> a -> a)) |] )++iF :: Bool -> a -> a -> a+iF True t f = t+iF False t f = f+++boolean = $(p [| ((&&) :: Bool -> Bool -> Bool,+ (||) :: Bool -> Bool -> Bool,+ not :: Bool -> Bool) |] )+-- Type classes are not supported yet....+eq = $(p [| ((==) :: Int->Int->Bool, (/=) :: Int->Int->Bool,+ (==) :: Char->Char->Bool, (/=) :: Char->Char->Bool,+ (==) :: Bool->Bool->Bool, (/=) :: Bool->Bool->Bool,+ (==) :: [Int] ->[Int] ->Bool, (/=) :: [Int] ->[Int]->Bool,+ (==) :: [Char]->[Char]->Bool, (/=) :: [Char]->[Char]->Bool,+ (==) :: [Bool]->[Bool]->Bool, (/=) :: [Bool]->[Bool]->Bool) |] )+-- ...bothered.+intinst = $(p [| ( (<=) :: 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) |])++list1 = $(p [| (map :: (a -> b) -> (->) [a] [b],+ (++) :: [a] -> [a] -> [a],+ filter :: (a -> Bool) -> [a] -> [a],+ concat :: [[a]] -> [a],+ concatMap :: (a -> [b]) -> (->) [a] [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]],+ unlines :: [[Char]] -> [Char],+ unwords :: [[Char]] -> [Char] ) |] )++list3 = $(p [| (reverse :: [a] -> [a],+ and :: [Bool] -> Bool,+ or :: [Bool] -> Bool,+ any :: (a -> Bool) -> (->) [a] Bool,+ all :: (a -> Bool) -> (->) [a] Bool,+ zipWith :: (a->b->c) -> (->) [a] ((->) [b] [c]) ) |] )++nats = $(p [| (1 ::Int, 2 :: Int, 3 :: Int) |])++reallyall :: ProgramGenerator pg => pg+reallyall = mkPG rich++nrnds = repeat 5+++-- comment out (mkStdGen 123456) when using 0.8.3*+++-- Currently only the pg==ConstrLSF case makes sense.+mix, poormix :: ProgramGenerator pg => pg+mix = mkPGSF (mkStdGen 123456)+ nrnds+ (list++bool)+ rich++rich = (list ++ bool +++ -- nat +++ -- mb ++ bool ++ $(p [| (hd :: [a] -> Maybe a, (+) :: Int -> Int -> Int) |]) +++ boolean ++ eq ++ -- intinst +++ list1 ++ list2 ++ list3)+++poormix = mkPGSF (mkStdGen 123456)+ nrnds+ $(p [| ([] :: [a], True) |] )+ rich++-- just for debugging+ra :: ProgramGenerator pg => pg+ra = mkPG rich'+rich' = (list++bool++boolean+++ list1 ++ list3)++mx :: ProgramGenerator pg => pg+mx = mkPGSF (mkStdGen 123456)+ nrnds+ (list++bool)+ rich'++debug = $(p [| (list_para :: (->) [b] (a -> (b -> [b] -> a -> a) -> a), concatMap :: (a -> [b]) -> (->) [a] [b]) |] )+
+ MagicHaskeller/MHTH.lhs view
@@ -0,0 +1,127 @@+-- +-- (c) Susumu Katayama 2009+--+MHTH is consisted of combinators which include quasi-quotes. They are moved from MagicHaskeller.lhs because Haddock dislikes quasi-quotes.+\begin{code}+-- #hide++{-# OPTIONS -XTemplateHaskell -cpp #-}+module MagicHaskeller.MHTH(expToExpExp, maybeWithTO, maybeWithPTO, newPTO, typeToExpType, unsafeWithPTO, unsafeOpWithPTO) where +import Language.Haskell.TH+import System.IO.Unsafe(unsafePerformIO)+import Data.IORef+-- import Types+#ifdef CHTO+import MagicHaskeller.TimeOut+#endif+import Control.Monad(liftM)++import MagicHaskeller.ReadTHType(showTypeName)++unsafeWithPTO :: Maybe Int -> a -> Maybe a+#ifdef CHTO+unsafeWithPTO pto a = unsafePerformIO $ wrapExecution (+ maybeWithPTO seq (return a) pto+ )+maybeWithPTO :: (a -> IO () -> IO ()) -- ^ seq or deepSeq(=Control.Parallel.Strategies.sforce). For our purposes seq is enough, because @a@ is either 'Bool' or 'Ordering'.+ -> IO a -> (Maybe Int) -> IO (Maybe a)+maybeWithPTO sq = flip (maybeWithTO sq)+newPTO t = return t+#else+unsafeWithPTO _ = Just+maybeWithPTO :: c -> IO a -> b -> IO (Maybe a)+maybeWithPTO _ action _ = do a <- action+ return (Just a)+maybeWithTO :: c -> b -> IO a -> IO (Maybe a)+maybeWithTO _ _ action = do a <- action+ return (Just a)+newPTO = error "not implemented on this platform."+#endif++unsafeOpWithPTO :: Maybe Int -> (a->b->c) -> a -> b -> Maybe c+unsafeOpWithPTO mto op l r = unsafeWithPTO mto (op l r)++#ifdef __GLASGOW_HASKELL__+nameToNameStr :: (Name -> String) -> Name -> ExpQ+nameToNameStr shw name = return $ LitE (StringL (shw name))++-- This is necessary because GHC.Base.[] would not parse as expected.+showName :: Name -> String+showName name | name == '[] = "[]" -- data constructor+ | name == ''[] = "[]" -- type constructor+ | otherwise = show name++-- showVarName = nameBase+showVarName = showName++expToExpExp :: Exp -> ExpQ+expToExpExp (VarE name) = [| VarE (mkName $(nameToNameStr showVarName name)) |]+expToExpExp (ConE name) = [| ConE (mkName $(nameToNameStr showVarName name)) |]+expToExpExp (AppE e0 e1) = [| AppE $(expToExpExp e0) $(expToExpExp e1) |]+expToExpExp (LamE ps e) = [| LamE $(liftM ListE $ mapM patToExpPat ps) $(expToExpExp e) |] +expToExpExp (InfixE Nothing e Nothing) = [| InfixE Nothing $(expToExpExp e) Nothing |]+expToExpExp (InfixE (Just e0) e Nothing) = [| InfixE (Just $(expToExpExp e0)) $(expToExpExp e) Nothing |]+expToExpExp (InfixE Nothing e (Just e1)) = [| InfixE Nothing $(expToExpExp e) (Just $(expToExpExp e1)) |]+expToExpExp (InfixE (Just e0) e (Just e1)) = [| InfixE (Just $(expToExpExp e0)) $(expToExpExp e) (Just $(expToExpExp e1)) |]+expToExpExp (TupE es) = [| (return . AppE . TupE) =<< $((return . ListE) =<< mapM expToExpExp es) |]+expToExpExp (CondE e0 e1 e2) = [| CondE $(expToExpExp e0) $(expToExpExp e1) $(expToExpExp e2) |]+expToExpExp (ListE es) = [| (return . AppE . ListE) =<< $((return . ListE) =<< mapM expToExpExp es) |]+expToExpExp e@(LitE (CharL c)) = [| LitE (CharL $(return e)) |]+expToExpExp e@(LitE (StringL s)) = [| LitE (StringL $(return e)) |]+expToExpExp e@(LitE (IntegerL c)) = [| LitE (IntegerL $(return e)) |]+expToExpExp e@(LitE (RationalL s)) = [| LitE (RationalL $(return e)) |]+expToExpExp (SigE e t) = [| SigE $(expToExpExp e) $(typeToExpType t) |]+expToExpExp e = [| VarE (mkName $(return $ LitE (StringL (show e)))) |]++{-+typeToExpType :: Type -> Exp+typeToExpType (TC (Con k i)) = [| TC (Con $(return $ LitE (IntegerL k)) $(return $ LitE (IntegerL i)) |]+typeToExpType (TV (Var i True k)) = [| TV (Var $(return $ LitE (IntegerL i)) True $(return $ LitE (IntegerL k)) |]+typeToExpType (TA t0 t1) = [| TA $(typeToExpType t0) $(typeToExpType t1) |]+typeToExpType (t0 :-> t1) = [| $(typeToExpType t0) :-> $(typeToExpType t1) |]+-}+typeToExpType :: Type -> ExpQ+typeToExpType (ForallT ns [] t) = [| ForallT (map mkName $(return $ ListE $ map (LitE . StringL . showTypeName) ns)) [] $(typeToExpType t) |]+typeToExpType (ForallT _ (_:_) _) = error "typeToExpType: Type classes are not implemented yet."+typeToExpType (ConT name) = [| ConT (mkName $(nameToNameStr showTypeName name)) |]+typeToExpType (VarT name) = [| VarT (mkName $(nameToNameStr showTypeName name)) |]+typeToExpType (AppT t0 t1) = [| AppT $(typeToExpType t0) $(typeToExpType t1) |]+typeToExpType (TupleT n) = [| TupleT $(return $ LitE (IntegerL (toInteger n))) |]+typeToExpType ArrowT = [| ArrowT |]+typeToExpType ListT = [| ListT |]++patToExpPat (VarP name) = [| VarP (mkName $(nameToNameStr showVarName name)) |]+patToExpPat (TupP ps) = [| TupP $(liftM ListE $ mapM patToExpPat ps) |]+patToExpPat (ConP name ps) = [| ConP (mkName $(nameToNameStr showVarName name)) $(liftM ListE $ mapM patToExpPat ps) |]+patToExpPat (InfixP p0 name p1) = [| InfixP $(patToExpPat p0) (mkName $(nameToNameStr showVarName name)) $(patToExpPat p1) |]+patToExpPat (TildeP p) = [| TildeP $(patToExpPat p) |]+patToExpPat (AsP name p) = [| AsP (mkName $(nameToNameStr showVarName name)) $(patToExpPat p) |]+patToExpPat WildP = [| WildP |]+patToExpPat (ListP ps) = [| ListP $(liftM ListE $ mapM patToExpPat ps) |]+patToExpPat (SigP p t) = [| SigP $(patToExpPat p) $(typeToExpType t) |]++#endif++instance Ord Type where+ compare (ForallT _ [] t0) (ForallT _ [] t1) = compare t0 t1+ compare (ForallT _ [] _) _ = GT+ compare _ (ForallT _ _ _ ) = LT+ compare (VarT n0) (VarT n1) = compare n0 n1+ compare (VarT _) _ = GT+ compare _ (VarT _) = LT+ compare (ConT n0) (ConT n1) = compare n0 n1+ compare (ConT _) _ = GT+ compare _ (ConT _) = LT+ compare (TupleT n0) (TupleT n1) = compare n0 n1+ compare (TupleT _) _ = GT+ compare _ (TupleT _) = LT+ compare ArrowT ArrowT = EQ+ compare ArrowT _ = GT+ compare _ ArrowT = LT+ compare ListT ListT = EQ+ compare ListT _ = GT+ compare _ ListT = LT+ compare (AppT f0 x0) (AppT f1 x1) = case compare f0 f1 of EQ -> compare x0 x1+ o -> o++\end{code}
+ MagicHaskeller/MyCheck.hs view
@@ -0,0 +1,233 @@+-- +-- (c) Susumu Katayama 2009+--+{-+rewrite of QuickCheck.Arbitrary in the form specialized for each type+@inproceedings{QuickCheck,+ AUTHOR = "Koen Claessen and John Hughes",+ TITLE = "{QuickCheck}: a lightweight tool for random testing of {Haskell} programs",+ BOOKTITLE = "ICFP'00: Proceedings of the 5th ACM SIGPLAN International Conference on Functional Programming",+ PAGES = "268-279",+ ORGANIZATION = "ACM",+ YEAR = 2000 }+The original source is released under BSD-style license.+I (Susumu) reimplemented this because QuickCheck-1 had (and has?) some bugs and QuickCheck-2 was not released, but +maybe I could import and reuse definitions of Arbitrary of QuickCheck-2.+(But still I am interested in using different generator than StdGen.)+-}+module MagicHaskeller.MyCheck where+import System.Random+import Control.Monad(liftM, liftM2, liftM3)+import Data.Char(ord,chr)+import Data.Ratio++newtype Gen a = Gen {unGen :: Int -> StdGen -> a}+type Coarb a b = a -> Gen b -> Gen b++sized :: (Int -> Gen a) -> Gen a+sized fgen = Gen $ \n g -> unGen (fgen n) n g++instance Functor Gen where+ fmap = liftM++instance Monad Gen where+ return a = Gen $ \_ _ -> a+ Gen m >>= k = Gen $ \n g -> case split g of (g1,g2) -> unGen (k (m n g1)) n g2++arbitraryR :: Random a => (a, a) -> Gen a+arbitraryR bnds = Gen $ \ _ gen -> fst $ randomR bnds gen+-- arbitrary :: (Random a, Bounded a) => Gen a+-- arbitrary = arbitraryR (minBound, maxBound)++arbitraryVoid :: Gen ()+arbitraryVoid = return ()+coarbitraryVoid :: Coarb () b+coarbitraryVoid _ = id++arbitraryBool :: Gen Bool+arbitraryBool = arbitraryR (False,True)+coarbitraryBool :: Coarb Bool b+-- coarbitraryBool b = if b then variant 0 else variant 1+coarbitraryBool b (Gen f) = Gen $ \size stdgen -> f size $ case split stdgen of (g0,g1) -> if b then g0 else g1++arbitraryInt :: Gen Int+arbitraryInt = arbitraryIntegral+coarbitraryInt :: Coarb Int b+coarbitraryInt n = newvariant n++arbitraryInteger :: Gen Integer+arbitraryInteger = arbitraryIntegral+coarbitraryInteger :: Coarb Integer b+coarbitraryInteger n = newvariant n++arbitraryIntegral :: (Random i, Integral i) => Gen i+arbitraryIntegral = sized $ \n -> arbitraryR ( - fromIntegral n, fromIntegral n )++-- variant of Test.QuickCheck.variant using divide-and-conquer+logvariant, newvariant :: Integral i => i -> Gen a -> Gen a+logvariant 0 = coarbitraryBool True+logvariant n | n > 0 = coarbitraryBool False . logvariant (n `div` 2) . coarbitraryBool (n `mod` 2 == 0)+ | otherwise = error "logvariant: negative argument"+newvariant n | n >= 0 = coarbitraryBool True . logvariant n+ | otherwise = coarbitraryBool False . logvariant (-1-n)++arbitraryFloat :: Gen Float+arbitraryFloat = arbitraryRealFloat+arbitraryDouble :: Gen Double+arbitraryDouble = arbitraryRealFloat++coarbitraryFloat :: Coarb Float b+coarbitraryFloat = coarbitraryRealFloat+coarbitraryDouble :: Coarb Double b+coarbitraryDouble = coarbitraryRealFloat++fraction a b c = fromInteger a + (fromInteger b / (abs (fromInteger c) + 1))++arbitraryRealFloat :: RealFloat a => Gen a+arbitraryRealFloat = liftM3 fraction arbitraryInteger arbitraryInteger arbitraryInteger+coarbitraryRealFloat :: RealFloat a => Coarb a b+coarbitraryRealFloat x = let (sig, xpo) = decodeFloat x in newvariant sig . newvariant xpo++arbitraryChar = arbitraryR (' ', chr 126)+coarbitraryChar c = newvariant (ord c)++arbitraryOrdering :: Gen Ordering+arbitraryOrdering = arbitraryR (0,2) >>= return . toEnum+-- Ordering is not an instance of Random!++arbitraryMaybe :: Gen a -> Gen (Maybe a)+arbitraryMaybe arb = do b <- arbitraryBool+ if b then return Nothing else liftM Just arb++arbitraryList :: Gen a -> Gen [a]+arbitraryList arb = sized $ \n -> arbitraryR (0,n) >>= \n -> sequence $ replicate n arb++arbitraryPair :: Gen a -> Gen b -> Gen (a,b)+arbitraryPair = liftM2 (,)++arbitraryEither :: Gen a -> Gen b -> Gen (Either a b)+arbitraryEither arb0 arb1 = do b <- arbitraryBool+ if b then liftM Left arb0 else liftM Right arb1++arbitraryTriplet :: Gen a -> Gen b -> Gen c -> Gen (a,b,c)+arbitraryTriplet = liftM3 (,,)++arbitraryFun :: Coarb a b -> Gen b -> Gen (a->b)+arbitraryFun coarb arb = Gen (\n r a -> unGen (coarb a arb) n r)++arbitraryRational :: Gen Rational+arbitraryRational = arbitrary+++coarbitraryOrdering :: Coarb Ordering b+coarbitraryOrdering x = case x of LT -> coarbitraryBool True+ EQ -> coarbitraryBool False . coarbitraryBool True+ GT -> coarbitraryBool False . coarbitraryBool False++coarbitraryList :: Coarb a b -> Coarb [a] b+coarbitraryList _ [] = coarbitraryBool True+coarbitraryList coarb (x:xs) = coarbitraryBool False . coarb x . coarbitraryList coarb xs++coarbitraryMaybe :: Coarb a b -> Coarb (Maybe a) b+coarbitraryMaybe _ Nothing = coarbitraryBool True+coarbitraryMaybe coarb (Just x) = coarbitraryBool False . coarb x++coarbitraryEither :: Coarb a c -> Coarb b c -> Coarb (Either a b) c+coarbitraryEither coarb0 _ (Left x) = coarbitraryBool True . coarb0 x+coarbitraryEither _ coarb1 (Right y) = coarbitraryBool False . coarb1 y++coarbitraryPair :: Coarb a c -> Coarb b c -> Coarb (a,b) c+coarbitraryPair coarb0 coarb1 (a,b) = coarb0 a . coarb1 b++coarbitraryTriplet :: Coarb a d -> Coarb b d -> Coarb c d -> Coarb (a,b,c) d+coarbitraryTriplet coarb0 coarb1 coarb2 (a,b,c) = coarb0 a . coarb1 b . coarb2 c++coarbitraryFun :: Gen a -> Coarb b d -> Coarb (a->b) d+-- This is based on QuickCheck-1, and quite lightweight.+coarbitraryFun arb coarb f gen = arb >>= \x -> coarb (f x) gen++-- This is a definition based on QuickCheck-2:+-- coarbitraryFun arb coarb f gen = arbitraryList arb >>= \xs -> coarbitraryList coarb (map f xs) gen++-- This does even heavier check.+-- coarbitraryFun arb coarb f gen = (sized $ \n -> sequence $ replicate n arb) >>= \xs -> coarbitraryList coarb (map f xs) gen++class Arbitrary a where+ arbitrary :: Gen a+class Coarbitrary a where+ coarbitrary :: a -> Gen b -> Gen b++instance Arbitrary () where+ arbitrary = arbitraryVoid+instance Coarbitrary () where+ coarbitrary = coarbitraryVoid++instance Arbitrary Bool where+ arbitrary = arbitraryBool+instance Coarbitrary Bool where+ coarbitrary = coarbitraryBool++instance Arbitrary Int where+ arbitrary = arbitraryInt+instance Coarbitrary Int where+ coarbitrary = coarbitraryInt++instance Arbitrary Integer where+ arbitrary = arbitraryInteger+instance Coarbitrary Integer where+ coarbitrary = coarbitraryInteger++instance Arbitrary Float where+ arbitrary = arbitraryFloat+instance Coarbitrary Float where+ coarbitrary = coarbitraryFloat++instance Arbitrary Double where+ arbitrary = arbitraryDouble+instance Coarbitrary Double where+ coarbitrary = coarbitraryDouble++instance Arbitrary Char where+ arbitrary = arbitraryChar+instance Coarbitrary Char where+ coarbitrary = coarbitraryChar++instance Arbitrary Ordering where+ arbitrary = arbitraryOrdering+instance Coarbitrary Ordering where+ coarbitrary = coarbitraryOrdering++instance Arbitrary a => Arbitrary (Maybe a) where+ arbitrary = arbitraryMaybe arbitrary+instance Coarbitrary a => Coarbitrary (Maybe a) where+ coarbitrary = coarbitraryMaybe coarbitrary++instance Arbitrary a => Arbitrary [a] where+ arbitrary = arbitraryList arbitrary+instance Coarbitrary a => Coarbitrary [a] where+ coarbitrary = coarbitraryList coarbitrary++instance (Arbitrary a, Arbitrary b) => Arbitrary (a,b) where+ arbitrary = arbitraryPair arbitrary arbitrary+instance (Coarbitrary a, Coarbitrary b) => Coarbitrary (a,b) where+ coarbitrary = coarbitraryPair coarbitrary coarbitrary++instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where+ arbitrary = arbitraryEither arbitrary arbitrary+instance (Coarbitrary a, Coarbitrary b) => Coarbitrary (Either a b) where+ coarbitrary = coarbitraryEither coarbitrary coarbitrary++instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (a,b,c) where+ arbitrary = arbitraryTriplet arbitrary arbitrary arbitrary+instance (Coarbitrary a, Coarbitrary b, Coarbitrary c) => Coarbitrary (a,b,c) where+ coarbitrary = coarbitraryTriplet coarbitrary coarbitrary coarbitrary++instance (Coarbitrary a, Arbitrary b) => Arbitrary (a->b) where+ arbitrary = arbitraryFun coarbitrary arbitrary+instance (Arbitrary a, Coarbitrary b) => Coarbitrary (a->b) where+ coarbitrary = coarbitraryFun arbitrary coarbitrary++instance (Integral i, Random i) => Arbitrary (Ratio i) where+ arbitrary = liftM2 (%) arbitraryIntegral (fmap (\x->1+abs x) arbitraryIntegral)+instance (Integral i) => Coarbitrary (Ratio i) where+ coarbitrary r = newvariant (numerator r) . logvariant (denominator r)
+ MagicHaskeller/MyDynamic.hs view
@@ -0,0 +1,39 @@+-- +-- (c) Susumu Katayama 2009+--+# ifdef REALDYNAMIC+module MagicHaskeller.MyDynamic(module MagicHaskeller.PolyDynamic, dynamic, dynamicH) where+import MagicHaskeller.PolyDynamic+# else+module MagicHaskeller.MyDynamic(module MagicHaskeller.FakeDynamic, dynamic, dynamicH) where+import MagicHaskeller.FakeDynamic -- MY dynamic+# endif++import MagicHaskeller.ReadTHType(thTypeToType)+import MagicHaskeller.ReadTypeRep(trToType)+import Language.Haskell.TH hiding (Type)+import MagicHaskeller.MHTH+import Data.Typeable(typeOf)+{-+$(dynamic [|tcl|] [| (,) :: forall a b. a->b->(a,b) |])+$B$N$h$&$K$G$-$k$h$&$K$9$k!%(BCLEAN$B$N(Bdynamic$B$_$?$$$J46$8!%(B+-}+dynamic :: ExpQ -> ExpQ -> ExpQ+dynamic eqtcl eq = eq >>= p' eqtcl+++-- Quasi-quotes with higher-rank types are not permitted. When that is the case, take the type info apart from the expression.+-- E.g. $(dynamicH [|tcl|] 'foo [t| forall a b. a->b->(a,b) |]) is equivalent to $(dynamic [|tcl|] [| foo :: forall a b. a->b->(a,b) |])+dynamicH :: ExpQ -> Name -> TypeQ -> ExpQ+dynamicH eqtcl nm tq = do t <- tq+ px eqtcl (VarE nm) t+-- p' is like MagicHaskeller.p'+{- MagicHaskeller.lhs$B$N%$%^%$%A$JDj5A(B+p' eqtcl se@(SigE e ty) = [| unsafeToDyn $eqtcl (readType' $eqtcl $(return (LitE (StringL (pprintType ty))))) $(return se) $(expToExpExp e) |]+p' eqtcl e = [| unsafeToDyn $eqtcl (readType' $eqtcl (show (typeOf $(return e)))) $(return e) $(expToExpExp e) |]+-}+p' eqtcl (SigE e ty) = px eqtcl e ty+p' eqtcl e = [| unsafeToDyn $eqtcl (trToType $eqtcl (typeOf $(return e))) $(return e) $(expToExpExp e) |]++px eqtcl e ty = [| unsafeToDyn $eqtcl (thTypeToType $eqtcl $(typeToExpType ty)) $(return se) $(expToExpExp se) |]+ where se = SigE e ty
+ MagicHaskeller/PriorSubsts.lhs view
@@ -0,0 +1,174 @@+-- +-- (c) Susumu Katayama 2009+--+\begin{code}+{-# OPTIONS -cpp -fglasgow-exts #-}+module MagicHaskeller.PriorSubsts where++import Control.Monad+import Control.Monad.Search.Combinatorial+import MagicHaskeller.Types+import Data.Array.IArray+import Data.Monoid+import MagicHaskeller.T10(mergeWithBy)++-- import T10(nubSortBy)+import Data.List++import Debug.Trace++substOKPS :: Monad m => String -> PriorSubsts m ()+substOKPS str = do subst <- getSubst+ if substOK subst then return () else error (str ++ "subst not OK. subst = "++show subst)++monsubst :: Monad m => PriorSubsts m ()+monsubst = do s <- getSubst+ trace ("subst = "++show s) $ return ()++mkPS :: Monad m => m a -> PriorSubsts m a+mkPS x = PS (\subst mx -> x >>= \a -> return (a,subst,mx))+++runPS :: Monad m => PriorSubsts m a -> m a+runPS (PS f) = do (x,_,_) <- f emptySubst 0+ return x++-- delayPS :: (Delay (m a)) => PriorSubsts m a -> PriorSubsts m a+-- delayPS = convertPS delay+delayPS (PS f) = PS g where g s i = delay (f s i)++{-# SPECIALIZE convertPS :: ([(a,Subst,Int)] -> Recomp (a,Subst,Int)) -> PriorSubsts [] a -> PriorSubsts Recomp a #-}+{-# SPECIALIZE convertPS :: ([(a,Subst,Int)] -> [(a,Subst,Int)]) -> PriorSubsts [] a -> PriorSubsts [] a #-}+convertPS :: (m (a,Subst,Int) -> n (a,Subst,Int)) -> PriorSubsts m a -> PriorSubsts n a+convertPS f (PS g) = PS h where h s i = f (g s i)++newtype PriorSubsts m a = PS {unPS :: Subst -> Int -> m (a, Subst, Int)}+instance Monad m => Monad (PriorSubsts m) where+ {-# SPECIALIZE instance Monad (PriorSubsts []) #-}+ return x = PS (\s m -> return (x, s, m))+ PS x >>= f = PS (\s i -> do (a,t,j) <- x s i+ unPS (f a) t j)+-- {-# INLINE (>>=) #-} °ÕÌ£¤Ê¤«¤Ã¤¿¡¥+-- PS x >>= f = x `thenPS` f ¤³¤ì¤â°ÕÌ£¤Ê¤«¤Ã¤¿¡¥¤Þ¤¢¡¤Monad¤Ï¥Ç¥Õ¥©¥ë¥È¤Çinline¤·¤Æ¤ë¤«¤â¡©++-- {-# INLINE listThenPS #-}+-- {-# INLINE thenPS #-}+-- x `thenPS` f = PS (\s i -> do (a,t,j) <- x s i+-- unPS (f a) t j)+-- x `listThenPS` f = PS (\s i -> [ (b, u, k) | (a, t, j) <- x s i, (b, u, k) <- unPS (f a) t j ])+-- {-# RULES "listThenPS" thenPS = listThenPS #-}++-- distPS is also used to implement ifDepthPS+distPS op (PS f) (PS g) = PS (\s i -> f s i `op` g s i)++instance MonadPlus m => MonadPlus (PriorSubsts m) where+ {-# SPECIALIZE instance MonadPlus (PriorSubsts []) #-}+ mzero = PS (\_ _->mzero)+ mplus = distPS mplus+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)+instance Monoid a => Monoid (PriorSubsts Recomp a) where+ mempty = PS (\_ _ -> mzero)+ PS f `mappend` PS g = PS $ \s i -> Rc $ \dep -> mergeWithBy (\(xs,k,i) (ys,_,_) -> (xs `mappend` ys, k, i)) (\ (_,k,_) (_,l,_) -> k `compare` l) (unRc (f s i) dep) (unRc (g s i) dep)++instance Functor m => Functor (PriorSubsts m) where+ fmap f (PS g) = PS (\s i -> fmap (\ (x, s', i') -> (f x, s', i')) (g s i))++{-# RULES "fmap/fmap" [2] forall f g x. fmap f (fmap g x) = fmap (f . g) x #-}+++{-# SPECIALIZE applyPS :: Type -> PriorSubsts [] Type #-}+applyPS :: MonadPlus 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 subst = PS (\s i -> return ((), subst `plusSubst` s, i))+{-# SPECIALIZE updateSubstPS :: (Subst -> [] Subst) -> PriorSubsts [] () #-}+updateSubstPS :: MonadPlus 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 subst = updateSubstPS (\_ -> return subst)++{-# SPECIALIZE mguPS :: Type -> Type -> PriorSubsts [] () #-}+mguPS, matchPS :: MonadPlus m => Type -> Type -> PriorSubsts m ()+mguPS t0 t1 = do subst <- mgu t0 t1+ updatePS subst+{-# SPECIALIZE varBindPS :: TyVar -> Type -> PriorSubsts [] () #-}+varBindPS :: MonadPlus m => TyVar -> Type -> PriorSubsts m ()+varBindPS v t = do subst <- varBind v t+ updatePS subst+matchPS t0 t1 = do subst <- match t0 t1+ updatePS subst+{-+symPlusPS :: MonadPlus m => Subst -> PriorSubsts m ()+symPlusPS subst = do s0 <- getSubst+ s1 <- symPlus subst s0+ setSubst s1+-}++lookupSubstPS :: MonadPlus m => Int -> PriorSubsts m Type+lookupSubstPS tvid = do subst <- getSubst+ case lookupSubst subst tvid of Nothing -> mzero+ Just ty -> return ty++-- what follow are mainly used by module Infer, but can be reused if necessary.+{-# SPECIALIZE getSubst :: PriorSubsts [] Subst #-}+getSubst :: Monad m => PriorSubsts m Subst+getSubst = PS (\s i -> return (s,s,i))+{-# SPECIALIZE getMx :: PriorSubsts [] Int #-}+getMx :: Monad m => PriorSubsts m Int+getMx = PS (\s i -> return (i,s,i))+{-# SPECIALIZE updateMx :: (Int->Int) -> PriorSubsts [] () #-}+updateMx :: Monad m => (Int->Int) -> PriorSubsts m ()+updateMx f = PS (\s i -> return ((), s, f i))+{-# SPECIALIZE unify :: Type -> Type -> PriorSubsts [] () #-}+unify :: MonadPlus m => Type -> Type -> PriorSubsts m ()+unify t1 t2 = do s <- getSubst+ u <- mgu (apply s t1) (apply s t2)+ updatePS u++newTVar :: Monad m => PriorSubsts m TyVar+newTVar = PS (\ s n -> return (n, s, n+1))+++-- Ʊ¤¸Ì¾Á°¤Î´Ø¿ô¤¬allifdefs/PSList.hs¤Ë¤â¤¢¤Ã¤¿¤ê¤¹¤ë¡¥Ìò³ä¤â»÷¤¿¤è¤¦¤Ê¤â¤ó¡¥+psListToPSRecomp :: (Int -> PriorSubsts [] a) -> PriorSubsts Recomp a+psListToPSRecomp f = PS (\subst int -> Rc (\dep -> case f dep of PS g -> g subst int))+psRecompToPSList :: PriorSubsts Recomp a -> Int -> PriorSubsts [] a+psRecompToPSList (PS f) dep = PS (\subst int -> case f subst int of Rc g -> g dep)++psListToPSDBound :: (Int -> PriorSubsts [] (a,Int)) -> PriorSubsts DBound a+psListToPSDBound f = PS (\subst int -> DB (\dep -> case f dep of PS g -> map tup23 $ g subst int))+psDBoundToPSList :: PriorSubsts DBound a -> Int -> PriorSubsts [] (a,Int)+psDBoundToPSList (PS f) dep = PS (\subst int -> case f subst int of DB g -> map tup32 $ g dep)++tup23 ((a,i),k,m) = ((a,k,m),i)+tup32 ((a,k,m),i) = ((a,i),k,m)++nubSortBy :: (a -> a -> Ordering) -> [a] -> [a]+nubSortBy cmp = uniqBy (\a b->cmp a b==EQ) . sortBy cmp+uniqBy :: (a->a->Bool) -> [a] -> [a]+uniqBy eq [] = []+uniqBy eq (x:xs) = case span (eq x) xs of (_,ns) -> x : uniqBy eq ns+++-- | reserveTVars takes the number of requested tvIDs, reserves consecutive tvIDs, and returns the first tvID. +reserveTVars :: Monad m => Int -> PriorSubsts m Int+reserveTVars n = PS (\s i -> return (i,s,i+n))+{- ¤³¤Ã¤Á¤ÎÄêµÁ¤Ë¤·¤¿¤é°¤Êò¤ß¤¿¤¤¤Ë»þ´Ö¤ò¿©¤Ã¤¿¡¥Ìõ¥ï¥«¥á+reserveTVars n = do i <- getMx+ updateMx (n+)+ return i+-}+++{-+flatten :: PriorSubsts [a] -> PriorSubsts a+flatten (PS sbb) = PS (\s i -> map cat $ unMx (sbb s i))+cat :: Bag ([a], Subst, Int) -> Bag (a, Subst, Int)+cat xs = [ (y, s, i) | (ys, s, i) <- xs, y <- ys ]+-}+\end{code}
+ MagicHaskeller/ProgGen.lhs view
@@ -0,0 +1,175 @@+-- +-- (c) Susumu Katayama 2009+--+\begin{code}+{-# OPTIONS -cpp -fglasgow-exts #-}+module MagicHaskeller.ProgGen(ProgGen(PG)) where++import MagicHaskeller.Types+import MagicHaskeller.TyConLib+import Control.Monad+import Data.Monoid+import MagicHaskeller.CoreLang+import Control.Monad.Search.Combinatorial+import MagicHaskeller.PriorSubsts+import Data.List(partition, sortBy)+import Data.Ix(inRange)++import MagicHaskeller.ProgramGenerator++import MagicHaskeller.Classify+import System.Random(mkStdGen)+import MagicHaskeller.Instantiate++import MagicHaskeller.Expression++import MagicHaskeller.T10+import qualified Data.Map as Map++import MagicHaskeller.DebMT++import Debug.Trace++import Data.Monoid+++-- x #define DESTRUCTIVE+traceTy _ = id+-- traceTy fty = trace ("lookup "++ show fty)+++type BF = Recomp+-- type BF = DBound++type BFM = Matrix+-- type BFM = DBMemo+fromMemo :: Search m => Matrix a -> m a+fromMemo = fromMx+toMemo :: Search m => m a -> Matrix a+toMemo = toMx+++-- Memoization table, created from primitive components++-- | The vanilla program generator corresponding to Version 0.7.*+newtype ProgGen = PG (MemoDeb CoreExpr) -- ^ internal data representation+++mapStrTyCon :: MemoDeb CoreExpr -> Map.Map String TyCon+mapStrTyCon = fst . extractTCL . PG++#ifdef DESTRUCTIVE+type MemoTrie a = (MapType (BFM (Possibility a)), MapType (BFM (Possibility a)))+#else+type MemoTrie a = MapType (BFM (Possibility a))+#endif++#ifdef DESTRUCTIVE+lmt (mt,_) fty =+#else+lmt mt fty =+#endif+ traceTy fty $+ lookupMT mt fty++lookupFunsPoly :: (Search m, Expression e) => Generator m e -> Generator m e+lookupFunsPoly behalf memodeb@(memodepth,(mt,_,_)) avail reqret+ = PS (\subst mx ->+ let (tn, decoder) = encode (popArgs avail reqret) mx+ in ifDepth (<= memodepth)+ (fmap (\ (exprs, sub, m) -> (exprs, retrieve decoder sub `plusSubst` subst, mx+m)) $ fromMemo $ lmt mt tn)+ (unPS (behalf memodeb avail reqret) subst mx) )++instance ProgramGenerator ProgGen where+ mkTrie cmn tces = PG (mkTrieMD cmn tces)+ unifyingPrograms ty (dep, px@(PG x)) = fmap (toAnnExpr $ reducer px) $ catBags $ fmap (\ (es,_,_) -> es) $ unifyingPossibilities ty (dep, x)+ extractCommon (PG (_,_,cmn)) = cmn++unifyingPossibilities :: Search m => Type -> (Int, MemoDeb CoreExpr) -> m ([CoreExpr],Subst,Int)+unifyingPossibilities ty memodeb = unPS (mguProgs memodeb [] ty) emptySubst 0++type MemoDeb a = (MemoTrie a, ([Prim],[Prim]), Common)+-- TyConLib¤Ï[Typed [CoreExpr]]¤«¤é¼«Á°¤Çºî¤ë¤Ù¤¡¥¾ì¹ç¤Ë¤è¤Ã¤Æ¤ÏLinsCCL¤È¤«¤ÈTyConLib¤ò¶¦Í¤Ç¤¤Ê¤¯¤Ê¤ë¤«¤âÃΤì¤Ê¤¤¤±¤É¡¤¤½¤ì¤Ï¤½¤ì¤ÇOK¡¥¤«¡© ¤ä¤Ã¤Ñ¼«Á°¤Çºî¤ë¤Î¤ÏLIBRARY¤Î¥±¡¼¥¹¤Î¤ß¤Ë¤·¤Æ¤ª¤¯¤«¡¥+-- ¤¢¡¤¤Æ¤æ¡¼¤«¡¤[Typed [CoreExpr]]¤òºî¤ë¤Î¤ËTyConLib¤¬É¬Íס¥+-- ¤à¤·¤í¡¤[([CoreExpr],TypeRep)]¤«¤éTyConLib¤È[Typed [CoreExpr]]¤òºî¤ë´¶¤¸¤Ç¡¥++ -- maxBound»È¤¦¤È¿ʬ¸úΨ°¤¤¤±¤É¡¤¤Þ¤¢ÌÌÅݤÀ¤·¤¤¤¤¤«¡¥+mkTrieMD :: Common -> [Typed [CoreExpr]] -> MemoDeb CoreExpr+mkTrieMD cmn txs+ = let+ memoDeb = (memoTrie, qtl, cmn)+ -- memoTrie :: MemoTrie a+-- monomorphic¤Ê¤Î¤Î¤ß¤òmemo¤·¤¿¤¤»þ¤Ï¡¤MemoMT.fps/freezePS¤ò»È¤¦¤Ù¤·¡¥+#ifdef DESTRUCTIVE+ memoTrie = (allTrie,listrie)+ listrie = mkMT (tcl cmn) (\ty -> freezePS ty (let (avail,t) = splitArgs ty in mguFuns (maxBound, (opt, (listrie, listrie), (fst qtl,[]), tcl cmn, rt cmn)) avail t :: PriorSubsts BF [CoreExpr]))+ allTrie = mkMT (tcl cmn) (\ty -> freezePS ty (let (avail,t) = splitArgs ty in mguFuns (maxBound, memoDeb) avail t :: PriorSubsts BF [CoreExpr]))+#else+ memoTrie = mkMT (tcl cmn) (\ty -> freezePS ty (let (avail,t) = splitArgs ty in mguFuns (maxBound, memoDeb) avail t :: PriorSubsts BF [CoreExpr]))+#endif+-- We need to specialize the type (to BF) in order to avoid ambiguity.+ in memoDeb+ where qtl = splitPrims txs+++-- moved from DebMT.lhs to avoid cyclic modules.+freezePS :: Search m => Type -> PriorSubsts m (Bag e) -> BFM (Possibility e)+freezePS ty ps+ = let mxty = maxVarID ty -- `max` maximum (map maxVarID avail)+ in toMemo $ mergesortDepthWithBy (\(xs,k,i) (ys,_,_) -> (xs `mappend` ys, k, i)) (\(_,k,_) (_,l,_) -> k `compare` l) $ fps mxty ps+fps :: Search m => Int -> PriorSubsts m es -> m (es,[(Int, Type)],Int)+fps mxty (PS f) = do (exprs, sub, m) <- f emptySubst (mxty+1)+ return (exprs, filterSubst sub mxty, m)+ where filterSubst :: Subst -> Int -> [(Int, Type)]+ filterSubst sub mx = [ t | t@(i,_) <- sub, inRange (0,mx) i ] -- note that the assoc list is NOT sorted.++-- avail¤Ë¤·¤íType¤Ë¤·¤íapply¤µ¤ì¤Æ¤¤¤ë¡¥+-- ¤À¤«¤é¤³¤½¡¤runAnotherPSŪ¤ËemptySubst¤ËÂФ·¤Æ¼Â¹Ô¤·¤¿Êý¤¬¸úΨŪ¤Ê¤Ï¤º¡© ¤Ç¤â¡¤Substitution¤Ã¤Æ¤½¤ó¤Ê¤Ë¤Ç¤«¤¯¤Ê¤é¤Ê¤«¤Ã¤¿¤Î¤Ç¤Ï¡©FiniteMap¤Ç¤âassoc list¤Ç¤âÊѤï¤é¤Ê¤«¤Ã¤¿µ¤¤¬¡¥++type Generator m e = (Int,MemoDeb e) -> [Type] -> Type -> PriorSubsts m [e]++++mguPrograms, mguProgs, mguFuns :: Search m => Generator m CoreExpr++mguPrograms memodeb = applyDo (mguProgs memodeb)++mguProgs memodeb = wind (>>= (return . fmap Lambda)) (\avail reqret -> reorganize (\newavail -> lookupFunsPoly mguFuns memodeb newavail reqret) avail)+{- ¤É¤Ã¤Á¤¬¤ï¤«¤ê¤ä¤¹¤¤¤«¤ÏÉÔÌÀ+mguProgs memodeb avail (t0:->t1) = do result <- mguProgs memodeb (t0 : avail) t1+ return (fmap Lambda result)+mguProgs memodeb avail reqret = reorganize (\newavail -> lookupFunsPoly mguFuns memodeb newavail reqret) avail+-}++mguFuns memodeb = generateFuns mguPrograms memodeb++-- MemoDeb¤Î·¿¤¬°ã¤¦¤È»È¤¨¤Ê¤¤¡¥+generateFuns :: (Search m) =>+ Generator m CoreExpr -- ^ recursive call+ -> Generator m CoreExpr+generateFuns rec memodeb@(_, md@(_, (primgen,primmono),cmn)) avail reqret+ = let behalf = rec memodeb avail+ lltbehalf = lookupListrie (opt cmn) rec memodeb avail -- heuristic filtration+ lenavails = length avail+ fe :: Type -> Type -> [CoreExpr] -> [CoreExpr] -- ^ heuristic filtration+ fe = filtExprs (guess $ opt cmn)+ rg = if tv0 $ opt cmn then retGenTV0 else+ if tv1 $ opt cmn then retGenTV1 else retGen+ in fromAssumptions (PG md) lenavails behalf mguPS reqret avail `mplus` msum (map (rg (PG md) lenavails fe lltbehalf behalf reqret) primgen ++ map (retPrimMono (PG md) lenavails lltbehalf behalf mguPS reqret) primmono )++#ifdef DESTRUCTIVE+lookupListrie rec (memodepth, (trie, (primgen,_),tcl,rtrie)) avail t = rec (memodepth,((snd trie, snd trie), (primgen,[]), tcl, rtrie)) avail t+filtExprs = filterExprs+#else+lookupListrie opt rec memodeb avail t+ | constrL opt = mguAssumptions t avail+ | guess opt = do args <- rec memodeb avail t+ let args' = filter (not.isClosed.toCE) args+ when (null args') mzero+ return args'+ | otherwise = rec memodeb avail t+filtExprs g a b | g = filterExprs a b+ | otherwise = id+#endif++\end{code}
+ MagicHaskeller/ProgGenSF.lhs view
@@ -0,0 +1,349 @@+-- +-- (c) Susumu Katayama 2009+--++\begin{code}+{-# OPTIONS -fglasgow-exts -cpp #-}+module MagicHaskeller.ProgGenSF(ProgGenSF, PGSF) where+import MagicHaskeller.Types+import MagicHaskeller.TyConLib+import Control.Monad+import MagicHaskeller.CoreLang+import Control.Monad.Search.Combinatorial+import MagicHaskeller.PriorSubsts+import Data.List(partition, sortBy, sort, nub, (\\))+import Data.Ix(inRange)++import MagicHaskeller.ClassifyDM+import MagicHaskeller.Classify(diffSortedBy)++import System.Random(mkStdGen, StdGen)+import MagicHaskeller.Instantiate++import MagicHaskeller.ProgramGenerator++import MagicHaskeller.Expression++++import MagicHaskeller.T10(mergesortWithBy)++import MagicHaskeller.DebMT++import Debug.Trace+-- trace str = id++reorganize_ = reorganizer_+-- reorganize_ = id++classify = True+traceExpTy _ = id+-- traceExpTy fty = trace ("lookupexp "++ show fty)+traceTy _ = id+-- traceTy fty = trace ("lookup "++ show fty)++-- Memoization table, created from primitive components+type ProgGenSF = PGSF AnnExpr+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).+-- The idea is to apply random numbers to the generated expressions, compute the quotient set of the resulting values at each depth of the search tree, and adopt the complete system of representatives for the depth and push the remaining expressions to one step deeper in the search tree.+-- (Thus, adoption of expressions that may be equivalent to another already-generated-expression will be postponed until their \"uniqueness\" is proved.)+-- As a result, (unlike "ProgGen",) expressions with size N may not appear at depth N but some deeper place.+--+-- "ProgGenSF" is more efficient along with a middle-sized primitive set (like @reallyall@ found in LibTH.hs),+-- but is slower than "ProgGen" for a small-sized one.+--+-- Also note that "ProgGenSF" depends on hard use of unsafe* stuff, so if there is a bug, it may segfault....++type ExpTip e = Matrix e++type ExpTrie e = MapType (ExpTip e)+type TypeTrie e = MapType (Matrix (ExpTip e, Subst, Int))++type MemoTrie e = (TypeTrie e, ExpTrie e)++lmt :: Expression e => (Int, MemoDeb e) -> Type -> Matrix e+lmt (_,memoDeb@((_,mt),_,cmn)) fty = traceExpTy fty $+ lookupMT mt fty -- ¤³¤Ã¤Á¤À¤Èlookup+-- filtBF cmn fty $ matchFunctions (maxBound', memoDeb) fty -- ¤³¤Ã¤Á¤À¤Èrecompute++-- 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) $+ uniqSorter (g d)))+ | otherwise = toMx . mapDepthDB uniqSorter+fDM = filterDM -- ¤³¤Ã¤Á¤¬½¾Íè+-- fDM = filterDMlite -- depth bound(¤Ä¤Þ¤ê¡¤Int->[(a,Int)]¤Ë¤ª¤±¤ë°ú¿ô¤ÎInt)¤ÎÂå¤ï¤ê¤Ë¡¤depth bound¤«¤é¤Îµ÷Î¥(¤Ä¤Þ¤ê¡¤Int->[(a,Int)]¤Ë¤ª¤±¤ëInt->[(a,¤³¤³¤ÎInt)])¤ò»È¤Ã¤Ænrnds¤Î²¿ÈÖÌܤ«¤ò·è¤á¤ë¤â¤Î¡¥+ -- filterDM¤È°ã¤Ã¤Æ¡¤Æ±¤¸depth bound¤Ç¤â°ã¤¦Íð¿ô¤ò»È¤¦¤Î¤Ç¡¤filterListƱÍÍdepth¤ò¸Ù¤¤¤Àfiltration¤¬¤Ç¤¤º¡¤·ë²Ì¤Ï¤¤¤Þ¤¤¤Á¡¥+ -- ¤¿¤À¤·¡¤dynamic¤Ê´Ø¿ô¼«ÂΤò¥á¥â²½¤¹¤ì¤Ð¡¤³ÊÃʤ˥á¥â¤Ë¥Ò¥Ã¥È¤·¤ä¤¹¤¯¤Ê¤ë¤Ï¤º¡¥++lmtty mt fty = traceTy fty $+ lookupMT mt fty++--memocond i = 3<i+-- memocond i = i<10+memocond i = True++-- memocond ty = size ty < 10 -- popArgs avail t¤·¤Æ¤«¤é¤ä¤ë¤Î¤Ï¤Á¤ç¤Ã¤È̵ÂÌ¡¥¤È»×¤Ã¤¿¤±¤É¡¤¼ÂºÝ¤Ï´Ø·¸¤Ê¤¤¤ß¤¿¤¤¡¥+-- memocond av ty = size ty + sum (map size av) < 10+++instance Expression e => ProgramGenerator (PGSF e) where+ mkTrieOpt cmn tcesopt tces = PGSF (mkTrieOptSF cmn tcesopt tces)+ matchingPrograms ty (dep, PGSF x) = fromMx $ matchProgs (dep, x) ty+ unifyingPrograms ty (dep, px@(PGSF x)) = catBags $ fromDB $ fmap (\ (es,_,_) -> map (toAnnExpr $ reducer px) es) $ unifyingPossibilities ty (dep, x)+ extractCommon (PGSF (_,_,cmn)) = cmn++unifyingPossibilities ty memodeb = unPS (unifyableExprs memodeb [] ty) emptySubst 0++-- quantify¤µ¤ì¤¿¤ä¤Ä¤¬memoize¤µ¤ì¤Æ¤¤¤ëÌõ¤À¤«¤é¡¤query¤Îentry¤Ç¤Ïquantify¤¹¤ëɬÍפϤʤ¤+-- entry for query+-- ¤Æ¤æ¡¼¤«¡¤quantify¤·¤Á¤ã¤¦¤Ê¤éMemoDeb.mguPrograms¤«¤Ê¤ó¤«¤½¤Î¤Þ¤Þ»È¤¨¤Ð¤¤¤¤¤Ã¤ÆÏä⤢¤ë¡¥¤Þ¤¢¡¤recursive¤Ë¤Ï¾åµ¤ÎunifyableExprs¤ò¸Æ¤Ð¤Ê¤¤ã¥À¥á¤À¤±¤É¡¥+-- ¤Ê¤ª¡¤¸·Ì©¤Ê°ÕÌ£¤Çmatch¤Ë¤¹¤ë¤Ë¤Ï¤É¤¦¤âquantify¤ÏɬÍפäݤ¤¡¥+--matchProgs :: (Int, Memo) -> Type -> BF AnnExpr+matchProgs :: Expression e => (Int,MemoDeb e) -> Type -> Matrix AnnExpr+matchProgs memodeb ty = fmap (toAnnExprWindWind (reducer $ PGSF $ snd memodeb) ty) $ lmt memodeb $ normalize $ unquantify ty -- ¤³¤Ã¤Á¤À¤Èlookup+{-+matchProgs memodeb ty = fmap toAnnExpr $ wind (fmap (mapCE Lambda)) (lookupFuns memodeb) [] (quantify ty) -- ¤³¤Ã¤Á¤À¤Èrecompute ¤È¤¤¤¦¤È¸ìÊÀ¤¬¤¢¤ë¡¥recompute¤·¤¿¤¤ãlmt¤Î¤È¤³¤í¤òÊѤ¨¤ë¤Ù¤·¡¥++-- matchProgs¤Î¤ß¤Î²¼ÀÁ¤±¡¤matchFuns¤È¸ò´¹²Äǽ+lookupFuns :: (Expression e, Ord e) => (Int, MemoDeb e) -> [Type] -> Type -> BF e+lookupFuns memodeb@(memodepth,((_,mt),_,tcl,rtrie)) avail reqret =+{-+#ifdef CLASSIFY+ fmap fromAnnExpr $ toRc $ filterDM tcl rtrie ty $ fromRc $ fmap (toAnnExprWind ty) $+#endif+-}+-- mapDepth uniqSort $+ matchFuns memodeb avail reqret+ where ty = popArgs avail reqret+-}++specializedPossibleTypes :: Expression e => Type -> (Int, MemoDeb e) -> Recomp Type+specializedPossibleTypes ty memodeb = runPS (fmap (\(av,t) -> popArgs av t) $ specializedTypes memodeb [] ty)+-- specializedPossibleTypes ty memodeb@(_,((mt,_),_,_,_)) = fmap (\(_,s,_) -> apply s ty) $ toRc $ lmtty mt ty+++type MemoDeb e = (MemoTrie e, (([Prim],[Prim]),([Prim],[Prim])), Common)+-- TyConLib¤Ï[Typed [CoreExpr]]¤«¤é¼«Á°¤Çºî¤ë¤Ù¤¡¥¾ì¹ç¤Ë¤è¤Ã¤Æ¤ÏLinsCCL¤È¤«¤ÈTyConLib¤ò¶¦Í¤Ç¤¤Ê¤¯¤Ê¤ë¤«¤âÃΤì¤Ê¤¤¤±¤É¡¤¤½¤ì¤Ï¤½¤ì¤ÇOK¡¥¤«¡© ¤ä¤Ã¤Ñ¼«Á°¤Çºî¤ë¤Î¤ÏLIBRARY¤Î¥±¡¼¥¹¤Î¤ß¤Ë¤·¤Æ¤ª¤¯¤«¡¥+-- ¤¢¡¤¤Æ¤æ¡¼¤«¡¤[Typed [CoreExpr]]¤òºî¤ë¤Î¤ËTyConLib¤¬É¬Íס¥+-- ¤à¤·¤í¡¤[([CoreExpr],TypeRep)]¤«¤éTyConLib¤È[Typed [CoreExpr]]¤òºî¤ë´¶¤¸¤Ç¡¥++ -- maxBound»È¤¦¤È¿ʬ¸úΨ°¤¤¤±¤É¡¤¤Þ¤¢ÌÌÅݤÀ¤·¤¤¤¤¤«¡¥+maxBound' = maxBound -- Setting this to some small value can sometimes be helpful when seeing the heap behavior.+mkTrieOptSF :: Expression e => Common -> [Typed [CoreExpr]] -> [Typed [CoreExpr]] -> MemoDeb e+mkTrieOptSF cmn txsopt txs+ = let+ memoDeb = (memoTrie, (qtlopt,qtl), cmn)+ -- memoTrie :: MemoTrie+ memoTrie = (typeTrie,expTrie)+ typeTrie = mkMTty (tcl cmn) (\ty -> freezePS ty (specTypes (maxBound', memoDeb) ty))+ expTrie = mkMTexp (tcl cmn) (\ty -> filtBF cmn ty $ matchFunctions (maxBound', memoDeb) ty)+ in memoDeb+ where qtlopt = splitPrims txsopt+ qtl = splitPrims txs+dbToCumulativeMx :: (Ord a) => DBound a -> Matrix a+-- 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++mondepth = zipDepthRc (\d xs -> trace ("depth="++show d++", and the length is "++show (length xs)) xs) -- depth¤Èɽ¼¨¤¹¤ë¤Ê¤é+1¤¹¤ë¤Ù¤¤Ç¤¢¤Ã¤¿¡¥(0¤«¤é»Ï¤Þ¤ë¤Î¤Ç)+++type BFT = Recomp+unBFM = unMx+++{-+freezePS :: (Search m, Expression e) => Type -> PriorSubsts m (ExpTip e) -> Matrix (ExpTip e,Subst,Int)+freezePS ty ps+ = 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 (ExpTip e,Subst,Int)+freezePS ty ps+ = let mxty = maxVarID ty -- `max` maximum (map maxVarID avail)+ 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)])+tokoro10 :: (Eq k, Ord k) => [(a,k,i)] -> [(a,k,i)]+tokoro10 = mergesortWithBy const (\ (_,k,_) (_,l,_) -> k `compare` l)++-- tokoro10fstfst = mergesortWithBy const (\ ((k,_),_,_) ((l,_),_,_) -> k `compare` l)++tokoro10ap :: Type -> [(a,Subst,i)] -> [(a,Subst,i)]+tokoro10ap ty = mergesortWithBy const (\ (_,k,_) (_,l,_) -> normalize (apply k ty) `compare` normalize (apply l ty))++-- avail¤Ë¤·¤íType¤Ë¤·¤íapply¤µ¤ì¤Æ¤¤¤ë¡¥+-- ¤À¤«¤é¤³¤½¡¤runAnotherPSŪ¤ËemptySubst¤ËÂФ·¤Æ¼Â¹Ô¤·¤¿Êý¤¬¸úΨŪ¤Ê¤Ï¤º¡© ¤Ç¤â¡¤Substitution¤Ã¤Æ¤½¤ó¤Ê¤Ë¤Ç¤«¤¯¤Ê¤é¤Ê¤«¤Ã¤¿¤Î¤Ç¤Ï¡©FiniteMap¤Ç¤âassoc list¤Ç¤âÊѤï¤é¤Ê¤«¤Ã¤¿µ¤¤¬¡¥+++specializedTypes :: (Search m, Expression e) => (Int, MemoDeb e) -> [Type] -> Type -> PriorSubsts m ([Type],Type)+specializedTypes memodeb avail t = do specializedCases memodeb avail t+ subst <- getSubst+ return (map (apply subst) avail, apply subst t)+-- specializedCases is the same as unifyableExprs, except that the latter returns PriorSubsts BF [CoreExpr], and that the latter considers memodepth.+specializedCases, specCases, specCases' :: (Search m, Expression e) => (Int, MemoDeb e) -> [Type] -> Type -> PriorSubsts m ()+specializedCases memodeb = applyDo (specCases memodeb)+specCases (_,memodeb) = wind_ (\avail reqret -> reorganize_ (\newavail -> uniExprs_ (maxBound',memodeb) newavail reqret) avail)+{- ¤É¤Ã¤Á¤¬¤ï¤«¤ê¤ä¤¹¤¤¤«¤ÏÉÔÌÀ+specCases memodeb avail (t0:->t1) = specCases memodeb (t0 : avail) t1+specCases (_,memodeb) avail reqret = reorganize_ (\newavail -> uniExprs_ (maxBound',memodeb) newavail reqret) avail+-}++++++uniExprs_ :: (Search m, Expression e) => (Int, MemoDeb e) -> [Type] -> Type -> PriorSubsts m ()+uniExprs_ memodeb avail t+ = convertPS fromRc $ psListToPSRecomp lfp+ where lfp depth+ | memocond depth = lookupUniExprs memodeb avail t depth >> return ()+ | otherwise = makeUniExprs memodeb avail t depth >> return ()++lookupUniExprs :: Expression e => (Int, MemoDeb e) -> [Type] -> Type -> Int -> PriorSubsts [] (ExpTip e)+lookupUniExprs memodeb@(_,((mt,_),_,_)) avail t depth+ = lookupNormalized (\tn -> unMx (lmtty mt tn) !! depth) avail t++makeUniExprs :: Expression e => (Int, MemoDeb e) -> [Type] -> Type -> Int -> PriorSubsts [] Type+makeUniExprs memodeb avail t depth+ = convertPS tokoro10fst $+ do psRecompToPSList (reorganize_ (\av -> specCases' memodeb av t) avail) depth+ sub <- getSubst+ return $ quantify (apply sub $ popArgs avail t)++{-+makeUniExprs_ memodeb@(_,(_, _, tcl, rtrie)) avail t depth+ = t10PS (popArgs avail t) $ psRecompToPSList (specCases' memodeb avail t) depth+t10PS :: Type -> PriorSubsts [] a -> PriorSubsts [] ()+t10PS ty ps+ = do convertPS tokoro10fst $+ do ps+ sub <- getSubst+ return (apply sub ty)+ return ()+-- ¤³¤³¤Ç¤ÏƱ¤¸·¿¤Ë¤Ê¤ë¤â¤Î¤ò¤Þ¤È¤á¤Æ¤¤¤ëÌõ¤À¤¬¡¤+-- - ¤³¤³¤Ç¤Þ¤È¤á¤¿Êý¤¬Â®¤¤¤Î¤«¡¤¤½¤ó¤Ê¤³¤È¤ò¤»¤º¤Ëñ¤ËpsRecompToPSList (specCases' memodeb avail t) depth¤ò»È¤¦Êý¤¬Â®¤¤¤Î¤«+-- - typetrie¤Ëmemoize¤¹¤ë¤È¤¤â¤Á¤ã¤ó¤È¤Þ¤È¤á¤Æ¤¤¤ë¤Î¤«¡¤+-- Ä´¤Ù¤ë¤Ù¤·¡¥Æäˡ¤typetrie¤Ç¤Þ¤È¤á¤Æ¤¤¤Ê¤¤¤«¤é¥Ò¡¼¥×¤¬Áý¤¨¤Æ¤¤¤ë¤Î¤«¤â¡¥+-}++-- entry point for memoization+specTypes :: (Search m, Expression e) => (Int, MemoDeb e) -> Type -> PriorSubsts m (ExpTip e)+specTypes memodeb@(_,((_,mt),_,_)) ty+ = do let (avail,t) = splitArgs ty+ reorganize_ (\av -> specCases' memodeb av t) avail+-- quantify¤ÏmemoÀè¤Ç´û¤Ë¤ä¤é¤ì¤Æ¤¤¤ë¤Î¤ÇÉÔÍ×+ typ <- applyPS ty+ return (lmt memodeb $ normalize $ unquantify typ)+++funApSub_ :: Search m => (Type -> PriorSubsts m ()) -> (Type -> PriorSubsts m ()) -> Type -> PriorSubsts m ()+funApSub_ lltbehalf behalf (t:>ts) = do lltbehalf t+ funApSub_ lltbehalf behalf ts+funApSub_ lltbehalf behalf (t:->ts) = do behalf t+ funApSub_ lltbehalf behalf ts+funApSub_ lltbehalf behalf _t = return ()++funApSub_spec behalf = funApSub_ behalf behalf++-- 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)+ where fas | constrL $ opt cmn = funApSub_ lltbehalf behalf+ | otherwise = funApSub_spec behalf+ where behalf = specializedCases memodeb avail+ lltbehalf = flip mguAssumptions_ avail+ -- retPrimMono :: (Int, Type, Int, Typed [CoreExpr]) -> PriorSubsts BFT ()+ retPrimMono (arity, retty, numtvs, _xs:::ty)+ = napply arity delayPS $+ do tvid <- reserveTVars numtvs+ mguPS reqret (mapTV (tvid+) retty)+ fas (mapTV (tvid+) ty)+ -- retMono :: Type -> PriorSubsts BFT ()+ retMono ty = napply (getArity ty) delayPS $+ do mguPS reqret (getRet ty)+ fas ty+ -- retGen :: (Int, Type, Int, Typed [CoreExpr]) -> PriorSubsts BFT ()+ retGen (arity, _r, numtvs, _s:::ty) = napply arity delayPS $+ do tvid <- reserveTVars numtvs -- ¤³¤Î¡ÊºÇ½é¤Î¡ËID¤½¤Î¤â¤Î¡Ê¤Ä¤Þ¤êÊÖ¤êÃͤÎtvID¡Ë¤Ï¤¹¤°¤Ë»È¤ï¤ì¤Ê¤¯¤Ê¤ë+ -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTV¤Èapply¤Ïhylo-fusion¤Ç¤¤ë¤Ï¤º¤À¤¬¡¤¾¡¼ê¤Ë¤µ¤ì¤ë¡©+ -- -- unitSubst¤òinline¤Ë¤·¤Ê¤¤¤ÈÂÌÌܤ«+ mkSubsts tvid reqret+ fas (mapTV (tvid+) ty)++ gentvar <- applyPS (TV tvid)++ guard (orderedAndUsedArgs gentvar)+ fas gentvar++type Generator m e = (Int,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)))+++lookupTypeTrie :: Expression e => (Int, MemoDeb e) -> Type -> Recomp ([e], Subst, Int)+lookupTypeTrie memodeb@(_, ((mt,_), _, _)) t+ = Rc $ + \depth -> let Mx xss = lmtty mt t+ in [ (yss!!depth, s, i) | (Mx yss, s, i) <- xss !! depth ]+++lookupNormalized :: MonadPlus m => (Type -> m (e, Subst, Int)) -> [Type] -> Type -> PriorSubsts m e+lookupNormalized fun avail t+ = do mx <- getMx+ let typ = popArgs avail t+ (tn, decoder) = encode typ mx+ (es, sub, m) <- mkPS (fun tn)+ updatePS (retrieve decoder sub)+ updateMx (m+)+ return es++tokoro10fst :: (Eq k, Ord k) => [(k,s,i)] -> [(k,s,i)]+tokoro10fst = mergesortWithBy const (\ (k,_,_) (l,_,_) -> k `compare` l)++-- entry for memoization+matchFunctions :: Expression e => (Int, MemoDeb e) -> Type -> DBound e+matchFunctions memodeb ty = case splitArgs (quantify ty) of (avail,t) -> matchFuns memodeb avail t++matchFuns :: Expression e => (Int,MemoDeb e) -> [Type] -> Type -> DBound e+matchFuns memodeb avail reqret = catBags $ runPS (matchFuns' unifyableExprs memodeb avail reqret)++matchFuns' :: (Search m, Expression e) => Generator m e -> Generator m e+-- matchFuns' = generateFuns matchPS filtExprs lookupListrie -- MemoDeb¤Î·¿¤Î°ã¤¤¤Ç¤³¤ì¤Ï¤¦¤Þ¤¯¤¤¤«¤Ê¤ó¤À¡¥+matchFuns' rec memodeb@(_, md@(_, (_,(primgen,primmono)),cmn)) avail reqret+ = let behalf = rec memodeb avail+ lltbehalf = lookupListrie lenavails rec memodeb avail -- heuristic filtration+ 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)++lookupListrie :: (Search m, Expression e) => Int -> Generator m e -> Generator m e+lookupListrie lenavails rec memodeb@(_,md@(_,_,cmn)) avail t+ | constrL opts = matchAssumptions (PGSF md) lenavails t avail+ | guess opts = do+ args <- rec memodeb avail t+ let args' = filter (not.isClosed.toCE) args+ when (null args') mzero+ return args'+ | otherwise = rec memodeb avail t+ where opts = opt cmn+filtExprs :: Expression e => Bool -> Type -> Type -> [e] -> [e]+filtExprs g a b | g = filterExprs a b+ | otherwise = id++\end{code}
+ MagicHaskeller/ProgGenXF.lhs view
@@ -0,0 +1,343 @@+-- +-- (c) Susumu Katayama 2009+--++\begin{code}+{-# OPTIONS -fglasgow-exts -cpp #-}+module MagicHaskeller.ProgGenXF(ProgGenXF) where+import MagicHaskeller.Types+import MagicHaskeller.TyConLib+import Control.Monad+import MagicHaskeller.CoreLang+import Control.Monad.Search.Combinatorial+import MagicHaskeller.PriorSubsts+import Data.List(partition, sortBy, sort, nub, (\\))+import Data.Ix(inRange)++import MagicHaskeller.ClassifyDM++import System.Random(mkStdGen, StdGen)+import MagicHaskeller.Instantiate++import MagicHaskeller.ProgramGenerator++import MagicHaskeller.Expression++import MagicHaskeller.ClassifyTr+import MagicHaskeller.MyDynamic++import MagicHaskeller.T10(mergesortWithBy)++import MagicHaskeller.DebMT++import Debug.Trace+-- trace str = id++reorganize_ = reorganizer_+-- reorganize_ = id++classify = True+traceExpTy _ = id+-- traceExpTy fty = trace ("lookupexp "++ show fty)+traceTy _ = id+-- traceTy fty = trace ("lookup "++ show fty)++-- Memoization table, created from primitive components+newtype ProgGenXF = PGXF MemoDeb -- internal data representation.+-- ^ Program generator with experimental leveraged filtration, experimental variant of ProgGenSF. The following is explanation of ProgGenSF.+-- 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).+-- The idea is to apply random numbers to the generated expressions, compute the quotient set of the resulting values at each depth of the search tree, and adopt the complete system of representatives for the depth and push the remaining expressions to one step deeper in the search tree.+-- (Thus, adoption of expressions that may be equivalent to another already-generated-expression will be postponed until their \"uniqueness\" is proved.)+-- As a result, (unlike "ProgGen",) expressions with size N may not appear at depth N but some deeper place.+--+-- "ProgGenSF" is more efficient along with a middle-sized primitive set (like @reallyall@ found in LibTH.hs),+-- but is slower than "ProgGen" for a small-sized one.+--+-- Also note that "ProgGenSF" depends on hard use of unsafe* stuff, so if there is a bug, it may segfault....++type ExpTip = (Stream (Forest ([Dynamic], AnnExpr)), Stream (Forest ([Dynamic], AnnExpr)), Matrix AnnExpr)++type ExpTrie = MapType ExpTip+type TypeTrie = MapType (Matrix (Matrix AnnExpr, Subst, Int))++type MemoTrie = (TypeTrie, ExpTrie)+++lmt :: (Int, MemoDeb) -> Type -> Matrix AnnExpr+lmt (_,memoDeb@((_,mt),_,cmn)) fty =+ let (_,_,x) = traceExpTy fty $+ lookupMT mt fty -- ¤³¤Ã¤Á¤À¤Èlookup+-- filtBF cmn fty $ matchFunctions (maxBound', memoDeb) fty -- ¤³¤Ã¤Á¤À¤Èrecompute+ in x+-- filtBF ty = fmap fromAnnExpr . filterBF tcl rtrie ty . fmap (toAnnExprWind (execute opt) ty) . tabulate+filtBF cmn ty | classify = filterTr cmn ty . fmap (toAnnExprWind (execute (opt cmn) (vl cmn)) ty) -- . mapDepth aUS+ | otherwise = \bf -> (undefined, undefined, toMx $ mapDepth aUS bf)++lmtty mt fty = traceTy fty $+ lookupMT mt fty++--memocond i = 3<i+-- memocond i = i<10+memocond i = True++-- memocond ty = size ty < 10 -- popArgs avail t¤·¤Æ¤«¤é¤ä¤ë¤Î¤Ï¤Á¤ç¤Ã¤È̵ÂÌ¡¥¤È»×¤Ã¤¿¤±¤É¡¤¼ÂºÝ¤Ï´Ø·¸¤Ê¤¤¤ß¤¿¤¤¡¥+-- memocond av ty = size ty + sum (map size av) < 10+++instance ProgramGenerator ProgGenXF where+ mkTrieOpt cmn tcesopt tces = PGXF (mkTrieOptSF cmn tcesopt tces)+ matchingPrograms ty (dep, PGXF x) = fromMx $ matchProgs (dep, x) ty+ unifyingPrograms ty (dep, px@(PGXF x)) = fromRc $ catBags $ fmap (\ (es,_,_) -> map (toAnnExpr $ reducer px) es) $ unifyingPossibilities ty (dep, x)+ extractCommon (PGXF (_,_,cmn)) = cmn++unifyingPossibilities ty memodeb = unPS (unifyableExprs memodeb [] ty) emptySubst 0++-- quantify¤µ¤ì¤¿¤ä¤Ä¤¬memoize¤µ¤ì¤Æ¤¤¤ëÌõ¤À¤«¤é¡¤query¤Îentry¤Ç¤Ïquantify¤¹¤ëɬÍפϤʤ¤+-- entry for query+-- ¤Æ¤æ¡¼¤«¡¤quantify¤·¤Á¤ã¤¦¤Ê¤éMemoDeb.mguPrograms¤«¤Ê¤ó¤«¤½¤Î¤Þ¤Þ»È¤¨¤Ð¤¤¤¤¤Ã¤ÆÏä⤢¤ë¡¥¤Þ¤¢¡¤recursive¤Ë¤Ï¾åµ¤ÎunifyableExprs¤ò¸Æ¤Ð¤Ê¤¤ã¥À¥á¤À¤±¤É¡¥+-- ¤Ê¤ª¡¤¸·Ì©¤Ê°ÕÌ£¤Çmatch¤Ë¤¹¤ë¤Ë¤Ï¤É¤¦¤âquantify¤ÏɬÍפäݤ¤¡¥+--matchProgs :: (Int, Memo) -> Type -> BF AnnExpr+matchProgs :: (Int,MemoDeb) -> Type -> Matrix AnnExpr+matchProgs memodeb ty = fmap (toAnnExprWindWind (reducer $ PGXF $ snd memodeb) ty) $ -- fmap meToAE $ -- koko+ lmt memodeb $ normalize $ unquantify ty -- ¤³¤Ã¤Á¤À¤Èlookup+{-+matchProgs memodeb ty = fmap toAnnExpr $ wind (fmap (mapCE Lambda)) (lookupFuns memodeb) [] (quantify ty) -- ¤³¤Ã¤Á¤À¤Èrecompute ¤È¤¤¤¦¤È¸ìÊÀ¤¬¤¢¤ë¡¥recompute¤·¤¿¤¤ãlmt¤Î¤È¤³¤í¤òÊѤ¨¤ë¤Ù¤·¡¥++-- matchProgs¤Î¤ß¤Î²¼ÀÁ¤±¡¤matchFuns¤È¸ò´¹²Äǽ+lookupFuns :: (Expression e, Ord e) => (Int, MemoDeb e) -> [Type] -> Type -> BF e+lookupFuns memodeb@(memodepth,((_,mt),_,tcl,rtrie)) avail reqret =+{-+#ifdef CLASSIFY+ fmap fromAnnExpr $ toRc $ filterDM tcl rtrie ty $ fromRc $ fmap (toAnnExprWind ty) $+#endif+-}+-- mapDepth uniqSort $+ matchFuns memodeb avail reqret+ where ty = popArgs avail reqret+-}++specializedPossibleTypes :: Type -> (Int, MemoDeb) -> Recomp Type+specializedPossibleTypes ty memodeb = runPS (fmap (\(av,t) -> popArgs av t) $ specializedTypes memodeb [] ty)+-- specializedPossibleTypes ty memodeb@(_,((mt,_),_,_,_)) = fmap (\(_,s,_) -> apply s ty) $ toRc $ lmtty mt ty+++type MemoDeb = (MemoTrie, (([Prim],[Prim]),([Prim],[Prim])), Common)+-- TyConLib¤Ï[Typed [CoreExpr]]¤«¤é¼«Á°¤Çºî¤ë¤Ù¤¡¥¾ì¹ç¤Ë¤è¤Ã¤Æ¤ÏLinsCCL¤È¤«¤ÈTyConLib¤ò¶¦Í¤Ç¤¤Ê¤¯¤Ê¤ë¤«¤âÃΤì¤Ê¤¤¤±¤É¡¤¤½¤ì¤Ï¤½¤ì¤ÇOK¡¥¤«¡© ¤ä¤Ã¤Ñ¼«Á°¤Çºî¤ë¤Î¤ÏLIBRARY¤Î¥±¡¼¥¹¤Î¤ß¤Ë¤·¤Æ¤ª¤¯¤«¡¥+-- ¤¢¡¤¤Æ¤æ¡¼¤«¡¤[Typed [CoreExpr]]¤òºî¤ë¤Î¤ËTyConLib¤¬É¬Íס¥+-- ¤à¤·¤í¡¤[([CoreExpr],TypeRep)]¤«¤éTyConLib¤È[Typed [CoreExpr]]¤òºî¤ë´¶¤¸¤Ç¡¥++ -- maxBound»È¤¦¤È¿ʬ¸úΨ°¤¤¤±¤É¡¤¤Þ¤¢ÌÌÅݤÀ¤·¤¤¤¤¤«¡¥+maxBound' = maxBound -- Setting this to some small value can sometimes be helpful when seeing the heap behavior.+mkTrieOptSF :: Common -> [Typed [CoreExpr]] -> [Typed [CoreExpr]] -> MemoDeb+mkTrieOptSF cmn txsopt txs+ = let+ memoDeb = (memoTrie, (qtlopt,qtl), cmn)+ -- memoTrie :: MemoTrie+ memoTrie = (typeTrie,expTrie)+ typeTrie = mkMTty (tcl cmn) (\ty -> freezePS ty (specTypes (maxBound', memoDeb) ty))+ expTrie = mkMTexp (tcl cmn) (\ty -> -- fmap (aeToME (tcl cmn) (rt cmn) ty) $+ filtBF cmn ty $ toMx $ matchFunctions (maxBound', memoDeb) ty)+ in memoDeb+ where qtlopt = splitPrims txsopt+ qtl = splitPrims txs++mkMTty = mkMT+mkMTexp = mkMT++mondepth = zipDepthRc (\d xs -> trace ("depth="++show d++", and the length is "++show (length xs)) xs) -- depth¤Èɽ¼¨¤¹¤ë¤Ê¤é+1¤¹¤ë¤Ù¤¤Ç¤¢¤Ã¤¿¡¥(0¤«¤é»Ï¤Þ¤ë¤Î¤Ç)+++type BFT = Recomp+unBFM = unMx+++{-+freezePS :: (Search m, Expression e) => Type -> PriorSubsts m (ExpTip e) -> Matrix (ExpTip e,Subst,Int)+freezePS ty ps+ = 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 Recomp e -> Matrix (e,Subst,Int)+freezePS ty ps+ = let mxty = maxVarID ty -- `max` maximum (map maxVarID avail)+ in mapDepth (tokoro10ap ty) $ toMx $ 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)])+tokoro10 :: (Eq k, Ord k) => [(a,k,i)] -> [(a,k,i)]+tokoro10 = mergesortWithBy const (\ (_,k,_) (_,l,_) -> k `compare` l)++-- tokoro10fstfst = mergesortWithBy const (\ ((k,_),_,_) ((l,_),_,_) -> k `compare` l)++tokoro10ap :: Type -> [(a,Subst,i)] -> [(a,Subst,i)]+tokoro10ap ty = mergesortWithBy const (\ (_,k,_) (_,l,_) -> normalize (apply k ty) `compare` normalize (apply l ty))++-- avail¤Ë¤·¤íType¤Ë¤·¤íapply¤µ¤ì¤Æ¤¤¤ë¡¥+-- ¤À¤«¤é¤³¤½¡¤runAnotherPSŪ¤ËemptySubst¤ËÂФ·¤Æ¼Â¹Ô¤·¤¿Êý¤¬¸úΨŪ¤Ê¤Ï¤º¡© ¤Ç¤â¡¤Substitution¤Ã¤Æ¤½¤ó¤Ê¤Ë¤Ç¤«¤¯¤Ê¤é¤Ê¤«¤Ã¤¿¤Î¤Ç¤Ï¡©FiniteMap¤Ç¤âassoc list¤Ç¤âÊѤï¤é¤Ê¤«¤Ã¤¿µ¤¤¬¡¥+++specializedTypes :: (Search m) => (Int, MemoDeb) -> [Type] -> Type -> PriorSubsts m ([Type],Type)+specializedTypes memodeb avail t = do specializedCases memodeb avail t+ subst <- getSubst+ return (map (apply subst) avail, apply subst t)+-- specializedCases is the same as unifyableExprs, except that the latter returns PriorSubsts BF [CoreExpr], and that the latter considers memodepth.+specializedCases, specCases, specCases' :: (Search m) => (Int, MemoDeb) -> [Type] -> Type -> PriorSubsts m ()+specializedCases memodeb = applyDo (specCases memodeb)+specCases (_,memodeb) = wind_ (\avail reqret -> reorganize_ (\newavail -> uniExprs_ (maxBound',memodeb) newavail reqret) avail)+{- ¤É¤Ã¤Á¤¬¤ï¤«¤ê¤ä¤¹¤¤¤«¤ÏÉÔÌÀ+specCases memodeb avail (t0:->t1) = specCases memodeb (t0 : avail) t1+specCases (_,memodeb) avail reqret = reorganize_ (\newavail -> uniExprs_ (maxBound',memodeb) newavail reqret) avail+-}++++++uniExprs_ :: (Search m) => (Int, MemoDeb) -> [Type] -> Type -> PriorSubsts m ()+uniExprs_ memodeb avail t+ = convertPS fromRc $ psListToPSRecomp lfp+ where lfp depth+ | memocond depth = lookupUniExprs memodeb avail t depth >> return ()+ | otherwise = makeUniExprs memodeb avail t depth >> return ()++lookupUniExprs :: (Int, MemoDeb) -> [Type] -> Type -> Int -> PriorSubsts [] (Matrix AnnExpr)+lookupUniExprs memodeb@(_,((mt,_),_,_)) avail t depth+ = lookupNormalized (\tn -> unMx (lmtty mt tn) !! depth) avail t++makeUniExprs :: (Int, MemoDeb) -> [Type] -> Type -> Int -> PriorSubsts [] Type+makeUniExprs memodeb avail t depth+ = convertPS tokoro10fst $+ do psRecompToPSList (reorganize_ (\av -> specCases' memodeb av t) avail) depth+ sub <- getSubst+ return $ quantify (apply sub $ popArgs avail t)++{-+makeUniExprs_ memodeb@(_,(_, _, tcl, rtrie)) avail t depth+ = t10PS (popArgs avail t) $ psRecompToPSList (specCases' memodeb avail t) depth+t10PS :: Type -> PriorSubsts [] a -> PriorSubsts [] ()+t10PS ty ps+ = do convertPS tokoro10fst $+ do ps+ sub <- getSubst+ return (apply sub ty)+ return ()+-- ¤³¤³¤Ç¤ÏƱ¤¸·¿¤Ë¤Ê¤ë¤â¤Î¤ò¤Þ¤È¤á¤Æ¤¤¤ëÌõ¤À¤¬¡¤+-- - ¤³¤³¤Ç¤Þ¤È¤á¤¿Êý¤¬Â®¤¤¤Î¤«¡¤¤½¤ó¤Ê¤³¤È¤ò¤»¤º¤Ëñ¤ËpsRecompToPSList (specCases' memodeb avail t) depth¤ò»È¤¦Êý¤¬Â®¤¤¤Î¤«+-- - typetrie¤Ëmemoize¤¹¤ë¤È¤¤â¤Á¤ã¤ó¤È¤Þ¤È¤á¤Æ¤¤¤ë¤Î¤«¡¤+-- Ä´¤Ù¤ë¤Ù¤·¡¥Æäˡ¤typetrie¤Ç¤Þ¤È¤á¤Æ¤¤¤Ê¤¤¤«¤é¥Ò¡¼¥×¤¬Áý¤¨¤Æ¤¤¤ë¤Î¤«¤â¡¥+-}++-- entry point for memoization+specTypes :: (Search m) => (Int, MemoDeb) -> Type -> PriorSubsts m (Matrix AnnExpr)+specTypes memodeb@(_,((_,mt),_,_)) ty+ = do let (avail,t) = splitArgs ty+ reorganize_ (\av -> specCases' memodeb av t) avail+-- quantify¤ÏmemoÀè¤Ç´û¤Ë¤ä¤é¤ì¤Æ¤¤¤ë¤Î¤ÇÉÔÍ×+ typ <- applyPS ty+ return (lmt memodeb $ normalize $ unquantify typ)+++funApSub_ :: Search m => (Type -> PriorSubsts m ()) -> (Type -> PriorSubsts m ()) -> Type -> PriorSubsts m ()+funApSub_ lltbehalf behalf (t:>ts) = do lltbehalf t+ funApSub_ lltbehalf behalf ts+funApSub_ lltbehalf behalf (t:->ts) = do behalf t+ funApSub_ lltbehalf behalf ts+funApSub_ lltbehalf behalf _t = return ()++funApSub_spec behalf = funApSub_ behalf behalf++-- 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)+ where fas | constrL $ opt cmn = funApSub_ lltbehalf behalf+ | otherwise = funApSub_spec behalf+ where behalf = specializedCases memodeb avail+ lltbehalf = flip mguAssumptions_ avail+ -- retPrimMono :: (Int, Type, Int, Typed [CoreExpr]) -> PriorSubsts BFT ()+ retPrimMono (arity, retty, numtvs, _xs:::ty)+ = napply arity delayPS $+ do tvid <- reserveTVars numtvs+ mguPS reqret (mapTV (tvid+) retty)+ fas (mapTV (tvid+) ty)+ -- retMono :: Type -> PriorSubsts BFT ()+ retMono ty = napply (getArity ty) delayPS $+ do mguPS reqret (getRet ty)+ fas ty+ -- retGen :: (Int, Type, Int, Typed [CoreExpr]) -> PriorSubsts BFT ()+ retGen (arity, _r, numtvs, _s:::ty) = napply arity delayPS $+ do tvid <- reserveTVars numtvs -- ¤³¤Î¡ÊºÇ½é¤Î¡ËID¤½¤Î¤â¤Î¡Ê¤Ä¤Þ¤êÊÖ¤êÃͤÎtvID¡Ë¤Ï¤¹¤°¤Ë»È¤ï¤ì¤Ê¤¯¤Ê¤ë+ -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTV¤Èapply¤Ïhylo-fusion¤Ç¤¤ë¤Ï¤º¤À¤¬¡¤¾¡¼ê¤Ë¤µ¤ì¤ë¡©+ -- -- unitSubst¤òinline¤Ë¤·¤Ê¤¤¤ÈÂÌÌܤ«+ mkSubsts tvid reqret+ fas (mapTV (tvid+) ty)++ gentvar <- applyPS (TV tvid)++ guard (orderedAndUsedArgs gentvar)+ fas gentvar++type Generator m e = (Int,MemoDeb) -> [Type] -> Type -> PriorSubsts m [e]++unifyableExprs :: Generator Recomp AnnExpr+unifyableExprs memodeb avails ty = unifyableExprs' memodeb avails ty+unifyableExprs' :: Generator Recomp AnnExpr+unifyableExprs' memodeb = applyDo (wind (fmap (map (mapCE Lambda))) (lookupNormalized (lookupTypeTrie memodeb)))+++lookupTypeTrie :: (Int, MemoDeb) -> Type -> Recomp ([AnnExpr], Subst, Int)+lookupTypeTrie memodeb@(_, ((mt,_), _, _)) t+ = Rc $ + \depth -> let Mx xss = lmtty mt t+ in [ ({-map meToAE-} (yss!!depth), s, i) | (Mx yss, s, i) <- xss !! depth ]+++lookupNormalized :: MonadPlus m => (Type -> m (e, Subst, Int)) -> [Type] -> Type -> PriorSubsts m e+lookupNormalized fun avail t+ = do mx <- getMx+ let typ = popArgs avail t+ (tn, decoder) = encode typ mx+ (es, sub, m) <- mkPS (fun tn)+ updatePS (retrieve decoder sub)+ updateMx (m+)+ return es++tokoro10fst :: (Eq k, Ord k) => [(k,s,i)] -> [(k,s,i)]+tokoro10fst = mergesortWithBy const (\ (k,_,_) (l,_,_) -> k `compare` l)++-- entry for memoization+matchFunctions :: (Int, MemoDeb) -> Type -> Recomp AnnExpr+matchFunctions memodeb ty = case splitArgs (quantify ty) of (avail,t) -> matchFuns memodeb avail t++matchFuns :: (Int,MemoDeb) -> [Type] -> Type -> Recomp AnnExpr+matchFuns memodeb avail reqret = catBags $ runPS (-- trace "matchFuns'" $ + matchFuns' unifyableExprs memodeb avail reqret)++matchFuns' :: Generator Recomp AnnExpr -> Generator Recomp AnnExpr+-- matchFuns' = generateFuns matchPS filtExprs lookupListrie -- MemoDeb¤Î·¿¤Î°ã¤¤¤Ç¤³¤ì¤Ï¤¦¤Þ¤¯¤¤¤«¤Ê¤ó¤À¡¥+matchFuns' rec memodeb@(_, md@(_, (_,(primgen,primmono)),cmn)) avail reqret+ = let behalf = rec memodeb avail+ lltbehalf = lookupListrie lenavails rec memodeb avail -- heuristic filtration+ lenavails = length avail+-- fe :: Type -> Type -> [CoreExpr] -> [CoreExpr] -- ^ heuristic filtration+ fe = filtExprs (guess $ opt cmn)+ in fromAssumptions (PGXF md) lenavails behalf matchPS reqret avail `mplus`+ msum (map (retPrimMono (PGXF md) lenavails lltbehalf behalf matchPS reqret) primmono+ ++ map (( if tv0 $ opt cmn then retGenTV0 else+ if tv1 $ opt cmn then retGenTV1+ else retGenOrd) (PGXF md) lenavails fe lltbehalf behalf reqret) primgen)++lookupListrie :: (Search m) => Int -> Generator m AnnExpr -> Generator m AnnExpr+lookupListrie lenavails rec memodeb@(_,md@(_,_,cmn)) avail t+ | constrL opts = matchAssumptions (PGXF md) lenavails t avail+ | guess opts = do+ args <- rec memodeb avail t+ let args' = filter (not.isClosed.toCE) args+ when (null args') mzero+ return args'+ | otherwise = rec memodeb avail t+ where opts = opt cmn+filtExprs :: Expression e => Bool -> Type -> Type -> [e] -> [e]+filtExprs g a b | g = filterExprs a b+ | otherwise = id++\end{code}
+ MagicHaskeller/ProgramGenerator.lhs view
@@ -0,0 +1,518 @@+-- +-- (c) Susumu Katayama 2009+--+ProgramGenerator.lhs; split from MemoDeb.lhs++DeBruijn.lhs; FMTypeDeb (FMTypeDS$B$r$$$8$C$?$b$N(B)$B$+$i!$(BFMType$B$r$d$a$F(Bavail$B$rA4It(Blist$B$K$7$?$b$N!%(B++revision1.36$B$+$i!$(BFIX$B$H(BOLD/FILTREC$B$r:o=|!%(B+++FMTypeDS.lhs+FMType.lhs$B$G(BPASSRENAMER2$B$J$d$D$r=PH/E@$H$9$k!%(B+revision 1.1$B!J(BFMType.lhs$B$r(BPASSRENAMER2$B$K8BDj$7$?$N$HF1$8!K$r(Bcommit$B$9$k$H$-$K%3%a%s%H$G!V%F%9%H$7$F$$$J$$!W$H=q$$$?$,!$D>8e$K%F%9%H$7$?!%(B++FMType.lhs+revision 1.41$B$/$i$$$+$iBgI}$K(Bsimplify$B$7$?!%FC$K!$(BMemoization$B$r;_$a$?!%(B+$B0JA0$N$O(BFMType.withMemoTrie.lhs$B$K;D$7$F$*$/!%(B+Memoization$B$r$d$C$F$?$*$=$i$/:G8e$NF0$/E[$K$O(BlastMemoTrie$B$H$$$&%?%0$rBG$C$F$"$k!%(B++\begin{code}+{-# OPTIONS -fglasgow-exts -cpp #-}++module MagicHaskeller.ProgramGenerator where+import MagicHaskeller.Types+import MagicHaskeller.TyConLib+import Control.Monad+import Data.Monoid+import MagicHaskeller.CoreLang+import Control.Monad.Search.Combinatorial+import MagicHaskeller.PriorSubsts+import Data.List(partition, sortBy)+import Data.Ix(inRange)++import System.Random(mkStdGen)+import MagicHaskeller.Instantiate++import MagicHaskeller.Expression++import MagicHaskeller.T10+import qualified Data.Map as Map++import Debug.Trace++import Data.Monoid+import System.Random++import MagicHaskeller.MyDynamic++import MagicHaskeller.Execute(unsafeExecute)+++-- replacement of LISTENER. Now replaced further with |guess|+-- listen = False+++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 cmn t = mkTrieOpt cmn t t+ 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 -> (Int,a) -> m AnnExpr+ matchingPrograms ty memodeb = unifyingPrograms (quantify ty) memodeb+ extractCommon :: a -> Common+extractTCL :: ProgramGenerator a => a -> TyConLib+extractTCL = tcl . extractCommon+extractVL :: ProgramGenerator a => a -> VarLib+extractVL = vl . extractCommon+extractRTrie :: ProgramGenerator a => a -> RTrie+extractRTrie = rt . extractCommon+reducer :: ProgramGenerator a => a -> CoreExpr -> Dynamic+reducer pg = execute (opt $ extractCommon pg) (extractVL pg)++data Common = Cmn {opt :: Opt (), tcl :: TyConLib, vl :: VarLib, rt :: RTrie}++-- | options that limit the hypothesis space.+data Opt a = Opt{ primopt :: Maybe a -- ^ Use this option if you want to use a different component library for the stage of solving the inhabitation problem.+ -- @Nothing@ means using the same one.+ -- This option makes sense only when using *SF style generators, because otherwise the program generation is not staged.+ -- Using a minimal set for solving the inhabitation and a redundant library for the real program generation can be a good bet.+ , execute :: VarLib -> CoreExpr -> Dynamic -- timeout $B$O$3$NCf$G$d$k$Y$-!%(BIO Dynamic$B$N>l9g$K(BunsafePerformIO$B$r(B2$B2s$d$k$HJQ$J$3$H$K$J$j$=$&$J$N$G!%(B+ , timeout :: Maybe Int -- ^ @Just ms@ sets the timeout to @ms@ microseconds. Also, my implementation of timeout also catches inevitable exceptions like stack space overflow. Note that setting timeout makes the library referentially untransparent. (But currently @Just 20000@ is the default!) Setting this option to @Nothing@ disables both timeout and capturing exceptions.+ , guess :: Bool -- ^ If this option is @True@, the program guesses whether each function is a case/catamorphism/paramorphism or not. This information is used to filter out some duplicate expressions.+ , contain :: Bool -- ^ This option is now obsolete, and we always assume True now.+ -- If this option was @False@, data structures might not contain functions, and thus types like @[Int->Int]@, @(Int->Bool, Char)@, etc. were not permitted.+ -- (NB: recently I noticed that making this @False@ might not improve the efficiency of generating lambda terms at all, though when I generated combinatory expressions it WAS necessary.+ -- In fact, I mistakenly turned this limitation off, and my code always regarded this as True, but I did not notice that, so this option can be obsoleted.)+ , constrL :: Bool -- ^ If this option is @True@, matching at the antecedent of induction rules may occur, which constrains generation of existential types. + -- You need to use prefixed @(->)@ to show that some parameter can be matched at the antecedent, e.g.,+ -- @'p' [| ( []::[a], (:)::a->[a]->[a], foldr :: (a->b->b) -> b -> (->) [a] b ) |]@+ -- See LibTH.hs for examples.+ , tv1 :: Bool -- ^ If this option is @True@, the return type of functions returning a type variable (e.g. @b@ in @foldr::(a->b->b)->b->[a]->b@)+ -- can only be replaced with @Eval t => t@ and @Eval t => u -> t@, while if @False@ with @Eval t => t@, @Eval t => u->t@, @Eval t => u->v->t@, etc., where @Eval t@ means t cannot be replaced with a function.+ -- The restriction can be amended if the tuple constructor and destructors are available.+ , tv0 :: Bool+ , stdgen :: StdGen -- ^ The random seed.+ , nrands :: [Int] -- ^ number of random samples at each depth, for each type.+ }++-- | default options+--+-- > options = Opt{ primopt = Nothing+-- > , execute = unsafeExecute+-- > , timeout = Just 20000+-- > , guess = False+-- > , contain = True+-- > , constrL = False+-- > , tv1 = False+-- > , stdgen = mkStdGen 123456+-- > , nrands = repeat 5+-- > }++options :: Opt a+options = Opt{ primopt = Nothing+ , execute = unsafeExecute+ , timeout = Just 20000+ , guess = False+ , contain = True+ , constrL = False+ , tv1 = False+ , tv0 = False+ , stdgen = mkStdGen 123456+ , nrands = nrnds+ }++-- reducer (opt,_,_,_,_) = execute opt++++nrnds = map fnrnds [0..]+chopRnds :: [[a]] -> [[a]]+chopRnds = zipWith take nrnds++{-+fnrnds n | n <= 5 = 5+ | n < 10 = 10-n+ | otherwise = 1+-}+fnrnds _ = 5+{-+fnrnds n | n < 13 = 13-n+ | otherwise = 1+-}++retsTVar (_, TV tv, _, _) = True+retsTVar _ = False++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)+++applyDo :: Monad m => ([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)++wind :: (a->a) -> ([Type] -> Type -> a) -> [Type] -> Type -> a+wind g f avail (t0 :-> t1) = g $ wind g f (t0 : avail) t1+wind _ f avail reqret = f avail reqret++wind_ :: ([Type] -> Type -> a) -> [Type] -> Type -> a+wind_ = wind id+++{-# SPECIALIZE fromAssumptions :: (Search m, ProgramGenerator pg) => pg -> Int -> (Type -> PriorSubsts m [CoreExpr]) -> (Type -> Type -> PriorSubsts m ()) -> Type -> [Type] -> PriorSubsts m [CoreExpr] #-}+fromAssumptions :: (Search m, Expression e, ProgramGenerator pg) => pg -> Int -> (Type -> PriorSubsts m [e]) -> (Type -> Type -> PriorSubsts m ()) -> Type -> [Type] -> PriorSubsts m [e]+fromAssumptions pg lenavails behalf mps reqret avail = msum $ map (retMono pg lenavails behalf (flip mps reqret)) (fromAvail avail)++retMono :: (Search m, Expression e, ProgramGenerator pg) => pg -> Int -> (Type -> PriorSubsts m [e]) -> (Type -> PriorSubsts m ()) -> ([CoreExpr], (Int,[Type],Type)) -> PriorSubsts m [e]+retMono pg lenavails behalf tok fromBlah+ = do let (es, (arity,args,retty)) = fromBlah+ tok retty+ convertPS (ndelay arity) $+ fap behalf args (map (fromCE (reducer pg) lenavails arity) es)+fromAvail :: [Type] -> [([CoreExpr], (Int,[Type],Type))]+fromAvail = zipWith (\ n t -> ([X n], revSplitArgs t)) [0..]+++-- ConstrL$B$G$O(Bmatch$B$G$O%@%a!%M}M3$O(BDec. 2, 2007$B$N(Bnotes$B$r;2>H!%(B+mguAssumptions :: (MonadPlus m) => Type -> [Type] -> PriorSubsts m [CoreExpr]+mguAssumptions patty assumptions = applyDo mguAssumptions' assumptions patty+mguAssumptions' assumptions patty = msum $ zipWith (\n t -> mguPS patty t >> return [X n]) [0..] assumptions++{-# SPECIALIZE matchAssumptions :: (MonadPlus m, ProgramGenerator pg) => pg -> Int -> Type -> [Type] -> PriorSubsts m [CoreExpr] #-}+matchAssumptions :: (MonadPlus m, Expression e, ProgramGenerator pg) => pg -> Int -> Type -> [Type] -> PriorSubsts m [e]+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+-- 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 ().+mguAssumptions_ :: (MonadPlus m) => Type -> [Type] -> PriorSubsts m ()+mguAssumptions_ patty assumptions = applyDo mguAssumptions_' assumptions patty+mguAssumptions_' assumptions patty = msum $ map (mguPS patty) assumptions++{-# SPECIALIZE retPrimMono :: (Search m, ProgramGenerator pg) => pg -> Int -> (Type -> PriorSubsts m [CoreExpr]) -> (Type -> PriorSubsts m [CoreExpr]) -> (Type -> Type -> PriorSubsts m ()) -> Type -> Prim -> PriorSubsts m [CoreExpr] #-}+retPrimMono :: (Search m, Expression e, ProgramGenerator pg) => pg -> Int -> (Type -> PriorSubsts m [e]) -> (Type -> PriorSubsts m [e]) -> (Type -> Type -> PriorSubsts m ()) -> Type -> Prim -> PriorSubsts m [e]+retPrimMono pg lenavails lltbehalf behalf mps reqret (arity, retty, numtvs, xs:::ty)+ = 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 :: (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+ funApSubOp op lltbehalf behalf ts (liftM2 op funs args)+-- original. +funApSubOp op lltbehalf behalf (t:->ts) funs = do args <- behalf t+ funApSubOp op lltbehalf behalf ts (liftM2 op funs args)+funApSubOp _ _ _ _ funs = return funs+-- original$B$G(BrevGetArgs$B7PM3$K$9$k$H!$(BfoldM$B$r;H$C$?>l9g$HF1$88zN($K$J$k!%(B+{-+funApSub behalf t funs = fap behalf (revGetArgs t) funs+revGetArgs (t:->u) = t : revGetArgs u+revGetArgs _ = []+-}+{-+fap behalf (t:ts) funs = do args <- behalf t+ fap behalf ts (liftM2 (<$>) funs args)+fap _ _ funs = return funs+-}+{- mapM$B$r;H$&(B $B0lHVCY$$!%(B+fap behalf ts funs = do args <- mapM behalf ts+ return (foldl (liftM2 (<$>)) funs args)+-}+ -- foldM$B$r;H$&!%$J$<$+$3$l$,0lHVB.$$(B+fap behalf ts funs = foldM (\fs t -> do args <- behalf t+ return $ liftM2 (<$>) fs args)+ funs+ ts++-- fap behalf ts funs = mapAndFoldM (liftM2 (<$>)) funs behalf ts+mapAndFoldM op n f [] = return n+mapAndFoldM op n f (x:xs) = do y <- f x+ mapAndFoldM op (n `op` y) f xs+++{-# SPECIALIZE retGen :: (Search m, ProgramGenerator pg) => pg -> Int -> (Type -> Type -> [CoreExpr] -> [CoreExpr]) -> (Type -> PriorSubsts m [CoreExpr]) -> (Type -> PriorSubsts m [CoreExpr]) -> Type -> Prim -> PriorSubsts m [CoreExpr] #-}+retGen, retGenOrd, retGenTV1+ :: (Search m, Expression e, ProgramGenerator pg) => pg -> Int -> (Type -> Type -> [e] -> [e]) -> (Type -> PriorSubsts m [e]) -> (Type -> PriorSubsts m [e]) -> Type -> Prim -> PriorSubsts m [e]+retGen pg lenavails fe lltbehalf behalf = retGen' (funApSub lltbehalf behalf) pg lenavails fe lltbehalf behalf+retGen' fas pg lenavails fe lltbehalf behalf reqret (arity, _retty, numtvs, xs:::ty)+ = convertPS (ndelay arity) $+ do tvid <- reserveTVars numtvs -- $B$3$N!J:G=i$N!K(BID$B$=$N$b$N!J$D$^$jJV$jCM$N(BtvID$B!K$O$9$0$K;H$o$l$J$/$J$k(B+ -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTV$B$H(Bapply$B$O(Bhylo-fusion$B$G$-$k$O$:$@$,!$>!<j$K$5$l$k!)(B+ -- -- unitSubst$B$r(Binline$B$K$7$J$$$HBLL\$+(B+ a <- mkSubsts tvid reqret+ exprs <- funApSub lltbehalf behalf (mapTV (tvid+) ty) (map (fromCE (reducer pg) lenavails (arity+a)) xs)+ gentvar <- applyPS (TV tvid)+ guard (orderedAndUsedArgs gentvar) -- $B$3$NJU$N(Bcheck$B$r(BTVn$B$KF~$kA0$NAa$$CJ3,$K$d$k$N$O(B1$B$D$N9M$(J}$@$,!$(BTVn$BCf$K(Breplace$B$5$l$?$j$O$7$J$$$N$+(B?+ fas gentvar (fe gentvar ty exprs)+-- retGenOrd can be used instead of retGen, when not reorganizing.+retGenOrd pg lenavails fe lltbehalf behalf = retGen' (funApSub'' False) pg lenavails fe lltbehalf behalf+ where+-- funApSub'' filtexp (TV _ :-> _) funs = mzero -- mkSubsts$B$GF3F~$5$l$?(Btyvars$B$,;H$o$l$F$$$J$$%1!<%9!%(Breplace$B$5$l$?7k2L(BTV$B$C$F%1!<%9$O$H$j$"$($:L5;k(B....+ funApSub'' filtexp (t:->ts@(u:->_)) funs+-- | t > u = mzero+ | otherwise = do args <- behalf t+ funApSub'' (t==u) ts (if filtexp then [ f <$> e | f <- funs, e <- args, let _:$d = toCE f, d <= toCE e ]+ else liftM2 (<$>) funs args)+-- $B$F$f!<$+(Bt$B$H(Bu$B$,F1$8$J$i$P$b$C$H$$$m$s$J$3$H$,$G$-$=$&!%(B+ funApSub'' filtexp (t:->ts) funs+ = do args <- behalf t+ return (if filtexp then [ f <$> e | f <- funs, e <- args, let _:$d = toCE f, d <= toCE e]+ else liftM2 (<$>) funs args)+ funApSub'' _fe _t funs = return funs++orderedAndUsedArgs (TV _ :-> _) = False -- mkSubsts$B$GF3F~$5$l$?(Btyvars$B$,;H$o$l$F$$$J$$%1!<%9!%(Breplace$B$5$l$?7k2L(BTV$B$C$F%1!<%9$O$H$j$"$($:L5;k(B....+orderedAndUsedArgs (t:->ts@(u:->_)) | t > u = False+ | otherwise = orderedAndUsedArgs ts+orderedAndUsedArgs _ = True++usedArg n (TV m :-> _) = n /= m+usedArg _ _ = True++retGenTV1 pg lenavails fe lltbehalf behalf reqret (arity, _retty, numtvs, xs:::ty)+ = convertPS (ndelay arity) $+ do tvid <- reserveTVars numtvs -- $B$3$N!J:G=i$N!K(BID$B$=$N$b$N!J$D$^$jJV$jCM$N(BtvID$B!K$O$9$0$K;H$o$l$J$/$J$k(B+ -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTV$B$H(Bapply$B$O(Bhylo-fusion$B$G$-$k$O$:$@$,!$>!<j$K$5$l$k!)(B+ -- -- unitSubst$B$r(Binline$B$K$7$J$$$HBLL\$+(B+ a <- mkSubst tvid reqret+ exprs <- funApSub lltbehalf behalf (mapTV (tvid+) ty) (map (fromCE (reducer pg) lenavails (arity+a)) xs)+ gentvar <- applyPS (TV tvid)+ guard (usedArg (tvid+1) gentvar)+ funApSub lltbehalf behalf gentvar (fe gentvar ty exprs)++retGenTV0 pg lenavails fe lltbehalf behalf reqret (arity, _retty, numtvs, xs:::ty)+ = convertPS (ndelay arity) $+ do tvid <- reserveTVars numtvs -- $B$3$N!J:G=i$N!K(BID$B$=$N$b$N!J$D$^$jJV$jCM$N(BtvID$B!K$O$9$0$K;H$o$l$J$/$J$k(B+ -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTV$B$H(Bapply$B$O(Bhylo-fusion$B$G$-$k$O$:$@$,!$>!<j$K$5$l$k!)(B+ -- -- unitSubst$B$r(Binline$B$K$7$J$$$HBLL\$+(B+ updatePS (unitSubst tvid reqret)+ exprs <- funApSub lltbehalf behalf (mapTV (tvid+) ty) (map (fromCE (reducer pg) lenavails arity) xs)+ gentvar <- applyPS (TV tvid)+ return $ fe gentvar ty exprs++-- LISTENER$B$+(BDESTRUCTIVE$B$,(Bdefine$B$5$l$F$$$k$H$-$N!$3F%1!<%9$N(Boptimization+filterExprs :: Expression e => Type -> Type -> [e] -> [e]+filterExprs gentvar ty = filter (cond . getArgExprs . toCE)+ where cond es = case gentvar of _:->_ -> not (retSameVal ty es) && not (includesStrictArg es) && anyRec ty es && not (constEq ty es)+ _ -> not (retSameVal ty es) && not (includesStrictArg es)++getArgExprs e = gae e []+gae (f:$e) es = gae f (e:es)+gae _ es = es++-- forall w x y. list_para w (\_ -> x) (\c d e f -> e (blah)) = \_ -> x $BE*$J$b$N(B.+constEq (t:->u) (e@(Lambda d):es) | returnsAtoA t = recHead t e && constEq u es+ | otherwise = not (isUsed 0 d) && ceq e u es+constEq (t:->u) (_:_) = False -- not case/cata/para, so should pass.+constEq (_:> u) (_ :es) = constEq u es+constEq _ [] = True+ceq d (t:->u) (e@(Lambda _):es) | returnsAtoA t = recHead t e && ceq d u es+ | otherwise = d == e && ceq d u es+ceq d (t:->u) (_:_) = False -- not case/cata/para, so should pass.+ceq d (_:> u) (_ :es) = ceq d u es+ceq _ _ [] = True++recHead (t:->u@(_:->_)) (Lambda e) = recHead u e+recHead (TV tv0 :-> TV tv1) (Lambda (Lambda (X 1 :$ _))) = tv0 == 0 && tv1 == 0 -- $BJ#?t(Brec$B$,$"$k>l9g!$:G8e$NE[$@$1(Brec$B$H$7$FG'$a$k$3$H$K$J$C$A$c$&$N$G!$:GE,2=$N0UL#$G$O$A$g$C$H$@$1%6%k(B+recHead _u _e = False+++-- windUntilRec$B$C$F$N$,$"$l$P6&M-2DG=(B (CPS$B$J46$8(B)++++retSameVal (_:>u) (_:es) = retSameVal u es+retSameVal (t:->u) (e:es) = (returnsId t e && rsv u es) || rsv' (retVal t e) u es+retSameVal _ _ = False+rsv (_:>u) (_:es) = rsv u es+rsv (t:->u) (e:es) = (returnsId t e && rsv u es) || rsv' (retVal t e) u es+rsv _ _ = True+rsv' rve (_:>u) (_:es) = rsv' rve u es+rsv' rve (t:->u) (e:es) = (returnsId t e || retVal t e == rve) && rsv' rve u es+rsv' _ _ _ = True++\end{code}++type$B$r$R$C$/$jJV$9>l9g(B++{-+-- :>$B$J(Bargument$B$r(Bdrop$B$9$k$N$rK:$l$F$?!%(B+-- :>$B$r:F$S<BAu$9$k;~$O!$(BCoreExpr$B$NJ}$N(Bspine$B$N(Blist$B$r;}$D!%$G!$(B:>$B$N>l=j$r(Bskip$B$9$k!%(B+-- $B$"$H!$JV$jCM$,4X?t$K(Bunify$B$9$k$3$H$b$"$k$N$G!$I,$:0z?t$G$O$J$/7?$NJ}$r?t$($k$3$H(B+... $B$F$f!<$+$=$l$@$C$?$i8e$m$+$i?t$($A$c%@%a$8$c$s!%(B+$B$3$l$O7k9=$d$d$3$7$$OC$@$,!$(B+$B!&(BreturnsId$B$K4X$7$F$O!$(Breplace$B$9$kA0$N7?$N(Barity$B$G?t$($F(Bid$B$rJV$9>l9g$7$+Ev$F$O$^$i$J$$!%(B+$B!&(BretVal$B$K4X$7$F$O!$$$$C$A$c$s:G8e$,Ey$7$1$l$P(BOK$B!%$H$O$$$(!$(B+ - returnsId$B$,8r$8$C$F$$$l$P!$7k6I(Breplace$B$9$kA0$N7?$N(Barity$B$G?t$($k$3$H$K$J$k$@$m$&!$$^$?!$(B+ - returnsId$B$,8r$8$C$F$$$J$$!$$D$^$j(Brecursion$B$,$J$$>l9g$O!$$=$b$=$b(Bcase expansion$B$G(Bfilter out$B$5$l$k!JM=Dj!K(B+$B$H$$$&$o$1$G!$<B:]$K$O$I$A$i$N%1!<%9$G$b(Breplace$B$9$kA0$N7?$N(Barity$B$G?t$($l$P$h$$!%$D$^$jA0$+$i?t$($m$C$F$3$H$d$M!%(B+$B$F$f!<$+!$A0$+$i?t$($k$H$+$$$&$N$O3F(Bargument$B$NOC!%(B+-}+{- $B>e5-$NM}M3$+$i!$$3$l$O4V0c$$!%(B+retSameVal (hd:tl@(_:_)) (f:$e) = -- trace ("t = "++show t ++ ", and f:$e = " ++ show (f:$e)) $ + (returnsId hd e && returnsAtoA hd && retSameVal tl f) || retSameVal' rve tl f+ where rve = retVal e+retSameVal _ _ = True+retSameVal' e (hd:tl@(_:_)) (f:$d) = ((returnsId hd d && returnsAtoA hd) || rvd==e) && retSameVal' e tl f+-- retSameVal' e t (f:$d) = (d == X 0 && returnsAtoA (head t) && retSameVal' e tailt f) || (d==e) && retSameVal' e tailt f+ where rvd = retVal d+retSameVal' _ _ _ = True+-}++retSameVal (hd:tl@(_:_)) (f:$e) = -- trace ("t = "++show t ++ ", and f:$e = " ++ show (f:$e)) $ + (returnsId hd e && retSameVal tl f) || retSameVal' (retVal hd e) tl f+retSameVal _ _ = True+retSameVal' rve (hd:tl@(_:_)) (f:$d) = (returnsId hd d || retVal hd d == rve) && retSameVal' rve tl f+retSameVal' _ _ _ = True++\begin{code}+++-- returnsAtoA is True when the type returns a->a, where the tvID of a is 0.+returnsAtoA (TV tv0 :-> TV tv1) = tv0 == 0 && tv1 == 0+returnsAtoA (t :-> u) = returnsAtoA u+returnsAtoA _ = False++-- $BF1;~$K(BreturnsAtoA$B$b%A%'%C%/$7$F$k$N$b%]%$%s%H!%(B+returnsId (t:->u@(_:->_)) (Lambda e) = returnsId u e+returnsId (TV tv0 :-> TV tv1) e = tv0 == 0 && tv1 == 0 && isId e+returnsId _u _e = False -- $B$3$3$G(B(_u,_e)$B$,(B(TV _, Lambda _)$B$C$F$3$H$b$"$jF@$k!%(B_u$B$,(Bt:->u$B$J$N$K(B_e$B$,(BLambda$B$G$J$$$C$F$N$O$"$j$($J$$$+!%(B+{- $B$3$l$@$H!$7k2L$H$7$F:G8e$N0z?t$HJV$jCM$N7?$,F1$8$@$1$I$b$H$b$H$N(BPrim$B>e$G$O0c$&!$$H$$$&2DG=@-$,$"$jF@$k!%(B+returnsId (t:->u) (Lambda e) = returnsId u e+returnsId (_:->_) _ = error "returnsId: impossible"+returnsId (TV tv) (X 0) = tvID tv == 0+returnsId _u _e = False -- $B$3$3$G(B(_u,_e)$B$,(B(TV _, Lambda _)$B$C$F$3$H$b$"$jF@$k!%(B_u$B$,(Bt:->u$B$J$N$K(B_e$B$,(BLambda$B$G$J$$$C$F$N$O$"$j$($J$$$+!%(B+-}++-- isId checks if the argument is eta-equivalent to id, i.e. (Lambda (X 0)). Note that expressions are eta-expanded.+-- for example, isId (Lambda (Lambda (Lambda ((X 2 :$ X 1) :$ X 0)))) is True.+-- There is no need to tell that isId (Lambda ((Lambda (X 0)) :$ X 0)) is True, because this beta-reducible expression would not be synthesized.+isId e = isId' 0 e+isId' n (Lambda e) = isId' (n+1) e+isId' n e = isId'' n 0 e+isId'' n m (e :$ X i) = i==m && isId'' n (m+1) e+isId'' n m (X i) = i==m && n == m+1+isId'' _ _ _ = False+++retVal t e = rv t 0 e+rv (_:->t) n (Lambda e) = rv t (n+1) e+rv (_:->_) _ _ = error "rv: impossible"+rv _ n e = mapsub n e++-- mapsub n ~= gmap (subtract n), but I will have to rewrite the definition of CoreExpr to prevent gmap from updating other Ints.+mapsub n (X m) = X (m-n)+mapsub n (a :$ b) = mapsub n a :$ mapsub n b+mapsub n (Lambda e) = Lambda (mapsub n e)+mapsub n e = e+++isClosed = isClosed' 0+isClosed' dep (X n) = n < dep+isClosed' dep (Lambda e) = isClosed' (dep+1) e+isClosed' dep (f :$ e) = isClosed' dep f && isClosed' dep e+isClosed' _ _ = True+++-- $B8zN($N$3$H$r9M$($k$H!$(BstrictArg$B$O:G=i$K;}$C$F$/$k$3$H$K$J$k!%!J>-MhE*$K$O!$:G=i$K$J$k$h$&$KJB$YJQ$($F(Bgenerate$B$7!$=*$C$F$+$i85$KLa$9$3$H$K$J$k!K(B+-- $B!J>/$J$/$H$b!$:G=i$K(Bexpand$B$9$k!%@)8B$,B?$$$N$GJ,4t$7$K$/$$$+$i!%!K(B+includesStrictArg (X n : es) = any (isUsed n) es+-- case$B$N%G!<%?$J$N$G(BLambda$B$OMh$J$$!%$"$H!$(BQuantify$B$O:G=i$+$i(Bexclude$B$5$l$F$$$k!%$H$$$&$o$1$G!$$3$3$K$O<B:]$K$O(B((_:$_):_)$B$+(B[]$B$7$+Mh$J$$!%(B+-- $B4X?tE,MQ$N>l9g$O$a$s$I$/$5$$$7%A%'%C%/$b%3%9%H$,$+$+$k$N$GAGDL$7$K$9$k!%(B+includesStrictArg _ = False+{-+includesStrictArg [] = False+includesStrictArg es = case last es of X n -> any (isUsed n) (init es)+ _:$_ -> False -- $B4X?tE,MQ$N>l9g$O$a$s$I$/$5$$$7%A%'%C%/$b%3%9%H$,$+$+$k$N$GAGDL$7$K$9$k!%(B+-- case$B$N%G!<%?$J$N$G(BLambda$B$OMh$J$$!%$"$H!$(BQuantify$B$O:G=i$+$i(Bexclude$B$5$l$F$$$k!%(B+-}++anyRec (_:>t) (_:es) = anyRec t es+anyRec (t:->u) (e:es) = -- trace ("ar: t = "++show t++" and u = "++ show u) $+ recursive t e || anyRec u es+anyRec (_:->_) _ = error "hoge"+anyRec _ [] = False+{- type$B$NJ}$r$R$C$/$jJV$9>l9g(B+anyRec (hd:tl@(_:_)) (f:$e) = recursive hd e || anyRec tl f+anyRec _ _ = False+-}++recursive (t:->u@(_:->_)) (Lambda e) = recursive u e+recursive (TV tv0 :-> TV tv1) (Lambda e) = tv0 == 0 && tv1 == 0 && isUsed 0 e && not (constRec 0 e) -- $B$3$l$@$H!$(Brecursive$B$N$d$D$H(Bnot const.rec$B$N$d$D$,F1$8$G$J$/$F$O$J$i$J$$$,!$$=$N>r7o$OI,MW$+!)(B $B!J(Blist$B$G$d$C$F$$$k8B$j$O5$$K$7$J$/$F$$$$$C$FOC$b$"$k$1$I!K(B+recursive _ _ = False++constRec dep (Lambda e) = constRec (dep+1) e+constRec dep (X n :$ e) | n == dep = not (belowIsUsed n e)+constRec _ _ = False+belowIsUsed dep (X n) = dep > n+belowIsUsed dep (Lambda e) = belowIsUsed (dep+1) e+belowIsUsed dep (f :$ e) = belowIsUsed dep f || belowIsUsed dep e+belowIsUsed _ _ = False++{-+lastarg (_:->t@(_:->_)) = let Just (la,n) = lastarg t in Just (la, n+1)+lastarg (t:->_) = Just (t, 1)+lastarg _ = Nothing++isRec n expr = isUsed (-n) expr+-}+isUsed dep (X n) = dep==n+isUsed dep (Lambda e) = isUsed (dep+1) e+isUsed dep (f :$ e) = isUsed dep f || isUsed dep e+isUsed _ _ = False+++mkSubsts :: Search m => Int -> Type -> PriorSubsts m Int+mkSubsts tvid reqret = base `mplus` delayPS recurse+ where base = do updatePS (unitSubst tvid reqret) -- $B$3$3$r(BsetSubst$B$K$7$F!$(BmguProgs$B$r8F$S=P$9$?$S$K7k2L$N(BSubst$B$r(BplusSubst$B$9$k$h$&$K$7$?J}$,!$L5BL$K(BSubst$B$,Bg$-$/$J$i$J$$!%(B+ -- $B$a$s$I$/$5$$$+$i$3$&$7$F$k$1$I!$$b$7(BlookupSubst$B$,;~4V$r?)$$2a$.$k$J$i9M$($k!%(B+ return 0+ recurse = do v <- newTVar+ arity <- mkSubsts tvid (TV v :-> reqret)+ return (arity+1)++mkSubst :: Search m => Int -> Type -> PriorSubsts m Int+mkSubst tvid reqret = base `mplus` delayPS first+ where base = do updatePS (unitSubst tvid reqret) -- $B$3$3$r(BsetSubst$B$K$7$F!$(BmguProgs$B$r8F$S=P$9$?$S$K7k2L$N(BSubst$B$r(BplusSubst$B$9$k$h$&$K$7$?J}$,!$L5BL$K(BSubst$B$,Bg$-$/$J$i$J$$!%(B+ -- $B$a$s$I$/$5$$$+$i$3$&$7$F$k$1$I!$$b$7(BlookupSubst$B$,;~4V$r?)$$2a$.$k$J$i9M$($k!%(B+ return 0+ first = do v <- newTVar+ updatePS (unitSubst tvid (TV v :-> reqret))+ return 1+mkRetty t = (getRet t, t)+-- getRet (t0:->t1) = getRet t1+-- getRet t = t++-- MemoStingy$B$H$+$G$O(B+-- reorganize_ :: ([Type] -> PriorSubsts BF ()) -> [Type] -> PriorSubsts BF ()+-- $B$H$7$F;H$o$l$k$N$@$,!$(BG4ip$B$G$O2<5-$N7?$8$c$J$$$H!%(B+reorganizer_ :: ([Type] -> a) -> [Type] -> a+reorganizer_ fun avail = fun $ uniqSort avail+++-- moved from T10.hs to make T10 independent of Types++-- hit decides whether to memoize or not.+hit :: Type -> [Type] -> Bool+-- hit ty tys = True -- always memo+-- hit ty tys = areMono (ty:tys) -- memo only tycons ... Subst$B$$$i$J$$$7!$(BavailsToReplacer$B$J$7$G!J(Bnewavail$B$J$7$G!KH=Dj$G$-$k!%$"$H$=$b$=$b!$(BMapType$B$K(Btv$B$d(Beval$B$,$$$i$J$$$7!$(Bencode/decode$B$b$$$i$J$/$J$k!%$?$@!$(Bmonomorphic$B$7$+$i$d$J$$$N$C$F!$$A$g$C$H>/$J2a$.$k5$$b$9$k!%(B+-- hit ty tys = sum (map size (ty:tys)) < 7+-- hit ty tys = sum (map size (ty:tys)) < 2+-- hit ty tys = sum (map size (ty:tys)) < 5+-- hit ty tys = sum (map size (ty:tys)) < 12+hit ty tys = sum (map size (ty:tys)) < 10+++areMono = all (null.tyvars)+++\end{code}+
+ MagicHaskeller/ReadDynamic.hs view
@@ -0,0 +1,22 @@+-- +-- (c) Susumu Katayama 2009+--+-- -prof$B$9$k$H$-$K(B-auto-all$B$9$k$H(BPAP$B$K(Benter$B$7$F$7$^$&ItJ,$r$o$1$F$_$?!%:G=i(BMyDynamic$B$KF~$l$h$&$H;W$C$?$N$@$,!$(Bcyclic$B$K$J$C$?$N$G!%(B++module MagicHaskeller.ReadDynamic where+-- import ReadType+import MagicHaskeller.MyDynamic+import Language.Haskell.TH+dynS = $(dynamic [|undefined|] [| s :: (b->c->a) -> (b->c) -> b -> a |])+dynK = $(dynamic [|undefined|] [| const :: a->b->a |])+dynI = $(dynamic [|undefined|] [| id :: a->a |])+dynB = $(dynamic [|undefined|] [| (.) :: (c->a) -> (b->c) -> b -> a |])+dynC = $(dynamic [|undefined|] [| flip :: (b->c->a) -> c -> b -> a |])+dynS' = $(dynamic [|undefined|] [| sprime :: (a->b->c)->(d->a)->(d->b)->d->c |])+dynB' = $(dynamic [|undefined|] [| bprime :: (a->b->c)->a->(d->b)->d->c |])+dynC' = $(dynamic [|undefined|] [| cprime :: (a->b->c)->(d->a)->b->d->c |])+-- readType assumes the tcl is undefined, so it cannot be used when type constructors other than -> are used.+s = \f g x -> f x (g x)+sprime = (\f g h x -> f (g x) (h x))+bprime = (\f g h x -> f g (h x))+cprime = (\f g h x -> f (g x) h)
+ MagicHaskeller/ReadTHType.lhs view
@@ -0,0 +1,82 @@+-- +-- (c) Susumu Katayama 2009+--++\begin{code}+{-# OPTIONS -fglasgow-exts -cpp #-}+module MagicHaskeller.ReadTHType(thTypeToType, typeToTHType, showTypeName) where++import MagicHaskeller.Types as Types+import MagicHaskeller.TyConLib+import Language.Haskell.TH as TH+import Data.Array((!), inRange, bounds)+import Data.Char(ord,chr)+import Data.List(nub)+import Data.Map(lookup)++showTypeName = TH.nameBase -- Use the unqualified name to avoid confusion because Data.Typeable.tyConString shows the unqualified name for types defined in the Standard Hierarchical Library (though the qualified name is shown when Typeable is derived).+-- showTypeName = show -- maybe in future, when TypeRep can be shown qualified.++-- MyDynamicŵ©gíêĢȢÌÅCForallTÍPɳ·éDPolyDynamicÌ`FbNª¿åÁÆÉÈ龯D+thTypeToType :: TyConLib -> TH.Type -> Types.Type+thTypeToType tcl t = normalize $ thTypeToType' tcl t+thTypeToType' tcl (ForallT _ [] t) = thTypeToType' tcl t+thTypeToType' tcl (ForallT _ (_:_) t) = error "Type classes are not supported yet."+thTypeToType' tcl (TupleT n) = TC (tuple tcl n)+thTypeToType' tcl ListT = TC (list tcl)+-- thTypeToType' tcl (HsTyFun ht0 ht1)+-- = thTypeToType' tcl ht0 :-> thTypeToType' tcl ht1+thTypeToType' tcl (AppT (AppT ArrowT ht0) ht1) = thTypeToType' tcl ht0 :-> thTypeToType' tcl ht1+thTypeToType' tcl (AppT (AppT (ConT name) ht0) ht1) | nameBase name == "(->)" = thTypeToType' tcl ht0 :> thTypeToType' tcl ht1+thTypeToType' tcl (AppT ht0 ht1) = TA (thTypeToType' tcl ht0) (thTypeToType' tcl ht1)+thTypeToType' (fm,_) (ConT name) = let nstr = showTypeName name+ in case Data.Map.lookup nstr fm of+ Nothing -> TC $ (-1 - bakaHash nstr) -- error "nameToTyCon: unknown TyCon"+ Just c -> TC c+{- ±ÌÓÍPÈéRgAEgÅ¢¢ñ¾Á¯H +thTypeToType' tcl (HsTyCon (Special HsUnitCon)) = TC (unit tcl)+thTypeToType' tcl (HsTyCon (Special HsListCon)) = TC (list tcl)+-}+thTypeToType' _ ArrowT = error "Partially applied (->)."+thTypeToType' _ (VarT name) = nameToVarType name+-- thTypeToType' _ hst = error ("thTypeToType': "++show hst)++nameToVarType name = strToVarType (showTypeName name)++{- tcKindðp~·éÌÅDÜCtcKindªÈÄàhigher-order kindÅȯêÎgbvxÌkind©ç_Å«éµD+-- copied from svn/MagicHaskeller/memodeb/RandomFilter.hs+typeToTHType :: TyConLib -> Types.Type -> TH.Type+typeToTHType tcl ty = TH.ForallT (map tvToName $ tyvars ty) [] (typeToTHType' tcl ty)+typeToTHType' (_,ar) (TC tc) | tcid >= 0 = TH.ConT (TH.mkName $ fst ((ar ! tcKind tc) !! tcid))+ where tcid = tcID tc+typeToTHType' tcl (TV tv) = TH.VarT $ tvToName tv+typeToTHType' tcl (TA t0 t1) = TH.AppT (typeToTHType' tcl t0) (typeToTHType' tcl t1)+typeToTHType' tcl (t0:->t1) = TH.AppT (TH.AppT TH.ArrowT (typeToTHType' tcl t0)) (typeToTHType' tcl t1)+typeToTHType' tcl (t0:> t1) = TH.AppT (TH.AppT sectionedArrow (typeToTHType' tcl t0)) (typeToTHType' tcl t1)+tvToName = TH.mkName . return . chr . (+ ord 'a') . tvID+-}+typeToTHType :: TyConLib -> Types.Type -> TH.Type+typeToTHType tcl ty = (case tyvars ty of [] -> id+ tvs -> TH.ForallT (map tvToName $ nub tvs) [])+ (typeToTHType' tcl 0 ty)+typeToTHType' (_,ar) k (TC tc) | tc >= 0 = TH.ConT (TH.mkName name)+ where name = if inRange (bounds ar) k then fst ((ar ! k) !! tc)+ else 'K':shows k ('I':show tc) -- useful with defaultTCL +typeToTHType' tcl _ (TV tv) = TH.VarT $ tvToName tv+typeToTHType' tcl k (TA t0 t1) = TH.AppT (typeToTHType' tcl (k+1) t0) (typeToTHType' tcl 0 t1)+typeToTHType' tcl 0 (t0:->t1) = TH.AppT (TH.AppT TH.ArrowT (typeToTHType' tcl 0 t0)) (typeToTHType' tcl 0 t1)+typeToTHType' tcl 0 (t0:> t1) = TH.AppT (TH.AppT sectionedArrow (typeToTHType' tcl 0 t0)) (typeToTHType' tcl 0 t1)+tvToName = TH.mkName . return . chr . (+ ord 'a')++-- secionedArrow = TH.ConT ''(->) -- ½ª±Á¿ÅàOK+sectionedArrow = TH.ConT (mkName "GHC.Prim.(->)")++{-+Prelude> :module +Language.Haskell.TH+Prelude Language.Haskell.TH> AppT (AppT (ConT $ mkName "GHC.Prim.(->)") (ConT $ mkName "GHC.Base.Int")) (ConT $ mkName "Char")+AppT (AppT (ConT GHC.Prim.(->)) (ConT GHC.Base.Int)) (ConT Char)+Prelude Language.Haskell.TH> AppT (AppT ArrowT (ConT $ mkName "GHC.Base.Int")) (ConT $ mkName "Char")+AppT (AppT ArrowT (ConT GHC.Base.Int)) (ConT Char)+-}++\end{code}
+ MagicHaskeller/ReadTypeRep.hs view
@@ -0,0 +1,69 @@+-- +-- (c) Susumu Katayama 2009+--+module MagicHaskeller.ReadTypeRep where+import Data.Typeable+import MagicHaskeller.Types as Types+import MagicHaskeller.TyConLib+import Data.Array.IArray((!))+import qualified Data.Map(lookup)++import qualified Language.Haskell.TH as TH+++typeToTR :: TyConLib -> Type -> TypeRep+typeToTR tcl ty = tyToTR tcl 0 ty+tyToTR :: TyConLib -> Kind -> Type -> TypeRep+tyToTR _ 0 (TV _) = typeOf 'c' -- ¤á¤ó¤É¤¯¤µ¤¤¤Î¤Ç¤È¤ê¤¢¤¨¤ºChar+tyToTR (_,ar) k (TC tc) | tc >= 0 = mkTyConApp (mkTyCon $ fst ((ar!k) !! tc)) []+ | otherwise = error "tyToTR: impossible (tc<0)."+tyToTR tcl k (TA a b) = mkAppTy (tyToTR tcl (k+1) a) (tyToTR tcl 0 b)+tyToTR tcl 0 (a :-> b) = mkFunTy (tyToTR tcl 0 a) (tyToTR tcl 0 b)++-- ¤È¤ê¤¢¤¨¤º¤ÏFake¤Ç¤Ê¤¤Dynamic¤Ç¤Îtype check¤Ë»È¤¦¤À¤±¤Ê¤Î¤Ç¡¤¸úΨ¤Ï¹Í¤¨¤Ê¤¯¤Æ¤è¤¤¡¥+-- ¤Ç¤â¤Þ¤¢¡¤monomorphic¸ÂÄê¤Ê¤éTypeRep¤ÎÊý¤¬Â®¤¤¤ß¤¿¤¤¡Ê¡©¡Ë¡¥¥½¡¼¥¹¤ò¸«¤¿´¶¤¸¡¤Æäˡ¤equality¤Ë´Ø¤·¤Æ¤Ï¸úΨŪ¤Ê¼ÂÁõ¤ò¤ä¤Ã¤Æ¤ë¤ß¤¿¤¤¡¥++{- -- ´Ö°ã¤Ã¤Æ¤â¤¦°ì²óƱ¤¸¤â¤Î¤òºî¤Ã¤Æ¤·¤Þ¤Ã¤¿¡¥kind¤Ë´Ø¤·¤Æ¤ÏtcID¤ò»È¤Ã¤¿Êý¤¬¤¤¤¤¤«¤â¡©+typeToTR :: TyConLib -> Type -> TypeRep+typeToTR _ (TV _) = typeOf 'c' -- ¤á¤ó¤É¤¯¤µ¤¤¤Î¤Ç¤È¤ê¤¢¤¨¤ºChar+typeToTR (_,ar) (TC tc) | tcid >= 0 = mkTyConApp (mkTyCon $ fst ((ar ! tcKind tc) !! tcid)) []+ | otherwise = error "tyToTR: impossible (tcid<0)."+ where tcid = tcID tc+typeToTR tcl (TA f a) = mkAppTy (typeToTR tcl f) (typeToTR tcl a)+typeToTR tcl (a :-> r) = mkFunTy (typeToTR tcl a) (typeToTR tcl r)+-}++trToType :: TyConLib -> TypeRep -> Types.Type+trToType tcl tr = case splitTyConApp tr of+ (tc,trs) -> (if tc == funTyCon || show tc == show funTyCon -- dunno why, but sometimes |tc==funTyCon| is not enough.+ then trToType tcl (head trs) :-> trToType tcl (head (tail trs))+ else foldl TA (TC $ fromJust $ Data.Map.lookup (tyConString' tc) (fst tcl)) (map (trToType tcl) trs))+ where fromJust (Just x) = x+ fromJust Nothing = error (tyConString' tc ++ " does not appear in the component library. (This is a known bug.) For now, please use a type variable instead of "++show tc+ ++ " and use `matching :: Int -> Memo -> TH.Type -> [[TH.Exp]]'.\n(or maybe you forgot to set a component library?)")+-- fromJust Nothing = error ("tyConString = "++show (tyConString' tc) ++ ", and fst tcl = "++show (fst tcl))+-- fromJust Nothing = error (show tc ++ " does not appear in the component library. Forgot to set one? BTW tc==funTyCon is "++show (tc==funTyCon)++" and funTyCon is "++show funTyCon)+ tyConString' tc = case tyConString tc of+ str@(',':_) -> '(':str++")" -- tyConString mistakenly prints "," instead of "(,)".+ str -> unqualify str+ -- Use the unqualified name to avoid confusion+ -- because Data.Typeable.tyConString shows the unqualified name+ -- for types defined in the Standard Hierarchical Library+ -- (though the qualified name is shown when Typeable is derived).+ unqualify :: String -> String+ unqualify = reverse . takeWhile (/='.') . reverse++-- Do the following, because (mkTyCon "(->)") may or may not be equivalent to TyCon for functions in general.+funTyCon :: Data.Typeable.TyCon+funTyCon = typeRepTyCon (mkFunTy undefTC undefTC)+-- undef = error "funTyCon" -- Dunno why, but seemingly mkFunTy is strict.+undefTC = mkTyConApp (mkTyCon "Hoge") []++trToTHType :: TypeRep -> TH.Type+trToTHType tr = case splitTyConApp tr of+ (tc,trs) -> if tc == funTyCon || show tc == show funTyCon -- dunno why, but sometimes |tc==funTyCon| is not enough.+ then TH.AppT TH.ArrowT (trToTHType (head trs)) `TH.AppT` trToTHType (head (tail trs))+ else foldl TH.AppT (TH.ConT (TH.mkName (tyConString tc))) (map trToTHType trs)+ where tyConToName str = case tyConString str of "[]" -> TH.ListT+ str@(',':_) -> TH.TupleT (length str) -- tyConString mistakenly prints "," instead of "(,)".+ str -> TH.ConT $ TH.mkName str
+ MagicHaskeller/T10.hs view
@@ -0,0 +1,99 @@+-- +-- (c) Susumu Katayama 2009+--+module MagicHaskeller.T10 where+import Control.Monad+import MagicHaskeller.CoreLang+-- import PriorSubsts+import Data.List(partition, sortBy)+import Data.Monoid++import MagicHaskeller.Types++liftList :: MonadPlus m => [a] -> m a+liftList = msum . map return+++-- Was: scan10 = mapDepth tokoro10 . scanl1 (++)+scan10 (xs:xss) = scanl (\x y -> tokoro10 (x ++ y)) (tokoro10 xs) xss++-- mergesortWithBy const cmp = map head . groupBy (\x y -> cmp x y == EQ) . sortBy cmp, except that mergesortWithBy is quicker when the domain includes lots of duplicates.+-- (If there are no duplicates, implementation with sortBy should be quicker.)+-- Implementation of mergesort by Ian Lynagh which is found in GHC distributions was useful for implementing this.+mergesortWithBy :: (k->k->k) -> (k->k->Ordering) -> [k] -> [k]+mergesortWithBy op cmp = mergesortWithByBot op (\x y -> Just (cmp x y))++mergesortWithByBot :: (k->k->k) -> (k -> k -> Maybe Ordering) -> [k] -> [k]+mergesortWithByBot op cmp = mergesortWithByBot' op cmp . map return++mergesortWithByBot' :: (k->k->k) -> (k -> k -> Maybe Ordering) -> [[k]] -> [k]+mergesortWithByBot' op cmp [] = []+mergesortWithByBot' op cmp [xs] = xs+mergesortWithByBot' op cmp xss = mergesortWithByBot' op cmp (merge_pairsBot op cmp xss)++merge_pairsBot :: (k->k->k) -> (k -> k -> Maybe Ordering) -> [[k]] -> [[k]]+merge_pairsBot op cmp [] = []+merge_pairsBot op cmp [xs] = [xs]+merge_pairsBot op cmp (xs:ys:xss) = mergeWithByBot op cmp xs ys : merge_pairsBot op cmp xss+++mergeWithBy :: (k->k->k) -> (k->k->Ordering) -> [k] -> [k] -> [k]+mergeWithBy op cmp = mergeWithByBot op (\x y -> Just (cmp x y))++-- cmp returns Nothing when the comparison causes time-out.+mergeWithByBot :: (k->k->k) -> (k -> k -> Maybe Ordering) -> [k] -> [k] -> [k]+mergeWithByBot op cmp xs [] = xs+mergeWithByBot op cmp [] ys = ys+mergeWithByBot op cmp (x:xs) (y:ys)+ = case x `cmp` y of+ Just GT -> y : mergeWithByBot op cmp (x:xs) ys+ Just EQ -> x `op` y : mergeWithByBot op cmp xs ys+ Just LT -> x : mergeWithByBot op cmp xs (y:ys)+ Nothing -> mergeWithByBot op cmp xs ys+-- Actually it is questionable if we may remove both of the expressions compared just because comparison between them fails, because only one of them might be responsible.++-- filters only emptySubst+tokoro10nil :: Eq k => [([a],[k],i)] -> [([a],[k],i)]+tokoro10nil xs = case partition (\ (_,k,_) -> k==[] ) xs of+ ([], diff) -> diff+ (same@((_,_,i):_), diff) -> (concat (map (\ (a,_,_) -> a) same), [], i) : diff+{-+-- $B$A$c$s$H7W;;$7$F$J$$$1$I!$(BO(n^2)$B$/$i$$!)(B $B$?$@!$MWAG?t(Bn$B$O>/$J$$$C$]$$$N$G$3$C$A$NJ}$,B.$$$+$b(B+tokoro10 :: Eq k => [([a],k,i)] -> [([a],k,i)]+tokoro10 [] = []+tokoro10 ((es,k,i):xs) = case partition (\ (_,k',_) -> k==k' ) xs of+ (same, diff) -> (es ++ concat (map (\ (a,_,_) -> a) same), k, i) : tokoro10 diff+-}+{- quicksort$B$NJQ7A(B+tokoro10 :: (Eq k, Ord k) => [([a],k,i)] -> [([a],k,i)]+tokoro10 [] = []+tokoro10 ((t@(x,k,i)):ts) = case partition3 k ts of (ls,es,gs) -> tokoro10 ls ++ (x ++ concat es, k, i) : tokoro10 gs+partition3 :: (Eq k, Ord k) => k -> [(a,k,i)] -> ([(a,k,i)],[a],[(a,k,i)])+-- {-# INLINE partition3 #-}+partition3 k ts = foldr (select3 k) ([],[],[]) ts+select3 k t@(x,k',_) (ls,es,gs) = case k' `compare` k of LT -> (t:ls, es, gs)+ EQ -> ( ls, x:es, gs)+ GT -> ( ls, es, t:gs)+-}++-- merge sort could be much faster.+tokoro10 :: (Monoid a, Eq k, Ord k) => [(a,k,i)] -> [(a,k,i)]+tokoro10 = mergesortWithBy (\(xs,k,i) (ys,_,_) -> (xs `mappend` ys, k, i)) (\ (_,k,_) (_,l,_) -> k `compare` l)+{- sort$B$O$7$J$$$1$I!$<B$O$3$C$A$NJ}$,8zN($,0-$$$N$G$O(B? $BD9$5$KBP$7$F(B2$B>h$N%*!<%@!<$K$J$j$=$&!%%=!<%H$9$l$P!$(BO(n log n)$B!J8eH>$O(BO(n)$B$G$9$_$=$&!K$7$+$b!$(B(\\\)$B$r;H$&$K$O%=!<%H$7$F$J$$$H$@$a!%(B+tokoro10 :: (Eq k, Ord k) => [([a],k,i)] -> [([a],k,i)]+tokoro10 ((t@(xs,k,i)):ts) = case partition (\ (_,k',_) -> k'==k) ts of (es,ns) -> (xs ++ concat (map (\ (a,_,_) -> a) es), k, i) : tokoro10 ns+-}++tkr10 :: [(Type,Int)] -> [(Type,[Int])]+tkr10 = mergesortWithBy (\ (k,is) (_,js) -> (k,is++js)) (\ (k,_) (l,_) -> k `compare` l) . map (\(k,i)->(k,[i]))++-- Moved from DebMT.lhs+-- ? means Maybe+[] !? n = Nothing+(x:xs) !? 0 = Just x+(x:xs) !? n = xs !? (n-1)+++-- nlambda n e = iterate Lambda e !! n$B$NJ}$,H~$7$$!)8zN($O!)(B+nlambda 0 e = e+nlambda n e = Lambda $ nlambda (n-1) e
+ MagicHaskeller/TimeOut.hs view
@@ -0,0 +1,94 @@+-- +-- (c) Susumu Katayama 2009+--+module MagicHaskeller.TimeOut where++import Control.Concurrent(forkIO, killThread, myThreadId, ThreadId, threadDelay, yield)+import Control.Concurrent.SampleVar+import Control.Exception(catch, Exception(..))+-- import System.Posix.Unistd(getSysVar, SysVar(..))+-- import System.Posix.Process(getProcessTimes, ProcessTimes(..))+-- import System.Posix.Types(ClockTick)+import System.CPUTime+import System.IO.Unsafe(unsafePerformIO)+import Control.Monad(when)++import System.IO++import Debug.Trace -- This IS necessary to monitor errors in the subprocs.++-- import Timeout++-- ¥½¡¼¥¹¤ò¤ß¤¿´¶¤¸¡¤MVar¤äSampleVar¤òºî¤ëoverhead¤Ï̵»ë¤Ç¤¤½¤¦¡¥+-- data CHTO a = CHTO {timeInMicroSecs :: Int, sv :: SampleVar (Maybe a)}++{-+unsafeEvaluate :: Int -> a -> Maybe a+unsafeEvaluate t e = unsafePerformIO (withTO t (return e)) -- Should I use Control.Exception.evaluate? I do not want to evaluate long lists deeply. +-}++maybeWithTO :: (a -> IO () -> IO ()) -- ^ seq or deepSeq(=Control.Parallel.Strategies.sforce). For our purposes seq is enough, because @a@ is either 'Bool' or 'Ordering'.+ -> Maybe Int -> IO a -> IO (Maybe a)+maybeWithTO sq mbt action = maybeWithTO' sq mbt (const action)++maybeWithTO' :: (a -> IO () -> IO ()) -> Maybe Int -> ((IO b -> IO b) -> IO a) -> IO (Maybe a)+maybeWithTO' _ Nothing action = do a <- action id+ return (Just a)+maybeWithTO' dsq (Just t) action = withTO' dsq t action+--maybeWithTO' dsq (Just t) action = timeout t (action undefined) -- System.Timeout.timeout¤ò»È¤¦¤È®¤¯¤Ê¤ë¡¥++-- 'withTO' creates CHTO every time it is called. Currently unused.+-- withTO :: DeepSeq a => Int -> IO a -> IO (Maybe a)+-- withTO timeInMicroSecs action = withTO' deepSeq timeInMicroSecs (const action)+withTO' :: (a -> IO () -> IO ()) -> Int -> ((IO b -> IO b) -> IO a) -> IO (Maybe a)+withTO' dsq timeInMicroSecs action+ = do -- clk_tck <- getSysVar ClockTick+ -- let ticks = fromInteger (clk_tck * toInteger timeInMicroSecs `div` 1000000)+ resSV <- newEmptySampleVar+ do+ forkIO (catchIt resSV (do+ tid <- myThreadId+ chtid <- forkIO (do threadDelay timeInMicroSecs+ -- wait deadline -- this line makes sure that timeInMicroSecs has really passed in the process time, but I guess this has no sense, because userTime is shared among Concurrent Haskell threads.+ writeSampleVar resSV Nothing+ killThread tid)+ -- res <- action (catchYield tid resSV)+ res <- action (yield>>)+ res `dsq` writeSampleVar resSV (Just res)+ killThread chtid))+ readSampleVar resSV++wrapExecution = id+--wrapExecution = measureExecutionTime++measureExecutionTime act+ = do begin <- getCPUTime+ res <- act+ end <- getCPUTime+ hPutStrLn stderr (show (end - begin))+ return res++-- Catch exceptions such as stack space overflow+catchIt :: (SampleVar (Maybe a)) -> IO () -> IO ()+catchIt sv act = Control.Exception.catch act (handler sv)+-- catchIt sv act = act -- disable++handler sv err = Control.Exception.catch (realHandler sv err) (handler sv)+-- realHandler sv (AsyncException ThreadKilled) = return () -- If the thread is killed by ^C (i.e. not by another thread), sv is left empty. So, the parent thread can catch ^C while waiting.+#ifdef REALDYNAMIC+-- realHandler sv err = trace (show err) $ writeSampleVar sv Nothing+realHandler sv (ErrorCall str) = trace str $ writeSampleVar sv Nothing+#endif+realHandler sv err = writeSampleVar sv Nothing++catchYield tid sv action = Control.Exception.catch (yield >> action) (childHandler tid sv)+childHandler tid sv err = Control.Exception.catch (realChildHandler tid sv err) (childHandler tid sv)+realChildHandler tid sv err = do writeSampleVar sv Nothing+ killThread tid+ error "This thread must have been killed...."+{-+wait deadline = do ticksNow <- getProcessTimes+ let tickNow = userTime ticksNow+ when (tickNow < deadline) $ do threadDelay 20000+ wait deadline+-}
+ MagicHaskeller/TyConLib.hs view
@@ -0,0 +1,68 @@+-- +-- (c) Susumu Katayama 2009+--+module MagicHaskeller.TyConLib where+import qualified Data.Map as Map+import MagicHaskeller.Types+import Data.Array.IArray+import qualified Language.Haskell.TH as TH+import Data.List(nub)++type Map = Map.Map++type TyConLib = (Map TypeName TyCon, Array Kind [(TypeName,TyCon)])++defaultTCL = tyConsToTCL defaultTyCons++tyConsToTCL :: [(Kind, TypeName)] -> TyConLib+tyConsToTCL tcs+ = (Map.fromListWith (\new old -> old) [ tup | k <- [0..7], tup <- tcsByK ! k ], tcsByK)+ where tnsByK :: Array Kind [TypeName]+ tnsByK = accumArray (flip (:)) [] (0,7) (reverse (nub tcs))+ tcsByK :: Array Kind [(TypeName,TyCon)]+ tcsByK = listArray (0,7) [ tnsToTCs (tnsByK ! k) | k <- [0..7] ]+ tnsToTCs :: [TypeName] -> [(TypeName,TyCon)]+ tnsToTCs tns = zipWith (\ i tn -> (tn, i)) [0..] tns+++ -- other info is used when adding type constructors as functions+-- listToFM_C op = addListToFM_C op emptyFM -- moved to XFiniteMap+{-+defaultTyCons :: Kind -> [TypeName]+defaultTyCons 0 = ["()", "Char", "Integer", "Int", "Double", "Float", "Bool"]+defaultTyCons 1 = ["[]", "IO"]+defaultTyCons i | i<=7 = tuplename i+-}+defaultTyCons :: [(Kind, TypeName)]+defaultTyCons = [(0, "()"), (1, "[]")] ++ [ (i, tuplename i) | i<-[2..tupleMax] ] ++ [(0, "Int"), (0, "Char"), (0, "Bool"), (0, "Integer"), (0, "Double"), (0, "Float"), (1,"Maybe"), (1,"IO"), (2,"Either"), (0,"Ordering"), (1,"Gen")]+tupleMax = 7+{- can be used at least with lthprof+defaultTyCons = []+tupleMax = 0+-}++tuplename i = '(':replicate (i-1) ',' ++")"++unit tcl = nameToTyCon tcl "()"+list tcl = nameToTyCon tcl "[]"+disj tcl = nameToTyCon tcl "Either"+tuple tcl n = nameToTyCon tcl (tuplename n)++nameToTyCon :: TyConLib -> String -> TyCon+nameToTyCon (fm,_) name = case Map.lookup name fm of+ Nothing -> error "nameToTyCon: unknown TyCon"+ Just c -> c++thTypesToTCL thts = tyConsToTCL (thTypesToTyCons thts ++ defaultTyCons)+thTypesToTyCons :: [TH.Type] -> [(Kind,TypeName)]+thTypesToTyCons thtys = [ tycon | thty <- thtys, tycon <- thTypeToTyCons 0 thty ]++thTypeToTyCons :: Kind -> TH.Type -> [(Kind,TypeName)]+thTypeToTyCons k (TH.ForallT names _cxt t) = thTypeToTyCons k t+thTypeToTyCons k (TH.AppT t u) = thTypeToTyCons (k+1) t ++ thTypeToTyCons 0 u+thTypeToTyCons 2 TH.ArrowT = []+thTypeToTyCons 1 TH.ListT = [(1, "[]")] -- It should be in defaultTyCons+thTypeToTyCons _ (TH.VarT _name) = []+thTypeToTyCons k (TH.ConT qname) = [(k, show qname)]+thTypeToTyCons 0 (TH.TupleT i) = [(i, tuplename i)]+thTypeToTyCons k tht = error ("thTypeToTyCons :: Kind error. k = "++show k++" and tht = "++TH.pprint tht)
+ MagicHaskeller/Types.lhs view
@@ -0,0 +1,384 @@+-- +-- (c) Susumu Katayama 2009+--++\begin{code}+++{-# OPTIONS -cpp -funbox-strict-fields #-}+module MagicHaskeller.Types(Type(..), Kind, TyCon, TyVar, TypeName, Class(..), Typed(..), tyvars, Subst, plusSubst, + emptySubst, apply, mgu, varBind, match, maxVarID, normalizeVarIDs, normalize, + Decoder(..), typer, typee, negateTVIDs, limitType, quantify, unquantify, lookupSubst, unifyFunAp,+ alltyvars, mapTV, size, unitSubst, applyCheck, assertsubst, substOK, eqType, getRet, getArity, splitArgs, getArgs, pushArgs, popArgs, mguFunAp, strToVarType, revSplitArgs, splitArgsCPS, bakaHash+ ) where+import Data.List+import Control.Monad+import Data.Char(ord)+#ifdef QUICKCHECK+import Test.QuickCheck -- this is since 6.4+-- import Debug.QuickCheck+#endif++-- import Debug.Trace++infixr :->, :>++trace _ = id+++{- Heap profiling with -hy (i.e. by types) flag the -O0 code shows Type (and TyVar) could be improved (by using #Int's),+ but still I think that is not essential. I think recomputation (without memoization) and improvement in Runnable.hs should be tried.+-}+++-- :> is same as :-> except FMType.lhs assumes it is a type constructor.+data Type = TV !TyVar | TC !TyVar | TA Type Type | Type :> Type | Type :-> Type+ deriving (Eq, Ord, Read)++size :: Type -> Int+size (TC _) = 1+size (TV _) = 1 -- but potentially large.+size (TA t0 t1) = size t0 + size t1+size (t0 :> t1) = size t0 + size t1+size (t0 :-> t1) = size t0 + size t1++{-+-- sizeCheck is normally id, but if the size is too large it fails.+sizeCheck :: Type -> Type+sizeCheck ty = sc 100 ty+ where sc 0 _ = error ("sizeCheck: " ++ show ty)+ sc n (TA t0 t1) = +-}++{- I comment this out because this is unused (except in Classification.tex, where arityOf is redefined) and confusing along with |:>|.+arityOf :: Type -> Int+arityOf (t1 :-> t0) = 1 + arityOf t0+arityOf _ = 0 -- including :>+-}++#ifdef QUICKCHECK+instance Arbitrary Type where+ arbitrary = sized arbType++arbType 0 = oneof [liftM TV arbitrary, liftM TC arbitrary]+arbType n = frequency [ (8, arbType 0),+ (2, liftM2 TA (arbType (n `div` 2)) (arbType (n `div` 2))),+ (2, liftM2 (:->) (arbType (n `div` 2)) (arbType (n `div` 2))) ]+#endif++-- {-# INLINE mapTV #-}+mapTV :: (TyVar -> TyVar) -> Type -> Type+mapTV f t = -- if t/=t then undefined else+ mtv t+ where mtv (TA t0 t1) = TA (mtv t0) (mtv t1)+ mtv (t1 :-> t0) = (mtv t1) :-> (mtv t0)+ mtv (t1 :> t0) = (mtv t1) :> (mtv t0)+ mtv (TV tv) = TV (f tv)+ mtv tc@(TC _) = tc++negateTVIDs :: Type -> Type+negateTVIDs = mapTV (\tvid -> -1 - tvid)++-- limitType is like counting the size of a type, but is specialised to limit it.+limitType n (TC _) = n-1+limitType n (TV _) = n-1+limitType n (u :-> t) = lt n t u+limitType n (u :> t) = lt n t u+limitType n (TA t u) = lt n t u++lt n t u = case limitType n t of m | m > 0 -> limitType m u+ | otherwise -> -1++alltyvars :: Type -> Subst -> [TyVar]+alltyvars ty s = alltyvars' ty s []+alltyvars' :: Type -> Subst -> [TyVar] -> [TyVar]+alltyvars' (TV tv) s = case lookupSubst s tv of Just t -> alltyvars' t s+ Nothing -> (tv:)+alltyvars' (TC tc) s = id+alltyvars' (TA t u) s = alltyvars' t s . alltyvars' u s+alltyvars' (u :> t) s = alltyvars' t s . alltyvars' u s+alltyvars' (u :-> t) s = alltyvars' t s . alltyvars' u s++-- These can sometimes be VERY time-consuming, because they are used by mgu, varBind, etc.+{-# INLINE tyvars #-}+{-# INLINE tyvars' #-}+tyvars :: Type -> [TyVar]+tyvars ty = tyvars' ty []+tyvars' :: Type -> [TyVar] -> [TyVar]+tyvars' (TV tv) = (tv:)+tyvars' (TC tc) = id+tyvars' (TA t u) = tyvars' t . tyvars' u+tyvars' (u :> t) = tyvars' t . tyvars' u+tyvars' (u :-> t) = tyvars' t . tyvars' u++-- use this instead of QType+maxVarID :: Type -> TyVar+maxVarID (TV tv) = tv+maxVarID (TC _) = -1 -- assume non-negative.+maxVarID (TA t u) = maxVarID t `max` maxVarID u+maxVarID (t :> u) = maxVarID t `max` maxVarID u+maxVarID (t :-> u) = maxVarID t `max` maxVarID u+{- higher-order kind$B$O9M$($J$$$H$$$&$+!$(B(*->*)->*$B$H(B*->*$B$r6hJL$7$J$$!J7?0z?t$N?t$N$_9MN8$9$k!K!%$=$N>e$G!$(Btype Kind = Int$B$H$9$k!%(BMemo$B$9$k$H$-$K(BKind$B$G(Bindex$B$7$?$$$C$F$N$H!$7?0z?t$N(BKind$B$O?dO@$G$-$J$$$N$G!%(B++$B$d$C$Q@53N$K$O!$!V(B(*->*)->*$B$H(B*->*$B$r6hJL$7$J$$!W$G$O$J$/!$!V(B(*->*)->* (higher order kind)$B$rG'$a$J$$!W$H$$$&$Y$-!%(B+TyApp t u$B$K$*$$$F!$(Bu::*$B$r2>Dj$7$F$7$^$C$F$$$k$N$G!%(B++data Kind = Star | Kind ::-> Kind deriving (Show, Eq, Ord, Read)+instance Arbitrary Kind where+ arbitrary = sized arbKind++arbKind 0 = return Star+arbKind n = frequency [ (4, return Star),+ (1, liftM2 (::->) (arbKind (n `div` 2)) (arbKind (n `div` 2))) ]+-}+type Kind = Int++ -- comparison between cs and ds is done in TypeLib, comparing types of different vars.++type TyVar = Int+type TyCon = Int++type TypeName = String++data Class = Cl Int TypeName [Type] deriving (Show, Ord, Eq, Read)++mapCls :: (Type -> Type) -> [Class] -> [Class]+mapCls f cs = [ Cl i n (map f ts) | Cl i n ts <- cs ]++-- Encoder and Decoder are partly moved to FMType.lhs++-- TyVar should be shared, so it is returned by the decoder.+-- $B$"$H!"(BdecoList$B$O$R$@$j$+$i$_$.$K$N$S$F$$$C$?$[$&$,$$$$$N$+!)(B++data Decoder = Dec [TyVar] Int+ deriving Show++{-# INLINE normalizeVarIDs #-}+-- FMType$B!$(BMemoTree$B$J$I$G(Bindex$B$9$k$H$-$N$?$a$K!$(BvarID$B$r(B0,1,...$B$K(Broot$BB&$+$i=g$K@55,2=$9$k(B+normalizeVarIDs :: Type -> Int -> (Type, Decoder)+normalizeVarIDs ty mx = let decoList = sieve $ tyvars ty+ tup = zip decoList [0..]+ encoType = mapTV (\tv -> case lookup tv tup of Just n -> n) ty+ len = length decoList+ margin = -- trace ("normalizeVarIDs: mx == "++show mx++ " and len = " ++ show len) $+ mx + 1 - len+ in -- trace ("len = " ++ show len) $ $B$[$H$s$I$N%1!<%9$G(B0$B$+(B1$B!$$?$^!<$K(B2$B$+(B3+ (encoType, Dec decoList margin)+ where sieve [] = []+ sieve (x:xs) = x : sieve [ y | y <- xs, y /= x ]+normalize ty = fst $ normalizeVarIDs ty (error "undef of normalize")++eqType :: Type -> Type -> Bool+eqType t0 t1 = normalize t0 == normalize t1+++-- quantify freezes tyvars into tycons whose IDs are negative.+quantify, quantify', unquantify :: Type -> Type+quantify ty = quantify' (normalize ty)+quantify' (TV iD) = TC (-iD-1)+quantify' tc@(TC _) = tc+quantify' (TA t u) = TA (quantify' t) (quantify' u)+quantify' (u :-> t) = quantify' u :-> quantify' t+quantify' (u :> t) = quantify' u :> quantify' t++-- unquantify is used only as a preprocessor of normalize, when used as a preprocessor of quantify. See notes on Nov. 17, 2006.+unquantify (TC tc) | tc < 0 = TV tc+unquantify (TA t u) = TA (unquantify t) (unquantify u)+unquantify (u :-> t) = unquantify u :-> unquantify t+unquantify (u :> t) = unquantify u :> unquantify t+unquantify t = t++{-+mbQuantify ty = return (quantify ty)+-}+{-+encodeSubst :: Encoder -> Subst -> Subst+encodeSubst = plusSubst+-}+unifyFunAp str t u = case uniFunAp t u of Just v -> trace (str ++ ". unify "++show t ++" and "++show u) v+ Nothing -> error (str ++ ". unifyFunAp: t = "++show t++", and u = "++show u)+uniFunAp :: MonadPlus m => Type -> Type -> m Type+uniFunAp (a:->r) t = do subst <- mgu (getRet a) (getRet t)+ return (apply subst r)+uniFunAp f t = mzero -- error ("uniFunAp: f = "++show f++" and t = "++show t)+++mguFunAp :: MonadPlus m => Type -> Type -> m Type+mguFunAp t0 t1 = trace ("mguFunAp t0 = "++ show t0++", and t1 = "++show t1) $+ case maxVarID t1 + 1 of mx -> mfa (mapTV (mx+) t0) t1+mfa (a:->r) t = do subst <- mgu a t+-- return (apply subst r)+ let retv = (apply subst r)+ trace ("retv = "++show retv) $ return retv+mfa (a:>r) t = mfa (a:->r) t -- mguFunAp is only used by PolyDynamic+mfa t@(TV _) _ = return t -- mguFunAp assumes different name spaces+mfa f t = mzero++++pushArgsCPS :: (Int -> [Type] -> Type -> a) -> [Type] -> Type -> a+pushArgsCPS f = pa 0+ where + pa n args (t0:->t1) = pa (n+1) (t0:args) t1+ pa n args (t0:>t1) = pa (n+1) (t0:args) t1+ pa n args retty = f n args retty++pushArgs :: [Type] -> Type -> ([Type],Type)+pushArgs = pushArgsCPS (\i a r -> (a,r))++getRet = pushArgsCPS (\i a r -> r) []+getArgs = pushArgsCPS (\i a r -> a) []+getArity = pushArgsCPS (\i _ _ -> i) undefined++splitArgsCPS :: (Int -> [Type] -> Type -> a) -> Type -> a+splitArgsCPS f = pushArgsCPS f []++splitArgs :: Type -> ([Type],Type)+splitArgs = pushArgs []++-- $B5U=g$K@Q$s$G$$$/(B+revSplitArgs :: Type -> (Int,[Type],Type)+revSplitArgs (t0:->t1) = case revSplitArgs t1 of (n,args,ret) -> (n+1, t0:args, ret)+revSplitArgs t = (0, [], t)++popArgs :: [Type] -> Type -> Type+popArgs = flip (foldl (flip (:->)))++{- $B$R$C$/$jJV$5$J$+$C$?%P!<%8%g%s(B+popArgs = flip (foldr (:->))+splitArgs (t0:->t1) = let (ts, t) = splitArgs t1 in (t0:ts, t)+splitArgs t = ([], t)+-}++\end{code}++data "Typed", taken from obsolete/Binding.hs++\begin{code}++data Typed a = a ::: !Type deriving (Show, Eq, Ord)++typee (a ::: _) = a+typer (_ ::: t) = t++\end{code}++\section{Type inference tools}++\begin{code}++type Subst = [(Int,Type)]++showsAssoc [] = id+showsAssoc ((k,v):assocs) = (' ':) . shows k . ("\t|-> "++) . shows v . ('\n':) . showsAssoc assocs++emptySubst = []+unitSubst k e = [(k, e)]+++-- subst$B$K$/$o$($k$H$-$O(B:>$B$r(B:->$B$K$;$M$P$J$i$J$$$,!"(Bapply s (a:>b)$B$O(Bapply s a :> apply s b+match, mgu :: MonadPlus m => Type -> Type -> m Subst++match (l :-> r) (l' :-> r') = match2Ap l r l' r'+{-+match (l :-> r) (l' :> r') = match2Ap l r l' r'+match (l :> r) (l' :-> r') = match2Ap l r l' r'+match (l :> r) (l' :> r') = match2Ap l r l' r'+-}+match (TA l r) (TA l' r') = match2Ap l r l' r'+match (TV u) t = varBind u t+match (TC tc1) (TC tc2) | tc1==tc2 = return emptySubst+match _ _ = mzero++match2Ap l r l' r' = do s1 <- match l l'+ s2 <- match (apply s1 r) r'+ return (s2 `plusSubst` s1)+++-- mgu t t' = mgu' (toChin t) (toChin t')+mgu (l :-> r) (l' :-> r') = mgu2Ap l r l' r'+#ifdef REALDYNAMIC+-- $B5/$3$i$J$$$O$:$@$7!$8zN($r9M$($k$H(B....+mgu (l :-> r) (l' :> r') = mgu2Ap l r l' r'+mgu (l :> r) (l' :-> r') = mgu2Ap l r l' r'+mgu (l :> r) (l' :> r') = mgu2Ap l r l' r'+#endif+mgu (TA l r) (TA l' r') = mgu2Ap l r l' r'+mgu (TV u) t = varBind u t+mgu t (TV u) = varBind u t+mgu (TC tc1) (TC tc2) | tc1==tc2 = return emptySubst+mgu _ _ = mzero++mgu2Ap l r l' r' = do s1 <- mgu l l'+ s2 <- mgu (apply s1 r) (apply s1 r')+ return (s2 `plusSubst` s1)++varBind :: MonadPlus m => TyVar -> Type -> m Subst+varBind u t | t == TV u = return emptySubst+ | u `elem` (tyvars t) = mzero+ | otherwise = return (unitSubst u t)++substOK :: Subst -> Bool+substOK = all (\ (i,ty) -> not (i `elem` (tyvars ty)))+++assertsubst :: String -> Subst -> Subst+assertsubst str = \s -> if substOK s then s else error (str ++ ": assertsubst failed. substitution = " ++ show s)+instance Show Type where+-- classes$B$rI=<($9$k$N$,$a$s$I$$!%:G=i$K$^$H$a$J$-$c%@%a(B? ReadType$B$N$H$3$m$G(BPrinter$B$G$d$C$H$-$c3Z$@$C$?$+$b!%(B+ showsPrec _ ty = toString' 0 ty -- The kind info can be incorrect, because we assume *.+ where toString' k (TV i) = ('a':) . shows i -- can be used to synthesize a generically typed program.+ toString' k (TC i) = ('K':) . shows k . ('I':) . shows i+ toString' k (TA t0 t1) = showParen True (toString' (k+1) t0 . (' ':) . toString' 0 t1) -- mandatory, just in case.+ toString' k (t0 :-> t1) = showParen True (toString' 0 t0 . ("->"++) . toString' 0 t1)+ toString' k (t0 :> t1) = showParen True (("(->) "++) . toString' 0 t0 . (' ':) . toString' 0 t1)++plusSubst :: Subst -> Subst -> Subst+s0 `plusSubst` s1 = [(u, -- if u `elem` tvids t then error "u is in t" else+ -- trace ("in plusSubst, s0="++show s0) $+ applyCheck s0 t) | (u,t) <- s1] ++ s0+++{-+prop_merge t0 t1 u0 u1 = mgu (t0:->t1) (u0:->u1) == ((do s0 <- mgu t0 u0+ s1 <- mgu t1 u1+ symPlus s0 s1) :: [Subst])+-}++-- $B=[4D$7$F$$$k>l9g$O(BplusSubst$B$,(Billegal$B$K$J$j$&$k(B+-- prop_PlusSubst s0 s1 = not (isIllegalSubst s0) && not (isIllegalSubst s1) ==> not (isIllegalSubst (s0 `plusSubst` s1))++-- apply$B$r(Bmap$B$7$?>e$G7k9g$7$J$$$H!$(BvarBind$B$7$?$H$-$KB?CJ3,$N=[4D$r%A%'%C%/$G$-$J$$!%(B+-- s1$B$r$d$C$?$"$H(Bs0$B$r(Bapply++-- applyHoge s t = if isIllegalSubst s then error "Illegal in applyHoge" else apply s t+lookupSubst :: MonadPlus m => Subst -> Int -> m Type+lookupSubst subst i = case lookup i subst of Nothing -> mzero+ Just x -> return x++apply :: Subst -> Type -> Type+apply subst ty = apply' ty+ where apply' tc@(TC _) = tc+ apply' tg@(TV tv)+ = case lookupSubst subst tv of Just tt -> tt+ Nothing -> tg+ apply' (TA t0 t1) = TA (apply' t0) (apply' t1)+ apply' (t0:->t1) = apply' t0 :-> apply' t1+ apply' (t0:>t1) = apply' t0 :> apply' t1++applyCheck subst t = -- trace ("t= " ++ show t ++ " and subst = "++ show subst) $+ apply subst t+++-- moved from ReadType.lhs+++strToVarType str+ = TV (bakaHash str)+-- This is Ok, because eventually normalizeVarIDs will be called. (But there can be Int overflow....) Also, when I coded normalizeVarIDs I assumed the tvIDs are small.+bakaHash [] = 0+bakaHash (c:cs) = ord c + bakaHash cs * 131++undef = [] -- for now++\end{code}
+ Setup.hs view
@@ -0,0 +1,5 @@+-- +-- (c) Susumu Katayama 2009+--+import Distribution.Simple+main = defaultMain