diff --git a/Control/Monad/Search/Combinatorial.lhs b/Control/Monad/Search/Combinatorial.lhs --- a/Control/Monad/Search/Combinatorial.lhs +++ b/Control/Monad/Search/Combinatorial.lhs @@ -1,5 +1,5 @@ -- --- (c) Susumu Katayama 2009 +-- (c) Susumu Katayama -- Combinators for Combinatorial Search: The first part is a slight hack on Spivey 2000. @@ -18,10 +18,11 @@ import Data.Monoid -- Matrix, and any (MonadPlus a) => a, should be a Monoid. #ifdef QUICKCHECK -import Test.QuickCheck +import Test.QuickCheck hiding (shrink) import Data.List(sort) #endif import MagicHaskeller.T10(mergesortWithBy, mergesortWithByBot) +import Control.Monad.State import Data.Array @@ -72,13 +73,7 @@ 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. -[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) @@ -176,7 +171,7 @@ 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$&e$N?<$5$r;H$& Bag (a,Int) -> Bag (b,Int)) -> DBound a -> DBound b zipDepthDB f (DB g) = DB (\d -> f d (g d)) @@ -232,12 +227,18 @@ ndelay i (RcT f) = RcT g where g n | n < i = return mempty | otherwise = f (n-i) +instance (Monad m, Delay m) => Delay (StateT s m) where + delay = mapStateT delay + ndelay n = mapStateT (ndelay n) + 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 + fromDF :: [a] -> m a -- NB: this gives everything the top priority. + toDF :: m a -> [a] -- NB: this drops the info of priority. -- | 'mapDepth' applies a function to the bag at each depth. mapDepth :: (Bag a -> Bag b) -> m a -> m b -- | 'catBags' flattens each bag. @@ -257,6 +258,8 @@ fromMx = concat . unMx toMx = msumMx fromDB (DB f) = [x | d <- [0..], (x,_) <- f d ] + fromDF = id + toDF = id mapDepth f = concat . map (f . (:[])) -- mapDepth /= id, because DepthFst is not a finite Bag but an infinite Stream. catBags = concat mergesortDepthWithBy _ _ = id @@ -267,6 +270,8 @@ fromMx = mxToRc toMx = rcToMx fromDB = toRc + fromDF = listToRc + toDF = fromMx . toMx mapDepth f (Rc g) = Rc (f.g) ifDepth pred (Rc t) (Rc f) = Rc fun where fun depth | pred depth = t depth @@ -278,6 +283,8 @@ fromMx = fromRc . mxToRc toMx = error "no toMx for RecompT" fromDB = fromRc . toRc + fromDF = fromRc . listToRc + toDF = error "no toDF for RecompT" 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 @@ -289,6 +296,8 @@ fromMx = id toMx = id fromDB = toMx + fromDF = msumMx + toDF = concat . unMx 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 @@ -357,12 +366,12 @@ 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 + fromDF xs = DB $ \n -> [ (x,n) | x <- xs ] + toDF = toDF . toMx 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)) diff --git a/Data/Memo.hs b/Data/Memo.hs --- a/Data/Memo.hs +++ b/Data/Memo.hs @@ -1,5 +1,5 @@ -- --- (c) Susumu Katayama 2009 +-- (c) Susumu Katayama -- {-# OPTIONS -fglasgow-exts -cpp #-} module Data.Memo where diff --git a/ExperimIOP.hs b/ExperimIOP.hs new file mode 100644 --- /dev/null +++ b/ExperimIOP.hs @@ -0,0 +1,1074 @@ +-- +-- (C) Susumu Katayama +-- +-- (Typed)IOPairs¾å¤Ç¥Ç¡¼¥¿¤ò¤È¤ë¡¥ghci¾å¤Ç :cmd ¤ò»È¤¤¤Þ¤¯¤ë´¶¤¸¡¥ +{-# LANGUAGE RankNTypes, CPP #-} +module ExperimIOP(module ExperimIOP, module MagicHaskeller.RunAnalytical) where + +import MagicHaskeller.Analytical +#ifdef DEBUG + hiding (rev) +#endif +import MagicHaskeller.Classification(Filtrable) +import MagicHaskeller.RunAnalytical +#ifdef DEBUG + hiding (main) +#endif +import MagicHaskeller.GetTime(batchWrite) + +main = do iop <- runQ andL + let e = getOne iop [] + putStrLn $ pprint e + + +-- Eg. :cmd prepare +prepare :: IO String +prepare = run [":set +s",":m +Language.Haskell.TH","session <- prepareAPI [\"MagicHaskeller\"]"] + +run :: [String] -> IO String +run = return . unlines . echoOn + +-- set of lightweight experiments +batchWriteFile filename = do + session <- prepareAPI ["MagicHaskeller"] + let f :: forall a. (Filtrable a, Typeable a) => Q [Dec] -> (a -> Bool) -> IO () + f = filterGetOne_ session + batchWrite filename [ f addN longAddNPred + , f andL andLPred + , f heaD headPred + , f incr incrPred + , f append appendPred +-- , f allOdd'21 (\\allodd -> allodd [3,3] && not (allodd [2,3]) && allodd [1,3,5] && not (allodd [1,2,4])) +-- , f concat12 (\\concat -> concat [\"abc\",\"\",\"de\",\"fghi\"] == \"abcdefghi\") + , f drop'9 dropPred + , f eq9 eqPred + , f evenpos7 evenposPred +-- , f evens21 (\\evens -> evens [4,6,9,2,3,8,8] == [4,6,2,8,8]) +-- , f fib6 (\\fib -> fib 1 == 1 && fib 2 == 1 && fib 4 == 3 && fib 6 == 8 && fib 8 == 21) + , f iniT initPred + , f oddpos6 oddposPred + , f lasT lastPred + , f lasts lastsPred + , f lens lengthsPred + , f multFst multFstPred + , f multLst multLstPred + , f negateall negateAllPred + , f reversE revPred + , f shiftl shiftlPred + , f shiftr shiftrPred + , f snoc snocPred + -- , f suM (\\sum -> sum [7,3,8,5] == 23) + , f swap swapPred + , f switch switchPred + , f takE takePred + , f weave weavePred + ] + + +-- :cmd batch +batch :: IO String +batch = run $ filtGetOne "addN" "longAddNPred" ++ + filtGetOne "andL" "andLPred" + ++ filtGetOne "heaD" "headPred" + ++ filtGetOne "incr" "incrPred" + ++ filtGetOne "append" "appendPred" +-- ++ filtGetOne "allOdd'21" "(\\allodd -> allodd [3,3] && not (allodd [2,3]) && allodd [1,3,5] && not (allodd [1,2,4]))" +-- ++ filtGetOne "concat12" "(\\concat -> concat [\"abc\",\"\",\"de\",\"fghi\"] == \"abcdefghi\")" + ++ filtGetOne "drop'9" "dropPred" + ++ filtGetOne "eq9" "eqPred" + ++ filtGetOne "evenpos7" "evenposPred" +-- ++ filtGetOne "evens21" "(\\evens -> evens [4,6,9,2,3,8,8] == [4,6,2,8,8])" +-- ++ filtGetOne "fib6" "(\\fib -> fib 1 == 1 && fib 2 == 1 && fib 4 == 3 && fib 6 == 8 && fib 8 == 21)" + ++ filtGetOne "iniT" "initPred" + ++ filtGetOne "oddpos6" "oddposPred" + ++ filtGetOne "lasT" "lastPred" + ++ filtGetOne "lasts" "lastsPred" + ++ filtGetOne "lens" "lengthsPred" + ++ filtGetOne "multFst" "multFstPred" + ++ filtGetOne "multLst" "multLstPred" + ++ filtGetOne "negateall" "negateAllPred" + ++ filtGetOne "reversE" "revPred" + ++ filtGetOne "shiftl" "shiftlPred" + ++ filtGetOne "shiftr" "shiftrPred" + ++ filtGetOne "snoc" "snocPred" +-- ++ filtGetOne "suM" "(\\sum -> sum [7,3,8,5] == 23)" + ++ filtGetOne "swap" "swapPred" + ++ filtGetOne "switch" "switchPred" + ++ filtGetOne "takE" "takePred" + ++ filtGetOne "weave" "weavePred" + +untype :: Functor m => m [a] -> m [a] +untype = fmap tail + +-- E.g. :cmd run $ tryGetOne "add6" +tryGetOne :: String -> [String] +tryGetOne str = ["iop <- runQ $ "++str, "let e = getOne iop []", "putStrLn $ pprint e"] + +-- E.g. :cmd run $ tryGetOneBK "add6" [] +-- :cmd run $ tryGetOneBK "fib6" ["add6"] +tryGetOneBK :: String -> String -> [String] +tryGetOneBK str bk = ["iop <- runQ $ "++str, "bk <- runQ $ "++bk, "let e = getOne iop bk", "putStrLn $ pprint e"] +-- E.g. :cmd run $ testGetOne "add6" addArgss +testGetOne :: String -> [String] -> [String] +testGetOne str argss = tryGetOne str ++ map ("$(return e) "++) argss + +-- E.g. :cmd run $ filtGetOne "reversE" "(\\f -> f \"abcdef\" == \"fedcba\")" +filtGetOne :: String -> String -> [String] +filtGetOne str predicate = ["filterGetOne session ("++str++") ("++predicate++")"] +filtGetOneBK :: String -> String -> String -> [String] +filtGetOneBK str bk predicate = ["filterGetOneBK session ("++str++") ("++bk++") ("++predicate++")"] + +emptyBK = [d| {} |] + +-- :cmd run $ filtGetOne "add''" "(\\(+) -> 3+5==8)" +add6 = [d| f :: Int->Int->Int; f 0 0 = 0; f 0 1 = 1; f 1 0 = 1; f 2 0 = 2; f 1 1 = 2; f 0 2 = 2 |] +add'7 = [d| f :: Int->Int->Int; f 0 x = x; f x 0 = x; f 1 1 = 2; f 1 2 = 3; f 2 1 = 3; f 2 2 = 4; f 2 3 = 5 |] -- dame. ¤Ç¤â¡¤Igor¤Ç¤ÏOK. +add'6 = [d| f :: Int->Int->Int; f 0 x = x; f x 0 = x; f 1 1 = 2; f 1 2 = 3; f 2 1 = 3; f 2 2 = 4 |] -- dame +add'5 = [d| f :: Int->Int->Int; f 0 x = x; f x 0 = x; f 1 1 = 2; f 1 2 = 3; f 2 1 = 3 |] -- dame +add'3 = [d| f :: Int->Int->Int; f 0 x = x; f x 0 = x; f 1 1 = 2 |] -- dame +add'2 = [d| f :: Int->Int->Int; f 0 x = x; f x 0 = x |] -- dame ¤É¤¦¤âoverlap¤·¤Æ¤¤¤ë¤Î¤¬¤Þ¤º¤¤¤Î¤Ç¤Ï? ¼«Æ°Åª¤Ëcaseʬ¤±¤¹¤ë¤è¤¦¤Ë¤¹¤ì¤Ð¤è¤¤¡¥ +add'1 = [d| f :: Int->Int->Int; f 0 x = x |] +add'' = [d| f :: Int->Int->Int; f 0 x = x; f 1 0 = 1; f 2 0 = 2; f 1 1 = 2; f 1 2 = 3; f 2 1 = 3; f 2 2 = 4; f 2 3 = 5 |] +addArgss = ["3 5"] + +-- :cmd run $ filtGetOne "addN" "longAddNPred" +addN = [d| + addN :: Int -> [Int] -> [Int] + addN 0 [] = [] + addN 1 [] = [] + addN 2 [] = [] + addN 0 [0] = [0] + addN 0 [1] = [1] + addN 0 [2] = [2] + addN 0 [0,1] = [0,1] + addN 0 [1,0] = [1,0] + addN 1 [0,1] = [1,2] + addN 1 [1,0] = [2,1] + addN 1 [0] = [1] + addN 1 [1] = [2] + addN 1 [2] = [3] + addN 2 [0] = [2] + addN 2 [1] = [3] + addN 2 [2] = [4] + addN 2 [0,1] = [2,3] + addN 2 [2,0] = [4,2] + |] +--batchAddN = do session <- prepareAPI ["MagicHaskeller"] +-- batchWrite "addN.dat" $ map (\n -> filterGetOne session (tunedAddN n) addNPred) [5..22] -- ¤³¤¦½ñ¤¤¤Æ¤Ï¸«¤¿¤â¤Î¤Î¡¤¥¿¥¤¥à¥¢¥¦¥È¤Ï¡© +testAddN = [d| + addN :: Int -> [Int] -> [Int] + addN 0 [] = [] + addN 1 [] = [] + addN 2 [] = [] + |] + +takeFunD n (FunD name clauses : xs) = FunD name (take n clauses) : takeFunD n xs +takeFunD n (x:xs) = x : takeFunD n xs +takeFunD _ [] = [] + +-- 22¤Þ¤Ç¡¥¼ÂºÝ¤Ë¤Ï¡¤[3,6..21]¤Ç¼Â¹Ô¤¹¤ë¤À¤±¤ÇÌÌÇò¤¤´¶¤¸¡¥(3¤È21°Ê³°¤Ï¤¦¤Þ¤¯¤¤¤¯¡¥) +tunedAddN n = fmap (takeFunD n) [d| + addN :: Int -> [Int] -> [Int] + addN 0 [] = [] + addN 1 [] = [] + addN 2 [] = [] + addN 0 [0] = [0] + addN 0 [1] = [1] + addN 0 [2] = [2] + addN 0 [0,0] = [0,0] + addN 0 [0,1] = [0,1] + addN 0 [1,0] = [1,0] + addN 1 [0] = [1] + addN 1 [1] = [2] + addN 1 [2] = [3] + addN 1 [0,0] = [1,1] + addN 1 [0,1] = [1,2] + addN 1 [1,0] = [2,1] + addN 2 [0] = [2] + addN 2 [1] = [3] + addN 2 [2] = [4] + addN 2 [0,0] = [2,2] + addN 2 [0,1] = [2,3] + addN 2 [1,0] = [3,2] + addN 2 [2,0] = [4,2] + |] +addNPred, longAddNPred :: (Int -> [Int] -> [Int]) -> Bool +addNPred addN = addN 3 [5,7] == [8,10] +longAddNPred addN = addN 3 [5,7,2] == [8,10,5] +-- :cmd run $ filtGetOne "andL" "(\\and -> not (and [True,False]) && and [True,True] && and [True,True,True] && not (and [False,True,True]))" +andL = tunedAndL 15 +-- [1,3,7,15,31] +tunedAndL n = fmap (takeFunD n) [d| + andL :: [Bool] -> Bool + andL [] = True + andL [True] = True + andL [False] = False + andL [True,True] = True + andL [True,False] = False + andL [False,True] = False + andL [False,False] = False + andL [True,True,True] = True + andL [False,True,True] = False + andL [True,False,True] = False + andL [True,True,False] = False + andL [True,False,False] = False + andL [False,True,False] = False + andL [False,False,True] = False + andL [False,False,False] = False + andL [True,True,True,True] = True + andL [True,False,True,True] = False + andL [True,True,False,True] = False + andL [True,True,True,False] = False + andL [True,True,False,False] = False + andL [True,False,True,False] = False + andL [True,False,False,True] = False + andL [True,False,False,False] = False + andL [False,True,True,True] = True + andL [False,False,True,True] = False + andL [False,True,False,True] = False + andL [False,True,True,False] = False + andL [False,True,False,False] = False + andL [False,False,True,False] = False + andL [False,False,False,True] = False + andL [False,False,False,False] = False + |] + +andLPred and = not (and [True,False]) && and [True,True] && and [True,True,True] && not (and [False,True,True]) + +allOdd4 = [d| f :: [Int]->Bool; f [] = True; f [x] = odd x; f [x,y] = odd x && odd y; f [x,y,z] = odd x && (odd y && odd z) |] + +-- :cmd run $ filtGetOne "allOdd'21" "longAlloddPred" +allOdd'21 = [d| f :: [Int]->Bool; f [] = True; f [0] = False; f [1] = True; f [2] = False; f [3] = True; + f [0,0] = False; f [0,1] = False; f [0,2] = False; f [0,3] = False; + f [1,0] = False; f [1,1] = True; f [1,2] = False; f [1,3] = True; + f [2,0] = False; f [2,1] = False; f [2,2] = False; f [2,3] = False; + f [3,0] = False; f [3,1] = True; f [3,2] = False; f [3,3] = True |] +-- [1,3,6,10,15] ¤¢¤È¡¤allOdd'21¤Ï¤³¤ì¤é¤òÊñ´Þ¤¹¤ë¡¥ +tunedAllOdd n = fmap (takeFunD n) + [d| f :: [Int]->Bool; f [] = True; f [0] = False; f [0,0] = False; + f [1] = True; f [0,1] = False; f [1,0] = False; + f [2] = False; f [0,2] = False; f [1,1] = True; f [2,0] = False; + f [3] = True; f [0,3] = False; f [1,2] = False; f [2,1] = False; f [3,0] = False |] -- dame + +-- Igor¤Ç¤âcatamorphism extension¤Ê¤·¤Ç¤Ï¤Ç¤­¤Ê¤¤¤Î¤Ç¤¤¤¤¤ä¡¥ +alloddPred allodd = allodd [3,3] && not (allodd [2,3]) && allodd [1,3,5] && not (allodd [1,2,4]) +longAlloddPred allodd = allodd [3,3] && not (allodd [2,3]) && allodd [1,3,5] && not (allodd [3,7,5,1,2]) + +-- Example.hs¤½¤Î¤Þ¤Þ +-- :cmd run $ filtGetOne "append" "appendPred" +append = [d| + appenD :: [a] -> [a] -> [a] + appenD [] x = x + --appenD [][] = [] + appenD [a][] = [a] +--appenD [][c] = [c] +--appenD [][c,d] = [c,d] + appenD [a][c] = [a,c] + appenD [a,b][] = [a,b] +--appenD [] [a,b,c] = [a,b,c] + appenD [a][c,d] = [a,c,d] + appenD [a,b][d] = [a,b,d] + appenD [a,c,d][] = [a,c,d] +--appenD [][a,b,c,d] = [a,b,c,d] + appenD [a,b][c,d] = [a,b,c,d] + appenD [a,b,c][d] = [a,b,c,d] + appenD [a,b,c,d][] = [a,b,c,d] + |] -- ¤¤¤±¤ë +-- [2,4,7,11,16] +tunedAppend n = fmap (takeFunD n) [d| + appenD :: [a] -> [a] -> [a] + appenD [] x = x + --appenD [][] = [] + appenD [a][] = [a] +--appenD [][c] = [c] +--appenD [][c,d] = [c,d] + appenD [a][c] = [a,c] + appenD [a,b][] = [a,b] +--appenD [] [a,b,c] = [a,b,c] + appenD [a][c,d] = [a,c,d] + appenD [a,b][d] = [a,b,d] + appenD [a,c,d][] = [a,c,d] + appenD [a][b,c,d] = [a,b,c,d] + appenD [a,b][c,d] = [a,b,c,d] + appenD [a,b,c][d] = [a,b,c,d] + appenD [a,b,c,d][] = [a,b,c,d] + appenD [a][b,c,d,e] = [a,b,c,d,e] + appenD [a,b][c,d,e] = [a,b,c,d,e] + appenD [a,b,c][d,e] = [a,b,c,d,e] + appenD [a,b,c,d][e] = [a,b,c,d,e] + appenD [a,b,c,d,e][] = [a,b,c,d,e] + |] -- ¤¤¤±¤ë +appendPred (++) = "foo" ++ "bar" == "foobar" +-- :cmd run $ filtGetOne "concat12" "(\\concat -> concat [\"abc\",\"\",\"de\",\"fghi\"] == \"abcdefghi\")" +concat12 = [d| + concaT :: [[a]] -> [a] + concaT [] = [] + concaT [[]] = [] + concaT [[a]] = [a] + concaT [[],[a]] = [a] + concaT [[a],[]] = [a] + concaT [[a],[b]] = [a,b] + concaT [[c,d]]= [c,d] + concaT [[a,b,c]] = [a,b,c] + concaT [[a,b],[c]] = [a,b,c] + concaT [[a],[c,d]] = [a,c,d] + concaT [[a],[b],[c]] = [a,b,c] + concaT [[a,b],[c,d]] = [a,b,c,d] + |] -- dame. igor¤Ç¤â¥À¥á¡¥MH¤À¤È°ì½Ö¡¥ +-- ¤Æ¤æ¡¼¤«¡¤Í×ÁÇ¿ô3¤Ä¤Î¾ì¹ç¤Ë¶õ¥ê¥¹¥È¤¬¤Ê¤«¤Ã¤¿¤ê¤¹¤ëÌõ¤Ç¡¤¤½¤ÎÊÕ·ÏÅýŪ¤ÊÎã¤È¤Ï¤¤¤¨¤Ê¤¤¤Î¤Ç¡¤²¿¤È¤â¸À¤¨¤Ê¤¤¡¥ +tunedConcat n = fmap (takeFunD n) [d| + concaT :: [[a]] -> [a] + concaT [] = [] + concaT [[]] = [] + concaT [[a]] = [a] + concaT [[],[]] = [] + concaT [[],[a]] = [a] + concaT [[a],[]] = [a] + concaT [[a],[b]] = [a,b] + concaT [[c,d]]= [c,d] + concaT [[a,b,c]] = [a,b,c] + concaT [[],[a,b,c]] = [a,b,c] + concaT [[a,b,c],[]] = [a,b,c] + concaT [[a,b],[c]] = [a,b,c] + concaT [[a],[c,d]] = [a,c,d] +-- concaT [[a,b],[c,d]] = [a,b,c,d] +-- concaT [[a],[b],[c]] = [a,b,c] + |] + +concatPred concat = concat ["abc","","de","fghi"] == "abcdefghi" + +allOddArgss = ["[3,1,5]", "[1,3,2]"] + +-- ¤³¤Ã¤Á¤¬tuned +drop12 = [d| droP :: Int -> [a] -> [a] + droP 0 [] = [] + droP 0 [a] = [a] + droP 0 [a,b] = [a,b] + droP 0 [a,b,c] = [a,b,c] + droP 1 [] = [] + droP 1 [a] = [] + droP 1 [a,b] = [b] + droP 1 [a,b,c] = [b,c] + droP 2 [] = [] + droP 2 [a] = [] + droP 2 [a,b] = [] + droP 2 [a,b,c] = [c] + --droP (S (S 1)) [] = [] + --droP (S (S 1)) [a] = [] + --droP (S (S 1)) [a,b] = [] + --droP (S (S 1)) [a,b,c] = [] + |] -- ¤¤¤±¤ë¡¥ +-- :cmd run $ filtGetOne "drop'9" "dropPred" +drop'9 = [d| droP :: Int -> [a] -> [a] + droP 0 x = x + --droP 0 [] = [] + --droP 0 [a] = [a] + + --droP x [] = [] + droP 1 [] = [] + droP 2 [] = [] + + --droP 0 [a,b] = [a,b] + --droP 0 [a,b,c] = [a,b,c] + droP 1 [a] = [] + droP 1 [a,b] = [b] + droP 1 [a,b,c] = [b,c] + droP 2 [a] = [] + droP 2 [a,b] = [] + droP 2 [a,b,c] = [c] + --droP (S (S 1)) [] = [] + --droP (S (S 1)) [a] = [] + --droP (S (S 1)) [a,b] = [] + --droP (S (S 1)) [a,b,c] = [] + |] -- ¤¤¤±¤ë¡¥¤Á¤Ê¤ß¤Ë¡¤drop12¤Î¾ì¹ç¤È¤Ï¤Ù¤Ä¤Î²ò¤¬ÀèƬ¤ËÍè¤ë¤¬¡¤¤É¤Á¤é¤âÀµ²ò¡¥¤Ê¤ª¡¤drop'9¤¬Example.hs¤ÈƱ¤¸¤â¤Î¡¥ +dropPred :: (Int -> String -> String) -> Bool +dropPred drop = drop 3 "abcde" == "de" + +dropArgss = ["3 [4,5,6,7,8]"] + +even6 = [d| f :: Int -> Bool; f 0 = True; f 1 = False; f 2 = True; f 3 = False; f 4 = True; f 5 = False |] +evenArgss = ["8", "9"] + +-- :cmd run $ filtGetOne "evenpos7" "evenposPred" +evenpos7 = [d| evenpos :: [a] -> [a] + evenpos [] = [] + evenpos [a] = [] + evenpos [a,b] = [b] + evenpos [a,b,c] = [b] + evenpos [a,b,c,d] = [b,d] + evenpos [a,b,c,d,e] = [b,d] + evenpos [a,b,c,d,e,f] = [b,d,f] + |] -- Examples.hs¤ÈƱ¤¸¤â¤Î¡¥ +evenposPred evenpos = evenpos "abcdefg" == "bdf" +-- :cmd run $ filtGetOne "evens21" "evensPred" +evens21 = [d| + evens :: [Int] -> [Int] + evens [] = [] + evens [0] = [0] + evens [1] = [] + evens [2] = [2] + evens [3] = [] + evens [0,0] = [0,0] + evens [0,1] = [0] + evens [0,2] = [0,2] + evens [0,3] = [0] + evens [1, 0] = [0] + evens [1, 1] = [] + evens [1, 2] = [2] + evens [1, 3] = [] + evens [2, 0] = [2,0] + evens [2, 1] = [2] + evens [2, 2] = [2,2] + evens [2, 3] = [2] + evens [3, 0] = [0] + evens [3, 1] = [] + evens [3, 2] = [2] + evens [3, 3] = [] + |] +evens13 = [d| + evens :: [Int] -> [Int] + evens [] = [] + evens [0] = [0] + evens [1] = [] + evens [2] = [2] + evens [0,0] = [0,0] + evens [0,1] = [0] + evens [0,2] = [0,2] + evens [1, 0] = [0] + evens [1, 1] = [] + evens [1, 2] = [2] + evens [2, 0] = [2,0] + evens [2, 1] = [2] + evens [2, 2] = [2,2] + |] +evensArgss = ["[1,2,3,4,5]"] +evensPred evens = evens [4,6,9,2,3,8,8] == [4,6,2,8,8] + +-- :cmd run $ filtGetOne "eq9" "eqPred" +eq9 = [d| f :: Int->Int->Bool; f 0 0 = True; f 0 1 = False; f 0 2 = False; f 1 0 = False; f 1 1 = True; f 1 2 = False; f 2 0 = False; f 2 1 = False; f 2 2 = True |] -- Examples.hs¤ÈƱ¤¸¤â¤Î +eq16 = [d| f :: Int->Int->Bool; f 0 0 = True; f 0 1 = False; f 0 2 = False; f 0 3 = False; f 1 0 = False; f 1 1 = True; f 1 2 = False; f 1 3 = False; f 2 0 = False; f 2 1 = False; f 2 2 = True; f 2 3 = False; f 3 0 = False; f 3 1 = False; f 3 2 = False; f 3 3 = True |] -- dame ... too slow.... +eqArgss = ["4 4", "5 7"] +eqPred :: (Int->Int->Bool) -> Bool +eqPred (==) = 3==3 && not (4==6) && 0==0 && not (2==0) && not (0==2) && not (3==5) + +tryFib :: [String] +tryFib = ["iop <- runQ $ fib6", "let e = getOne iop []", "putStrLn $ pprint e"] +-- note that this starts with 0 rather than 1. Also, more examples should be given. +-- :cmd run $ filtGetOne "fib6" "(\\fib -> fib 1 == 1 && fib 2 == 1 && fib 4 == 3 && fib 6 == 8 && fib 8 == 21)" +fib6 = [d| fib :: Int->Int + fib 0 = 0 + fib 1 = 1 + fib 2 = 1 + fib 3 = 2 + fib 4 = 3 + fib 5 = 5 + |] -- Examples.hs¤È¤ª¤Ê¤¸¤â¤Î +-- :cmd run $ filtGetOne "fib8" "(\\fib -> fib 1 == 1 && fib 2 == 1 && fib 4 == 3 && fib 6 == 8 && fib 8 == 21)" +fib8 = [d| fib :: Int->Int + fib 0 = 0 + fib 1 = 1 + fib 2 = 1 + fib 3 = 2 + fib 4 = 3 + fib 5 = 5 + fib 6 = 8 + fib 7 = 13 + |] +fib9 = [d| fib :: Int->Int + fib 0 = 0 + fib 1 = 1 + fib 2 = 1 + fib 3 = 2 + fib 4 = 3 + fib 5 = 5 + fib 6 = 8 + fib 7 = 13 + fib 8 = 21 + |] +fib10 = [d| fib :: Int->Int + fib 0 = 0 + fib 1 = 1 + fib 2 = 1 + fib 3 = 2 + fib 4 = 3 + fib 5 = 5 + fib 6 = 8 + fib 7 = 13 + fib 8 = 21 + fib 9 = 34 + |] +fibPred fib = fib 1 == 1 && fib 2 == 1 && fib 4 == 3 && fib 6 == 8 && fib 8 == 21 +-- :cmd run $ filtGetOne "heaD" "headPred" +heaD = [d| + heaD :: [a] -> a + heaD [a] = a + heaD [a,b] = a + heaD [a,b,c] = a + heaD [a,b,c,d] = a + |] +headPred head = head "abcde" == 'a' +-- :cmd run $ filtGetOne "incr" "incrPred" +incr = [d| + incr :: [Int] -> [Int] + incr [] = [] + incr [0] = [1] + incr [1] = [2] +--incr [2] = [3] + incr [0,1] = [1,2] +--incr [0,2] = [1,3] + incr [1,0] = [2,1] + |] -- Examples.hs¤ÈƱ¤¸¤â¤Î¡¥Ä¹¤µ¤¬Â­¤ê¤º¡¤filter¤¬Í­¸ú¤ÊÎã¡¥`mplus`¤Ç¤â(+/)¤Ç¤â¡¥¤Ç¤â¡¤Igor¤À¤È¤¦¤Þ¤¯¤¤¤¯¡¥ + +incrPred :: ([Int] -> [Int]) -> Bool +incrPred f = f [0,1,1,2] == [1,2,2,3] +incr' = [d| + incr :: [Int] -> [Int] + incr [] = [] + incr [0] = [1] + incr [1] = [2] +--incr [2] = [3] + incr [0,1] = [1,2] +--incr [0,2] = [1,3] + incr [1,0] = [2,1] +-- incr [0,0,0] = [1,1,1] + incr [1,0,0] = [2,1,1] + incr [0,1,0] = [1,2,1] + incr [0,0,1] = [1,1,2] + incr [1,0,0,0] = [2,1,1,1] + incr [0,1,0,0] = [1,2,1,1] + incr [0,0,1,0] = [1,1,2,1] + incr [0,0,0,1] = [1,1,1,2] + |] -- ¤³¤¦¤ä¤Ã¤Æ¤â¥À¥á¡¥ +-- :cmd run $ filtGetOne "iniT" "initPred" +iniT = [d| + iniT:: [a] -> [a] + iniT [a] = [] + iniT [a,b] = [a] + iniT [a,b,c] = [a,b] + iniT [a,b,c,d] = [a,b,c] + |] -- ¤ª¤Ê¤¸¤ä¤Ä +initPred init = init "foobar" == "fooba" + +-- taken from Examples.hs in igor2-0.7.1.3, but equivalence over Ints has to be defined in order to work with igor2, because equivalence over Ints are not defined. +-- These (with eq9 as the BK) should not work when anti-unification is forced. ¤Ê¤¼¤Ê¤é¡¤succ¤¬Æ³Æþ¤µ¤ì¤ÆintroBK¤¬Á˳²¤µ¤ì¤ë¤«¤é¡¥1¤«¤é¤Ç¤Ê¤¯0¤«¤é»Ï¤á¤ë¤Ù¤­¡¥ +mem15 = [d| + mem :: Int -> [Int] -> Bool + mem 1 [] = False + mem 2 [] = False + mem 3 [] = False + mem 1 [1] = True + mem 2 [1] = False + mem 3 [1] = False + mem 1 [2] = False + mem 2 [2] = True + mem 3 [2] = False + mem 1 [3] = False + mem 2 [3] = False + mem 3 [3] = True + + mem 1 [2,1] = True + mem 2 [2,1] = True + --member 1 [3,1,2] = [1,2] + --member 1 [1,2,3] = [1,2,3] + mem 1 [3,2,1] = True + |] +mem8 = [d| + mem :: Int -> [Int] -> Bool + mem 1 [] = False + mem 2 [] = False + mem 1 [1] = True + mem 2 [1] = False + mem 1 [2] = False + mem 2 [2] = True + mem 1 [2,1] = True + mem 2 [2,1] = True + |] +mem6 = [d| + mem :: Int -> [Int] -> Bool + mem 1 [] = False + mem 2 [] = False + mem 1 [1] = True + mem 2 [1] = False + mem 1 [2] = False + mem 2 [2] = True + |] +mem'15 = [d| + mem :: Int -> [Int] -> Bool + mem 0 [] = False + mem 1 [] = False + mem 2 [] = False + mem 0 [0] = True + mem 1 [0] = False + mem 2 [0] = False + mem 0 [1] = False + mem 1 [1] = True + mem 2 [1] = False + mem 0 [2] = False + mem 1 [2] = False + mem 2 [2] = True + + mem 0 [1,0] = True + mem 1 [1,0] = True + --member 0 [2,0,1] = [0,1] + --member 0 [0,1,2] = [0,1,2] + mem 0 [2,1,0] = True + |] + +mem'6 = [d| + mem :: Int -> [Int] -> Bool + mem 0 [] = False + mem 1 [] = False + mem 0 [0] = True + mem 1 [0] = False + mem 0 [1] = False + mem 1 [1] = True + |] + +mem'8 = [d| + mem :: Int -> [Int] -> Bool + mem 0 [] = False + mem 1 [] = False + mem 0 [0] = True + mem 1 [0] = False + mem 0 [1] = False + mem 1 [1] = True + mem 0 [0,1] = True + mem 1 [0,1] = True + |] + +-- rev n = fmap (take (n+1)) [d| f :: [a]->[a]; f [] = []; f [a] = [a]; f [a,b] = [b,a]; f [a,b,c] = [c,b,a]; f [a,b,c,d] = [d,c,b,a] |] +-- :cmd run $ filtGetOne "oddpos6" "oddposPred" +oddpos6 = [d| + oddpos :: [a] -> [a] + oddpos [] = [] + oddpos [a] = [a] + oddpos [a,b] = [a] + oddpos [a,b,c] = [a,c] + oddpos [a,b,c,d] = [a,c] + oddpos [a,b,c,d,e] = [a,c,e] + |] +oddposPred oddpos = oddpos "abcdef" == "ace" && oddpos "abc" == "ac" + +-- :cmd run $ filtGetOne "lasT" "lastPred" +lasT = [d| + lasT :: [a] -> a + lasT [a] = a + lasT [a,b] = b + lasT [a,b,c] = c + lasT [a,b,c,d] = d + |] +lastPred last = last "abcde" == 'e' + +lastM = [d| + lastM :: [a] -> Maybe a + lastM [] = Nothing + lastM [a] = Just a + lastM [a,b] = Just b + lastM [a,b,c] = Just c + lastM [a,b,c,d] = Just d + |] -- Maybe¤ä¤Ã¤Æ¤Ê¤«¤Ã¤¿¡¥ +-- :cmd run $ filtGetOne "lasts" "lastsPred" +lasts = [d| + lasts :: [[a]] -> [a] + lasts [] = [] + lasts [[a]] = [a] + lasts [[a,b]] = [b] + lasts [[a,b,c]] = [c] + lasts [[b],[a]] = [b,a] + lasts [[c],[a,b]] = [c,b] + lasts [[a,b],[c,d]] = [b,d] + lasts [[c,d],[b]] = [d,b] + lasts [[c],[d,e],[f]] = [c,e,f] + lasts [[c,d],[e,f],[g]] = [d,f,g] + |] +lasts' = [d| + lasts :: [[a]] -> [a] + lasts [] = [] + lasts [[a]] = [a] + lasts [[a,b]] = [b] +-- lasts [[a,b,c]] = [c] + lasts [[b],[a]] = [b,a] + lasts [[c],[a,b]] = [c,b] + lasts [[a,b],[c,d]] = [b,d] + lasts [[c,d],[b]] = [d,b] +-- lasts [[c],[e],[f]] = [c,e,f] + -- lasts [[c],[d,e],[f]] = [c,e,f] + -- lasts [[c,d],[e,f],[g]] = [d,f,g] + -- lasts [[c,d],[e,f],[h,g]] = [d,f,g] + |] +lastsPred lasts = lasts ["abcdef", "abc", "abcde"] == "fce" + +-- :cmd run $ filtGetOne "lens" "lengthsPred" +lens = [d| + lengths :: [[a]] -> [Int] + lengths [] = [] + lengths [[]] = [0] + lengths [[a]] = [1] + lengths [[b,a]] = [2] +--lengths [[c,b,a]] = [S(S(1)] + lengths [[],[]] = [0, 0] + lengths [[],[a]] = [0,1] + lengths [[],[b,a]] = [0,2] + |] +lengthsPred :: ([String] -> [Int]) -> Bool +lengthsPred lengths = lengths ["abcdef", "abc", "abcde"] == [6,3,5] + +-- :cmd run $ filtGetOne "multFst" "multFstPred" +multFst = [d| + multfst :: [a] -> [a] + multfst [] = [] + multfst [a] = [a] + multfst [a,b] = [a,a] + multfst [a,b,c] = [a,a,a] + multfst [a,b,c,d] = [a,a,a,a] +--multfst [a,b,c,d,e] = [a,a,a,a,a] +--multfst [a,b,c,d,e,f] = [a,a,a,a,a,a] + |] +multFstPred multfst = multfst "abcdef" == "aaaaaa" + +-- :cmd run $ filtGetOne "multLst" "multLstPred" +multLst = [d| + multlst :: [a] -> [a] + multlst [] = [] + multlst [a] = [a] + multlst [a,b] = [b,b] + multlst [a,b,c] = [c,c,c] + multlst [a,b,c,d] = [d,d,d,d] +--multlst [a,b,c,d,e] = [e,e,e,e,e] +--multlst [a,b,c,d,e,f] = [f,f,f,f,f,f] + |] +multLstPred multlst = multlst "abcdef" == "ffffff" + +-- :cmd run $ filtGetOne "negateall" "negateAllPred" +negateall = [d| + negateAll :: [Bool] -> [Bool] + negateAll [] = [] + negateAll [True] = [False] + negateAll [False] = [True] + negateAll [False,False] = [True,True] + negateAll [False,True] = [True,False] + negateAll [True,False] = [False,True] + negateAll [True,True] = [False,False] + |] +negateAllPred f = f [True,False,False,True] == [False,True,True,False] && f [False,True,False] == [True,False,True] + +-- :cmd run $ filtGetOne "powset" "(\\powset -> powset \"abcd\" == [\"abcd\",\"abc\",\"abd\",\"ab\",\"acd\",\"ac\",\"ad\",\"a\",\"bcd\",\"bc\",\"bd\",\"b\",\"cd\",\"c\",\"d\",\"\"])" +powset = [d| + powset :: [a] -> [[a]] + powset [] = [[]] + powset [a] = [[a],[]] + powset [a,b] = [[a,b],[a],[b],[]] + powset [a,b,c] = [[a,b,c],[a,b],[a,c],[a],[b,c],[b],[c],[]] + --powset [a,b,c,d] = [[a,b,c,d],[a,b,c],[a,b,d],[a,b],[a,c,d],[a,c],[a,d],[a],[b,c,d],[b,c],[b,d],[b],[c,d],[c],[d],[]] + |] + +odD = [d| + odD :: Int -> Bool + odD 0 = False + odD 1 = True + odD 2 = False + odD 3 = True + odD 4 = False + odD 5 = True + |] +-- :cmd run $ filtGetOne "reversE" "(\\rev -> rev \"abcde\" == \"edcba\")" +reversE = [d| + reversE :: [a] -> [a] + reversE [] = [] + reversE [a] =[a] + reversE [a,b] = [b,a] + reversE [a,b,c] = [c,b,a] + reversE [a,b,c,d] = [d,c,b,a] +--reversE [a,b,c,d,e] = [e,d,c,b,a] +--reversE [a,b,c,d,e,f] = [f,e,d,c,b,a] + |] +revPred rev = rev "abcdef" == "fedcba" +-- :cmd run $ filtGetOne "shiftl" "shiftlPred" +shiftl = [d| + shiftl :: [a] -> [a] + shiftl [] = [] + shiftl [a] = [a] + shiftl [a,b] = [b,a] + shiftl [a,b,c] = [b,c,a] + shiftl [a,b,c,d] = [b,c,d,a] +--shiftl [a,b,c,d,e] = [b,c,d,e,a] +--shiftl [a,b,c,d,e,f] = [b,c,d,e,f,a] +--shiftl [a,b,c,d,e,f,g] = [b,c,d,e,f,g,a] +--shiftl [a,b,c,d,e,f,g,h] = [b,c,d,e,f,g,h,a] + |] +shiftlPred shiftl = shiftl "abcde" == "bcdea" + +-- :cmd run $ filtGetOne "shiftr" "shiftrPred" +shiftr = [d| + shiftr :: [a] -> [a] + shiftr [] = [] + shiftr [a] = [a] + shiftr [a,b] = [b,a] + shiftr [a,b,c] = [c,a,b] + shiftr [a,b,c,d] = [d,a,b,c] +-- shiftr [a,b,c,d,e] = [e,a,b,c,d] + |] +shiftrPred shiftr = shiftr "abcde" == "eabcd" + +-- :cmd run $ filtGetOne "snoc" "snocPred" +snoc = [d| + snoc :: a -> [a] -> [a] + snoc a [] = [a] + snoc b [a] = [a,b] + snoc c [a,b] = [a,b,c] + snoc d [a,b,c] = [a,b,c,d] +--snoc e [a,b,c,d] = [a,b,c,d,e] +--snoc f [a,b,c,d,e] = [a,b,c,d,e,f] + |] +snocPred snoc = snoc 'f' "abcde" == "abcdef" + +-- :cmd run $ filtGetOne "suM" "(\\sum -> sum [7,3,8,5] == 23)" +suM = [d| + suM :: [Int] -> Int + suM [] = 0 + suM [0] = 0 + suM [1] = 1 + suM [2] = 2 + suM [0,0] = 0 + suM [0,1] = 1 + suM [0,2] = 2 + suM [1,0] = 1 + suM [1,1] = 2 + suM [1,2] = 3 + suM [2,0] = 2 + suM [2,1] = 3 + suM [2,2] = 4 + suM [2,1, 2] = 5 + |] +tunedSum n = fmap (takeFunD n) suM +sumPred sum = sum [7,3,8,5] == 23 + +-- :cmd run $ filtGetOne "swap" "swapPred" +swap = [d| + swap:: [a] -> [a] + swap [] = [] + swap [a] = [a] + swap [a,b] = [b,a] + swap [a,b,c] = [b,a,c] + swap [a,b,c,d] = [b,a,d,c] + swap [a,b,c,d,e] = [b,a,d,c,e] + swap [a,b,c,d,e,f] = [b,a,d,c,f,e] + |] +swapPred swap = swap "abcde" == "badce" + +-- :cmd run $ filtGetOne "switch" "switchPred" +switch = [d| + switch :: [a] -> [a] + switch [] = [] + switch [a] = [a] + switch [a,b] = [b,a] + switch [a,b,c] = [c,b,a] + switch [a,b,c,d] = [d,b,c,a] +--switch [a,b,c,d,e] = [e,b,c,d,a] +--switch [a,b,c,d,e,f] = [f,b,c,d,e,a] + |] +switchPred switch = switch "abcde" == "ebcda" + +-- :cmd run $ filtGetOne "takE" "takePred" +takE = [d| + takE :: Int -> [a] -> [a] + takE 0 [] = [] + takE 0 [a] = [] + takE 0 [a,b] = [] +--takE 0 [a,b,c] = [] + takE 1 [] = [] + takE 1 [a] = [a] + takE 1 [a,b] = [a] +--takE 1 [a,b,c] = [a] + takE 2 [] = [] + takE 2 [a] = [a] + takE 2 [a,b] = [a,b] +--takE 2 [a,b,c] = [a,b] + takE 3 [] = [] + takE 3 [a] = [a] + takE 3 [a,b] = [a,b] +--takE 3 [a,b,c] = [a,b,c] + |] +takePred :: (Int->String->String) -> Bool +takePred take = take 3 "abcde" == "abc" + +-- :cmd run $ filtGetOne "weave" "weavePred" +weave = [d| + weave :: [a] -> [a] -> [a] + weave [] [] = [] + weave [a][] = [a] + weave [][c] = [c] + weave [a][c] = [a,c] + weave [a,b][] = [a,b] + weave [][c,d] = [c,d] + weave [a,b][c] = [a,c,b] + weave [a][c,d] = [a,c,d] + weave [a,b][c,d] = [a,c,b,d] + |] +weavePred weave = weave "abc" "def" == "adbecf" + +{- +zeros = [d| + zeros :: [Int] -> [Int] + zeros [] = [] + zeros [0] = [0] + zeros [S x] = [] + zeros [0,S x] = [0] + zeros [S x,0] = [0] + zeros [S x,S y] = [] + zeros [0,0] = [0,0] +--zeros [0,S x,S y] = [0] +--zeros [S x,0,S y] = [0] +--zeros [S y,S x,0] = [0] +--zeros [0,0,S x] = [0,0] +--zeros [0,S x,0] = [0,0] +--zeros [S x,0,0] = [0,0] +--zeros [0,0,0] = [0,0,0] + |] +-} +zeros'7 = [d| + zeros :: [Int] -> [Int] + zeros [] = [] + zeros [0] = [0] + zeros [1] = [] + zeros [0,1] = [0] + zeros [1,0] = [0] + zeros [1,1] = [] + zeros [0,0] = [0,0] + |] -- dame +zeros'14 = [d| + zeros :: [Int] -> [Int] + zeros [] = [] + zeros [0] = [0] + zeros [1] = [] + zeros [0,1] = [0] + zeros [1,0] = [0] + zeros [1,1] = [] + zeros [0,0] = [0,0] + zeros [1,1,1] = [] + zeros [0,1,1] = [0] + zeros [1,0,1] = [0] + zeros [1,1,0] = [0] + zeros [0,0,1] = [0,0] + zeros [0,1,0] = [0,0] + zeros [1,0,0] = [0,0] + zeros [0,0,0] = [0,0,0] + |] -- dame +zeros'31 = [d| + zeros :: [Int] -> [Int] + zeros [] = [] + zeros [0] = [0] + zeros [1] = [] + zeros [0,1] = [0] + zeros [1,0] = [0] + zeros [1,1] = [] + zeros [0,0] = [0,0] + zeros [1,1,1] = [] + zeros [0,1,1] = [0] + zeros [1,0,1] = [0] + zeros [1,1,0] = [0] + zeros [0,0,1] = [0,0] + zeros [0,1,0] = [0,0] + zeros [1,0,0] = [0,0] + zeros [0,0,0] = [0,0,0] + zeros [1,1,1,1] = [] + zeros [0,1,1,1] = [0] + zeros [1,0,1,1] = [0] + zeros [1,1,0,1] = [0] + zeros [0,0,1,1] = [0,0] + zeros [0,1,0,1] = [0,0] + zeros [1,0,0,1] = [0,0] + zeros [0,0,0,1] = [0,0,0] + zeros [1,1,1,0] = [] + zeros [0,1,1,0] = [0,0] + zeros [1,0,1,0] = [0,0] + zeros [1,1,0,0] = [0,0] + zeros [0,0,1,0] = [0,0,0] + zeros [0,1,0,0] = [0,0,0] + zeros [1,0,0,0] = [0,0,0] + zeros [0,0,0,0] = [0,0,0,0] + |] -- dame + +echoOn :: [String] -> [String] +echoOn [] = [] +echoOn (x:xs) = ("putStrLn "++ show x) : x : echoOn xs + +withEcho :: String -> String +withEcho str = show str ++ '\n' : str ++ "\n" + + +ins21 = [d| + ins 0 [] = [0] + ins 1 [] = [1] + ins 2 [] = [2] + ins 0 [0] = [0,0] + ins 1 [0] = [0,1] + ins 2 [0] = [0,2] + ins 0 [1] = [0,1] + ins 1 [1] = [1,1] + ins 2 [1] = [1,2] + ins 0 [2] = [0,2] + ins 1 [2] = [1,2] + ins 0 [0,0] = [0,0,0] + ins 1 [0,0] = [0,0,1] + ins 2 [0,0] = [0,0,2] + ins 0 [0,1] = [0,0,1] + ins 1 [0,1] = [0,1,1] + ins 2 [0,1] = [0,1,2] + ins 0 [0,2] = [0,0,2] + ins 1 [0,2] = [0,1,2] + ins 0 [1,1] = [0,1,1] + ins 1 [1,1] = [1,1,1] + |] +ins30 = [d| + ins 0 [] = [0] + ins 1 [] = [1] + ins 2 [] = [2] + ins 0 [0] = [0,0] + ins 1 [0] = [0,1] + ins 2 [0] = [0,2] + ins 0 [1] = [0,1] + ins 1 [1] = [1,1] + ins 2 [1] = [1,2] + ins 0 [2] = [0,2] + ins 1 [2] = [1,2] + ins 2 [2] = [2,2] + ins 0 [0,0] = [0,0,0] + ins 1 [0,0] = [0,0,1] + ins 2 [0,0] = [0,0,2] + ins 0 [0,1] = [0,0,1] + ins 1 [0,1] = [0,1,1] + ins 2 [0,1] = [0,1,2] + ins 0 [0,2] = [0,0,2] + ins 1 [0,2] = [0,1,2] + ins 2 [0,2] = [0,2,2] + ins 0 [1,1] = [0,1,1] + ins 1 [1,1] = [1,1,1] + ins 2 [1,1] = [1,1,2] + ins 0 [1,2] = [0,1,2] + ins 1 [1,2] = [1,1,2] + ins 2 [1,2] = [1,2,2] + ins 0 [2,2] = [0,2,2] + ins 1 [2,2] = [1,2,2] + ins 2 [2,2] = [2,2,2] + |] +bmin = [d| + mi 0 x = 0 + mi 1 0 = 0 + mi 1 1 = 1 + mi 1 2 = 1 + mi 2 0 = 0 + mi 2 1 = 1 + mi 2 2 = 2 + |] +bmax = [d| + ma 0 0 = 0 + ma 0 1 = 1 + ma 0 2 = 2 + ma 1 0 = 1 + ma 1 1 = 1 + ma 1 2 = 2 + ma 2 0 = 2 + ma 2 1 = 2 + ma 2 2 = 2 + |] diff --git a/LICENSE b/LICENSE deleted file mode 100644 --- a/LICENSE +++ /dev/null @@ -1,25 +0,0 @@ -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. diff --git a/MagicHaskeller.cabal b/MagicHaskeller.cabal --- a/MagicHaskeller.cabal +++ b/MagicHaskeller.cabal @@ -1,26 +1,42 @@ -Name: MagicHaskeller -Version: 0.8.5 +Name: MagicHaskeller +Version: 0.8.6 +Cabal-Version: >= 1.2 License: BSD3 -License-File: LICENSE -Copyright: Copyright: (c) 2009 Susumu Katayama -Author: Susumu Katayama -Maintainer: Susumu Katayama -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 +Author: Susumu Katayama +Maintainer: Susumu Katayama +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 +data-files: ExperimIOP.hs +Tested-with: GHC == 6.10.4 +Flag GHCAPI + Description: Enable execution using the GHC API rather than the combinatory interpreter + Default: True + +-- Flag ForcibleTO +-- Flag Debug +-- Flag Benchmark + +Library + Build-depends: template-haskell, base >= 4 && < 5, syb, containers, array, random, directory, bytestring, mtl + Exposed-modules: MagicHaskeller, Control.Monad.Search.Combinatorial, MagicHaskeller.ProgGen, MagicHaskeller.ProgGenSF, MagicHaskeller.ProgGenXF, + MagicHaskeller.Expression, MagicHaskeller.LibTH, MagicHaskeller.Analytical, MagicHaskeller.Options + Other-modules: MagicHaskeller.MemoToFiles, MagicHaskeller.ShortString, MagicHaskeller.GetTime, + MagicHaskeller.Types, MagicHaskeller.PriorSubsts, Data.Memo, MagicHaskeller.ClassifyTr, MagicHaskeller.Classification, + MagicHaskeller.CoreLang, MagicHaskeller.DebMT, MagicHaskeller.TyConLib, + MagicHaskeller.FakeDynamic, MagicHaskeller.PolyDynamic, 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, MagicHaskeller.Analytical.FMExpr, + MagicHaskeller.Analytical.Parser, MagicHaskeller.Analytical.Syntax, MagicHaskeller.Analytical.UniT, MagicHaskeller.Analytical.Synthesize + Extensions: CPP, TemplateHaskell + GHC-options: -O2 -fvia-C + cpp-options: -DCHTO + + if flag(GHCAPI) + Build-depends: ghc >= 6.10, old-time, ghc-paths + Exposed-modules: MagicHaskeller.RunAnalytical, MagicHaskeller.ExecuteAPI610 diff --git a/MagicHaskeller.lhs b/MagicHaskeller.lhs --- a/MagicHaskeller.lhs +++ b/MagicHaskeller.lhs @@ -1,12 +1,9 @@ -- --- (c) Susumu Katayama 2009 +-- (c) Susumu Katayama -- \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 @@ -15,6 +12,11 @@ -- 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, +{- x ²¼¤ÎÊý¤ËThe program generators¤Ã¤Æ¤Î¤¬¤¢¤ë¤¿¤á¡¤confusing¤Ê¤Î¤Ç¡¥ + -- * Program generators + ProgramGenerator, ProgGen, ProgGenSF, {- ProgGenSFIF, -} CutFree, CutFreeSF, ConstrL, ConstrLSF, +-} + -- * 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. @@ -51,16 +53,19 @@ mkPG075, mkMemo075, -- | 'mkPGOpt' can be used along with its friends instead of 'mkPG' when the search should be fine-tuned. - mkPGOpt, Options, Opt(..), options, + mkPGOpt, Options, Opt(..), options, MemoType(..), #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, + -- | 'load' and 'f' provides an alternative scheme to create program generator algorithms. + load, f, #endif -- ** Memoization depth + -- | NB: 'setDepth' will be obsoleted. It is provided for backward compatibility, but + -- not exactly compatible with the old one in that its result will not affect the behavior of 'everything', etc., which explicitly take a 'ProgramGenerator' as an argument. + -- Also, in the current implementation, the result of 'setDepth' will be overwritten by setPrimitives. + -- Use 'memodepth' option instead. setDepth, -- ** Time out @@ -77,7 +82,7 @@ -- ** Defining functions automatically -- | In this case \"automatically\" does not mean \"inductively\" but \"deductively using Template Haskell\";) - define, Everything, Filter, Every, + define, Everything, Filter, Every, EveryIO, -- * Generating programs -- | (There are many variants, but most of the functions here just filter 'everything' with the predicates you provide.) @@ -86,7 +91,7 @@ -- (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, + findOne, printOne, printAll, printAllF, io2pred, -- ** Incremental filtration -- | Sometimes you may want to filter further after synthesis, because the predicate you previously provided did not specify @@ -95,34 +100,32 @@ -- ** Expression generators -- | These functions generate all the expressions that have the type you provide. - getEverything, everything, everythingM, unifyable, matching, getEverythingF, everythingF, unifyableF, matchingF, + getEverything, everything, everythingM, everythingIO, unifyable, matching, getEverythingF, everythingF, unifyableF, matchingF, -- ** Utility to filter out equivalent expressions everyF, + -- ** Unility to get one value easily + stripEvery, + -- ** Pretty printers - pprs, printQ, + pprs, pprsIO, pprsIOn, lengths, lengthsIO, lengthsIOn, 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 + unsafeCoerce#, {- unifyablePos, -} exprToTHExp, trToTHType, printAny, p1 ) where import Data.Generics(everywhere, mkT, Data) import Data.Array.IArray -import MagicHaskeller.CoreLang(CoreExpr(..), HValue(..), exprToTHExp, VarLib) +import MagicHaskeller.CoreLang import Language.Haskell.TH as TH #ifdef HASKELLSRC -import Language.Haskell.Syntax -import Language.Haskell.Pretty -import ReadType +import MagicHaskeller.ReadHsType(readHsTypeSigs) #endif import MagicHaskeller.TyConLib import qualified Data.Map as Map @@ -135,6 +138,7 @@ -- import MagicHaskeller.ProgGenLF(ProgGenLF) import MagicHaskeller.ProgGenXF(ProgGenXF) import MagicHaskeller.ProgramGenerator +import MagicHaskeller.Options(Opt(..), options) import Control.Monad.Search.Combinatorial -- This should all be exposed? import Data.Typeable as Typeable import System.IO.Unsafe(unsafePerformIO) @@ -144,14 +148,17 @@ import System.IO import System.Random(mkStdGen,StdGen) import MagicHaskeller.MHTH +import MagicHaskeller.TimeOut import MagicHaskeller.ReadTHType import MagicHaskeller.ReadTypeRep(trToType, trToTHType) import MagicHaskeller.MyDynamic +import qualified MagicHaskeller.PolyDynamic as PD import MagicHaskeller.Expression import MagicHaskeller.Classify import MagicHaskeller.Classification(unsafeRandomTestFilter, Filtrable) import MagicHaskeller.Instantiate(mkRandTrie) +import MagicHaskeller.MemoToFiles(MemoType(..)) \end{code} @@ -159,32 +166,32 @@ -- "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) |]) ) +-- > $( define ''ProgGen "Foo" (p [| (1 :: Int, (+) :: Int -> Int -> Int) |]) ) -- -- is equivalent to -- -- > memoFoo :: ProgGen -- > memoFoo = mkPG (p [| (1 :: Int, (+) :: Int -> Int -> Int) |]) -- > everyFoo :: Everything --- > everyFoo = everything 15 memoFoo +-- > everyFoo = everything memoFoo -- > filterFoo :: Filter -- > filterFoo pred = filterThen pred everyFoo -- -- If you do not think this function reduces the number of your keystrokes a lot, you can do without it. -define :: TH.Name -> String -> Integer -> TH.ExpQ -> TH.Q [TH.Dec] -define mn name depth pq = pq >>= \prims -> +define :: TH.Name -> String -> TH.ExpQ -> TH.Q [TH.Dec] +define mn name pq = pq >>= \prims -> return [ SigD (mkName ("memo"++name)) (ConT mn), ValD (VarP (mkName ("memo"++name))) (NormalB (AppE (VarE (mkName "mkPG")) prims -- (VarE (mkName "prims")) )) [], SigD (mkName ("every"++name)) (ConT (mkName "Everything")), - ValD (VarP (mkName ("every"++name))) (NormalB ((VarE (mkName "everything") `AppE` LitE (IntegerL depth)) `AppE` VarE (mkName ("memo"++name)))) [], + ValD (VarP (mkName ("every"++name))) (NormalB (VarE (mkName "everything") `AppE` VarE (mkName ("memo"++name)))) [], SigD (mkName ("filter"++name)) (ConT (mkName "Filter")), ValD (VarP (mkName ("filter"++name))) (NormalB ((VarE (mkName "flip") `AppE` VarE (mkName "filterThen")) `AppE` VarE (mkName ("every"++name)))) [] ] type Every a = [[(TH.Exp,a)]] +type EveryIO a = Int -- query depth + -> IO [(TH.Exp, a)] type Everything = Typeable a => Every a type Filter = Typeable a => (a->Bool) -> IO (Every a) @@ -207,15 +214,21 @@ -- | '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 +p eq = eq >>= \e -> case e of TupE es -> (return . ListE) =<< (mapM p1 es) + _ -> (return . ListE . return) =<< p1 e -- This default pattern should also be defined, because it takes two (or more) to tuple! +p1 :: TH.Exp -> TH.ExpQ +p1 se@(SigE e ty) = p1' se e ty +p1 e@(ConE name) = do DataConI _ ty _ _ <- reify name + p1' e e ty +p1 e@(VarE name) = do VarI _ ty _ _ <- reify name + p1' e e ty +p1 e = 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)] +p1' se e ty = do ee <- expToExpExp e + et <- typeToExpType ty + return $ TupE [ AppE (ConE (mkName "HV")) (AppE (VarE (mkName "unsafeCoerce#")) se), ee, et] + -- nameToExpName :: TH.Name -> TH.Exp -- nameToExpName = strToExpName . showName -- strToExpName str = AppE (VarE (mkName "mkName")) (LitE (StringL str)) @@ -242,15 +255,7 @@ 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 @@ -291,8 +296,8 @@ -- 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 +mkCommon opts prims = let + tyconlib = primitivesToTCL prims optunit = forget opts in Cmn {opt = optunit, tcl = tyconlib, vl = primitivesToVL tyconlib prims, rt = mkRandTrie (nrands opts) tyconlib (stdgen opts)} @@ -316,35 +321,12 @@ #ifdef HASKELLSRC -- | 'load' loads a component library file. load :: FilePath - -> TH.ExpQ -- ^ This becomes @([[HValue]], String)@ when spliced. + -> TH.ExpQ -- ^ This becomes @[Primitive]@ when spliced. load fp = do str <- runIO $ readFile fp f str -- | f is supposed to be used by load, but not hidden. f :: String -> TH.ExpQ -f 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) +f = p . return . readHsTypeSigs #endif @@ -358,14 +340,12 @@ 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 +setDepth d = do PG (x,y,cmn) <- readIORef refmemodeb + writeIORef refmemodeb $ PG (x,y,cmn{opt = (opt cmn){memodepth=d}}) + -- ^ Currently the default depth is 10. You may want to lower the value if your computer often swaps, or increase it if you have a lot of memory. {-# NOINLINE refmemodeb #-} @@ -376,9 +356,9 @@ 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] + where tnsByK :: Array Types.Kind [TypeName] tnsByK = accumArray (flip (:)) [] (0,7) ( trsToTCstrs trs ) -- ¤³¤³¤òÊѤ¨¤¿¡¥ - tcsByK :: Array Kind [(TypeName,Types.TyCon)] + tcsByK :: Array Types.Kind [(TypeName,Types.TyCon)] tcsByK = listArray (0,7) [ tnsToTCs (tnsByK ! k) | k <- [0..7] ] tnsToTCs :: [TypeName] -> [(TypeName,Types.TyCon)] tnsToTCs tns = zipWith (\ i tn -> (tn, i)) [0..] tns @@ -394,13 +374,11 @@ -- | '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) +getEverything = do memodeb <- readIORef refmemodeb + return (everything memodeb) getEverythingF :: Typeable a => IO (Every a) -getEverythingF =do depth <- readIORef refdepth - memodeb <- readIORef refmemodeb - return (everythingF depth memodeb) +getEverythingF =do memodeb <- readIORef refmemodeb + return (everythingF memodeb) {- getEverything = result where ty = typeOf $ snd $ head $ head $ unsafePerformIO result @@ -412,18 +390,16 @@ -- 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 + 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) +everything memodeb = et undefined memodeb (mxExprToEvery "MagicHaskeller.everything: type mismatch" memodeb) +everythingF memodeb = et undefined memodeb (mxExprFiltEvery "MagicHaskeller.everythingF: type mismatch" memodeb) et :: (ProgramGenerator pg, Typeable a) => a -- ^ dummy argument - -> 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) +et dmy memodeb filt = unMx $ filt ty $ matchingPrograms ty memodeb where ty = trToType (extractTCL memodeb) (typeOf dmy) noFilter :: ProgramGenerator pg => pg -> Types.Type -> a -> a noFilter _m _t = id @@ -441,46 +417,58 @@ ̵¸Â¥ê¥¹¥È¤ò»È¤¦¤Ê¤é¡¤unsafeInterleaveIO¤¬É¬ÍפʤϤº¡¥¤½¤Î¾ì¹çIO¤ËÆò½¤¹¤ë¤³¤È¤Ë¤Ê¤ë¡¥ -} everythingM :: (ProgramGenerator pg, Typeable a, Monad m, Functor m) => - Int -- ^ memoization depth. - -> pg -- ^ program generator + 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 +eM dmy memodeb = result where tcl = extractTCL memodeb ty = trToType tcl $ typeOf dmy - result = unRcT $ mxExprToEvery "MagicHaskeller.everythingM: type mismatch" memodeb undefined $ matchingPrograms ty (memodepth,memodeb) + result = unRcT $ mxExprToEvery "MagicHaskeller.everythingM: type mismatch" memodeb undefined $ matchingPrograms ty memodeb +everythingIO :: (ProgramGenerator pg, Typeable a) => + pg -- ^ program generator + -> EveryIO a +everythingIO = eIO undefined +eIO :: (ProgramGenerator pg, Typeable a) => + a -- ^ dummy argument + -> pg -- ^ program generator + -> EveryIO a +eIO dmy memodeb = result + where tcl = extractTCL memodeb + ty = trToType tcl $ typeOf dmy + result = unRcT $ mxExprToEvery "MagicHaskeller.everythingIO: type mismatch" memodeb undefined $ matchingProgramsIO ty memodeb strip :: m (Every a) -> a strip = undefined +stripEvery :: Every a -> a +stripEvery = head . map snd . concat + unifyable, matching, unifyableF, matchingF :: ProgramGenerator pg => - Int -- ^ memoization depth - -> pg -- ^ program generator + 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 +unifyable memodeb tht = unMx $ genExps noFilter unifyingPrograms memodeb tht +matching memodeb tht = unMx $ genExps noFilter matchingPrograms memodeb tht +-- unifyablePos memodeb tht = unMx $ toMx $ fmap (\(es,subst,mx) -> (map (pprintUC . exprToTHExp (extractVL memodeb)) es, subst, mx)) $ unifyingPossibilities (thTypeToType (extractTCL memodeb) tht) memodeb +unifyableF memodeb tht = unMx $ genExps randomTestFilter unifyingPrograms memodeb tht +matchingF memodeb tht = unMx $ genExps randomTestFilter matchingPrograms memodeb tht +genExps filt rawGenProgs memodeb tht = case thTypeToType (extractTCL memodeb) tht of ty -> fmap (exprToTHExp (extractVL memodeb) . toCE) $ - filt memodeb ty $ fmap (toAnnExpr (reducer memodeb)) (rawGenProgs ty (memodepth,memodeb)) + filt memodeb ty $ fmap (toAnnExpr (reducer memodeb)) (rawGenProgs ty memodeb) -- Another advantage of these functions is that you do not need to define @instance Typeable@ for user defined types. -- ¤È»×¤Ã¤¿¤±¤É¡¤GHC¤Ç¤Ïderiving Typeable¤Ç´Êñ¤ËÄêµÁ¤Ç¤­¤ë¤·¡¤Typeable¤¬ÄêµÁ¤Ç¤­¤Ê¤¤·¿¤Ê¤ó¤Æ¤Ê¤µ¤½¤¦¡Êderiving Typeable¤·Ëº¤ì¤¿data type¤ò´Þ¤àdata¤¬¤½¤¦¡©¡Ë --- specializedPossi memodepth memodeb tht = unMx $ toMx $ fmap show (specializedPossibleTypes (thTypeToType (extractTCL memodeb) tht) (memodepth,memodeb)) +-- specializedPossi memodeb tht = unMx $ toMx $ fmap show (specializedPossibleTypes (thTypeToType (extractTCL memodeb) tht) memodeb) {- wrappit :: (Search m, Functor m, Typeable a) => m CoreExpr -> [[(TH.Exp,a)]] @@ -496,26 +484,33 @@ 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 :: Typeable a => (a->Bool) -> IO TH.Exp 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) + return expr +-- | 'printAll' prints all the expressions satisfying the given predicate. +printAll, printAny :: Typeable a => (a->Bool) -> IO () +printAny = printAll -- provided just for backward compatibility +printAll = findDo (\e r -> putStrLn (pprintUC e) >> r) +printAllF :: (Typeable a, Filtrable a) => (a->Bool) -> IO () +printAllF pred = do et <- getEverything + fet <- filterThenF pred et + pprs fet + 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 + result <- maybeWithTO seq mpto (return (pred a)) case result of Just True -> e `op` fp mpto ts Just False -> fp mpto ts Nothing -> hPutStrLn stderr ("timeout on "++pprintUC e) >> fp mpto ts -- x ËÜÅö¤Ïrecomp¤Î¤Þ¤Þ¤Ç¤ä¤Ã¤¿Êý¤¬Â®¤¤¤Ï¤º¡¥ --- | 'filterFirst' is like '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' is like 'printAll', but by itself it does not print anything. Instead, it creates a stream of expressions represented in tuples of 'TH.Exp' and the expressions themselves. filterFirst :: Typeable a => (a->Bool) -> IO (Every a) filterFirst pred = do et <- getEverything filterThen pred et @@ -551,58 +546,40 @@ 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 + fp mpto (ea@(e,a):ts) = case unsafePerformIO (maybeWithTO seq mpto (return (pred a))) 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 -¤ò»È¤¨¤Ð¤¤¤¤¤Ï¤º¡¥ - - - +-- | @io2pred@ converts a specification given as a set of I/O pairs to the predicate form which other functions accept. +io2pred :: Eq b => [(a,b)] -> ((a->b)->Bool) +io2pred ios f = all (\(a,b) -> f a == b) ios -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 +-- | 'pprsIO' is the 'EveryIO' version of pprs +pprsIO :: EveryIO a -> IO () +pprsIO eio = mapM_ (\d -> eio d >>= mapM_ (putStrLn . pprintUC . fst)) [0..] +-- | @pprsIOn depth eio@ is the counterpart of @pprs (take depth eio)@, while @pprsIO eio@ is the counterpart of @pprs eio@. +-- Example: @pprsIOn 5 (everythingIO (mlist::ProgGen) :: EveryIO ([Char]->[Char]))@ +pprsIOn :: Int -> EveryIO a -> IO () +pprsIOn depth eio = mapM_ (\d -> eio d >>= mapM_ (putStrLn . pprintUC . fst)) [0..depth-1] -- | 'pprintUC' is like 'Language.Haskell.TH.pprint', but unqualifies (:) before pprinting in order to avoid printing "GHC.Types.:" which GHCi does not accept and sometimes annoys when doing some demo. pprintUC :: (Ppr a, Data a) => a -> String pprintUC = pprint . everywhere (mkT unqCons) unqCons :: Name -> Name unqCons n | show n == show '(:) = mkName ":" -- NB: n == '(:) would not work due to the definition of Eq Name. | otherwise = n + +lengths :: Every a -> IO () +lengths = print . map length +lengthsIO :: EveryIO a -> IO () +lengthsIO eio = mapM_ (\d -> eio d >>= putStr . (' ':) . show . length) [0..] +lengthsIOn :: Int -> EveryIO a -> IO () +lengthsIOn depth eio = mapM_ (\d -> eio d >>= putStr . (' ':) . show . length) [0..depth-1] + printQ :: (Ppr a, Data a) => Q a -> IO () printQ q = runQ q >>= putStrLn . pprintUC diff --git a/MagicHaskeller/Analytical.hs b/MagicHaskeller/Analytical.hs new file mode 100644 --- /dev/null +++ b/MagicHaskeller/Analytical.hs @@ -0,0 +1,114 @@ +-- +-- (C) Susumu Katayama +-- +-- test with ghci -XTemplateHaskell -cpp -DCHTO MagicHaskeller/Analytical.hs +-- Was: monolithic MagicHaskeller.TypedIOPairs +{-# LANGUAGE TemplateHaskell, CPP #-} +module MagicHaskeller.Analytical( + -- * Analytical synthesizer + -- | This module provides with analytical synthesis, that only generates expressions without testing. + -- (So this alone may not be very useful, and for this reason this is not very well-documented.) + -- In order to generate-and-test over the result of this module, use "MagicHaskeller.RunAnalytical". + + -- ** Synthesizers which can be used with any types. + get1, getMany, getManyTyped, noBK, c, SplicedPrims, + -- ** Synthesizers which are easier to use that can be used only with types appearing 'MagicHaskeller.CoreLang.defaultPrimitives' + getOne, synth, synthTyped + ) where + +import Data.Char(ord,chr) +import Data.Array +import qualified Data.Map as Map +import Data.Generics +import Language.Haskell.TH + +import Control.Monad.Search.Combinatorial +import MagicHaskeller.TyConLib +import MagicHaskeller.CoreLang hiding (C) +import MagicHaskeller.PriorSubsts +import MagicHaskeller.ReadTHType(typeToTHType) +import MagicHaskeller.MHTH(decsToExpDecs) + +import MagicHaskeller(p1) + +import MagicHaskeller.Analytical.Synthesize +#ifdef DEBUG +import MagicHaskeller.Analytical.Debug +#endif + + +type Strategy = Matrix + +type SplicedPrims = ([Dec],[Primitive]) + +-- | get1 can be used to synthesize one expression. For example, +-- +-- >>> putStrLn $ pprint $ get1 $(c [d| f [] = 0; f [a] = 1; f [a,b] = 2 |]) noBK +-- > \a -> let fa (b@([])) = 0 +-- > fa (b@(_ : d)) = succ (fa d) +-- > in fa a +get1 :: SplicedPrims -- ^ target function definition by example + -> SplicedPrims -- ^ background knowledge function definitions by example + -> Exp +get1 target bk = head $ concat $ getMany target bk +-- | getMany does what you expect from its name. +getMany :: SplicedPrims -- ^ target function definition by example + -> SplicedPrims -- ^ background knowledge function definitions by example + -> [[Exp]] +getMany (tgt,pt) (bk,pb) = let ps = pt++pb + tcl = primitivesToTCL ps + vl = primitivesToVL tcl ps + in map (map (exprToTHExp vl)) $ unMx $ toMx (analyticSynth tcl vl tgt bk :: Strategy CoreExpr) +-- | getManyTyped is a variant of 'getMany' that generates typed expressions. +-- This alone is not very useful, but the type info is required when compiling the expression and is used in "MagicHaskeller.RunAnalytical". +getManyTyped :: SplicedPrims -- ^ target function definition by example + -> SplicedPrims -- ^ background knowledge function definitions by example + -> [[Exp]] +getManyTyped (tgt,pt) (bk,pb) + = let ps = pt++pb + tcl = primitivesToTCL ps + vl = primitivesToVL tcl ps + (unit, ty) = analyticSynthAndInfType tcl vl tgt bk + addSignature thexp = SigE thexp $ typeToTHType tcl ty + in map (map (addSignature . exprToTHExpLite vl)) $ unMx $ toMx (unit :: Strategy CoreExpr) + +noBK :: SplicedPrims +noBK = ([],[]) + +c :: Q [Dec] -> ExpQ +-- ^ Also, @ $(c [d| ... |]) :: SplicedPrims @ +-- 'c' is a helper function for extracting some info from the quasi-quoted declarations. +c decq = do decs <- decq + expdecs <- decsToExpDecs decs + expPrims <- fmap ListE $ mapM p1 $ cons decs + return $ TupE [expdecs, expPrims] + +cons, conEs, conPs :: (Data a, Typeable a) => a -> [Exp] +cons a = conEs a ++ conPs a +conEs = everything (++) (mkQ [] (\x -> [ e | e@(ConE _) <- [x]])) +conPs = everything (++) (mkQ [] (\x -> [ ConE name | (ConP name _) <- [x]])) + + +-- Functions appearing from here are easier to use, but they work only for limited types, included in 'defaultPrimitives'. + +getOne :: [Dec] -> [Dec] -> Exp +-- ^ Example: +-- +-- >>> runQ [d| f [] = 0; f [a] = 1; f [a,b] = 2 |] >>= \iops -> putStrLn $ pprint $ getOne iops [] +-- > \a -> let fa (b@([])) = 0 +-- > fa (b@(_ : d)) = succ (fa d) +-- > in fa a +getOne iops bk = head $ concat $ synth iops bk +synth :: [Dec] -> [Dec] -> [[Exp]] +synth iops bk + = map (map (exprToTHExp defaultVarLib)) $ unMx $ toMx (analyticSynth defaultTCL defaultVarLib iops bk :: Strategy CoreExpr) + +-- | 'synthTyped' is like synth, but adds the infered type signature to each expression. This is useful for executing the expression at runtime using GHC API. +synthTyped :: [Dec] -> [Dec] -> [[Exp]] +synthTyped iops bk + = let (unit, ty) = analyticSynthAndInfType defaultTCL defaultVarLib iops bk + addSignature thexp = SigE thexp $ typeToTHType defaultTCL ty + in map (map (addSignature . exprToTHExpLite defaultVarLib)) $ unMx $ toMx (unit :: Strategy CoreExpr) +synthesize :: [Dec] -> [Dec] -> [[String]] +synthesize iops bk + = map (map pprint) $ synth iops bk diff --git a/MagicHaskeller/Analytical/FMExpr.hs b/MagicHaskeller/Analytical/FMExpr.hs new file mode 100644 --- /dev/null +++ b/MagicHaskeller/Analytical/FMExpr.hs @@ -0,0 +1,119 @@ +-- +-- (C) Susumu Katayama +-- +-- Finite trie indexed by Expr, used for fast pattern match +module MagicHaskeller.Analytical.FMExpr where + +import qualified Data.IntMap as IntMap + +import qualified MagicHaskeller.Types as Types + +import MagicHaskeller.Analytical.Syntax + + +iopsToVisFME :: TBS -> [IOPair] -> FMExpr [IOPair] +iopsToVisFME tbs = iopsToFME . map (visIOP tbs) +iopsToFME :: [IOPair] -> FMExpr [IOPair] +iopsToFME = assocsToFME . map iop2Assoc + +visIOP :: TBS -> IOPair -> IOPair +visIOP tbs iop = iop {inputs = visibles tbs $ inputs iop} + +iop2Assoc :: IOPair -> (Expr, IOPair) +iop2Assoc iop = (output iop, iop) + + + +-- | @FMExpr a@ is a finite trie representing @Expr -> a@ +data FMExpr a = EmptyFME -- use of emptyFME in place of EmptyFME should not be as efficient, because there are many EmptyFME's. + | FME { existentialFME :: IntMap.IntMap a, universalFME :: [a], conApFME :: IntMap.IntMap (FMExprs a) } deriving Show +data FMExprs a = EmptyFMEs -- and there are many EmptyFMEs's, too. + | FMEs { nilFMEs :: a, consFMEs :: FMExpr (FMExprs a) } deriving Show +instance Functor FMExpr where + fmap _ EmptyFME = EmptyFME + fmap f (FME {existentialFME=e, universalFME=u, conApFME=c}) = FME{existentialFME = fmap f e, universalFME = fmap f u, conApFME = fmap (fmap f) c} +instance Functor FMExprs where + fmap f EmptyFMEs = EmptyFMEs + fmap f (FMEs {nilFMEs = n, consFMEs = c}) = FMEs {nilFMEs = f n, consFMEs = fmap (fmap f) c} +assocsToFME :: [(Expr, a)] -> FMExpr [a] +assocsToFME = foldr (\(k,v) -> updateFME (v:) [] k) emptyFME +updateFME :: (a->a) -> a -> Expr -> FMExpr a -> FMExpr a +updateFME f x t EmptyFME = updateFME f x t emptyFME +updateFME f x (E i) fme = fme { existentialFME = IntMap.insertWith (\_ -> f) i (f x) $ existentialFME fme } +updateFME f x (U i) fme = fme { universalFME = insertNth f x i $ universalFME fme } +updateFME f x (C _ (c Types.:::_) fs) fme = fme { conApFME = IntMap.insertWith (\_ -> updateFMEs f x fs) c (updateFMEs f x fs EmptyFMEs) $ conApFME fme } +updateFMEs f x es EmptyFMEs = updateFMEs f x es FMEs{nilFMEs = x, consFMEs = EmptyFME} +updateFMEs f x [] fmes = fmes { nilFMEs = f $ nilFMEs fmes } +updateFMEs f x (e:es) fmes = fmes { consFMEs = updateFME (updateFMEs f x es) EmptyFMEs e $ consFMEs fmes } +emptyFME = FME{ existentialFME = IntMap.empty, universalFME = [], conApFME = IntMap.empty } + + +insertNth upd zero n [] = replicate n zero ++ [upd zero] +insertNth upd zero 0 (x:xs) = upd x : xs +insertNth upd zero n (x:xs) = x : insertNth upd zero (n-1) xs + + + +-- returns the set of possible substitutions. Should the name be matchFME? +unifyFME :: Expr -> FMExpr a -> [(a,Subst)] +unifyFME x fme = unifyFME' x fme emptySubst +--unifyFME = matchFME +unifyFME' :: Expr -> FMExpr a -> Subst -> [(a,Subst)] +unifyFME' x EmptyFME s = [] +unifyFME' x@(E i) fme s = error "cannot happen for now" + {- +unifyFME' x@(E i) fme s o = case lookup i s of Nothing -> [ (x, [(i,e')] `plusSubst` s) | (e,x) <- assocsFME fme, let e' = fresh (o+) e ] -- assocsFME :: FMExpr a -> [(Expr,a)]¤À¤±¤É¡¤FMExpr¤Ë¾ðÊó¤ò»Ä¤·¤Æ¤ª¤±¤Ð̵Â̤ʷ׻»¤¬¤Ê¤¯¤Ê¤ë¤«¡¥¤Æ¤æ¡¼¤«¡¤Typed Constr¤ÎType¤ÎÉôʬ¤Î¤¿¤á¤Ë¤½¤¦¤¹¤ëɬÍפ¬¤¢¤ë¡¥ + Just e -> unifyFME' e fme s o +-} +unifyFME' x@(U i) fme s = [ (v, subst `plusSubst` s) + | (k,v) <- zip [0..] (universalFME fme) + , subst <- case lookup k s of Nothing -> [[(k,x)]] + Just (E j) -> [[(j,x)]] + Just (U j) | i==j -> [[]] + _ -> [] + ] +unifyFME' x@(C _sz (c Types.::: _) xs) fme s = matchExistential ++ matchConstr + where matchExistential = [ (v, subst `plusSubst` s) + | (k,v) <- zip [0..] (universalFME fme) + , subst <- case lookup k s of Nothing -> [[(k,x)]] + Just e -> unify e x + ] + matchConstr = case IntMap.lookup c (conApFME fme) of Nothing -> [] + Just fmes -> unifyFMEs xs fmes s +unifyFMEs :: [Expr] -> FMExprs a -> Subst -> [(a,Subst)] +unifyFMEs _ EmptyFMEs _ = [] +unifyFMEs [] fmes s = [ (nilFMEs fmes, s) ] +unifyFMEs (x:xs) fmes s = [ t | (fmes', s') <- unifyFME' x (consFMEs fmes) s, t <- unifyFMEs xs fmes' s' ] + +assocsFME :: FMExpr a -> [(Expr,a)] +assocsFME EmptyFME = [] +assocsFME fme = [ (E i, v) | (i,v) <- IntMap.toList (existentialFME fme) ] ++ [ (U i, v) | (i,v) <- zip [0..] (universalFME fme) ] + ++ [ (C (sum $ map size xs) (c Types.::: error "Not implemented yet!") xs, v) | (c,fmes) <- IntMap.toList (conApFME fme), (xs, v) <- assocsFMEs fmes ] +assocsFMEs :: FMExprs a -> [([Expr],a)] +assocsFMEs EmptyFMEs = [] +assocsFMEs fmes = ([], nilFMEs fmes) : [ (x:xs, v) | (x,fmes') <- assocsFME (consFMEs fmes), (xs, v) <- assocsFMEs fmes ] + + +-- û¤¯¤·¤¿Êª¡¥¸úΨ¤Ï³Îǧ¤·¤Æ¤Ê¤¤¡¥ +matchFME :: Expr -> FMExpr a -> [(a,Subst)] +matchFME x fme = matchFME' x fme emptySubst +matchFME' :: Expr -> FMExpr a -> Subst -> [(a,Subst)] +matchFME' x EmptyFME s = [] +matchFME' x@(E i) fme s = error "cannot happen" +-- Universal variables only match to existentials +matchFME' x@(U _) fme s = matchExistential x fme s +-- Constractor applications can match to both existentials and constructor applications with the same constructor. +matchFME' x@(C _sz (c Types.::: _) xs) fme s = matchExistential x fme s ++ matchConstr + where matchConstr = case IntMap.lookup c (conApFME fme) of Nothing -> [] + Just fmes -> matchFMEs xs fmes s +matchExistential x fme s = [ (v, subst `plusSubst` s) + | (k,v) <- zip [0..] (universalFME fme) + , subst <- case lookup k s of Nothing -> [[(k,x)]] + Just e -> unify e x + ] +-- matchFMEs matches corresponding constructor fields +matchFMEs :: [Expr] -> FMExprs a -> Subst -> [(a,Subst)] +matchFMEs _ EmptyFMEs _ = [] +matchFMEs [] fmes s = [ (nilFMEs fmes, s) ] +matchFMEs (x:xs) fmes s = [ t | (fmes', s') <- matchFME' x (consFMEs fmes) s, t <- matchFMEs xs fmes' s' ] + diff --git a/MagicHaskeller/Analytical/Parser.hs b/MagicHaskeller/Analytical/Parser.hs new file mode 100644 --- /dev/null +++ b/MagicHaskeller/Analytical/Parser.hs @@ -0,0 +1,216 @@ +-- +-- (C) Susumu Katayama +-- +module MagicHaskeller.Analytical.Parser where + +import Data.List(sort, group) +import Control.Monad -- hiding (guard) +import Control.Monad.State -- hiding (guard) +import Data.Char(ord) +import Data.Array +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap +import Language.Haskell.TH hiding (match) + +import MagicHaskeller.CoreLang(VarLib) +import qualified MagicHaskeller.Types as Types +import MagicHaskeller.PriorSubsts hiding (unify) +import MagicHaskeller.TyConLib +import MagicHaskeller.ReadTHType(thTypeToType) +import qualified MagicHaskeller.PolyDynamic as PD + +import MagicHaskeller.Analytical.Syntax + + +data XVarLib = XVL {varLib :: VarLib, invVarLib :: Map.Map String Int, zeroID :: Int, succID :: Int, negateID :: Int} deriving Show + +-- We compare nameBase ignoring the module name, instead of using equivalence over Name's. +mkXVarLib :: VarLib -> XVarLib +mkXVarLib vl = let + (_,mx) = bounds vl + in XVL {varLib = vl + , invVarLib = Map.fromListWith (\_ a -> a) ([ (nameBase name, num) | (num, PD.Dynamic{PD.dynExp=thexpr}) <- assocs vl, name <- extractName thexpr ]) + , zeroID = mx-2 -- These are dependent on the order in CoreLang.defaultPrimitives + , succID = mx-1 + , negateID = mx + } +extractName (ConE name) = [name] +extractName (VarE name) = [name] +extractName _ = [] +parseTypedIOPairss :: (Functor m, MonadPlus m) => TyConLib -> XVarLib -> [Dec] -> PriorSubsts m [(Name, Types.Typed [IOPair])] +parseTypedIOPairss tcl xvl ds = inferTypedIOPairss =<< parseTypedIOPairss' tcl xvl ds +inferTypedIOPairss :: MonadPlus m => [(Name,(Maybe Types.Type, Maybe (Types.Typed [IOPair])))] -> PriorSubsts m [(Name, Types.Typed [IOPair])] +inferTypedIOPairss ((name, (Just ty, Just (iops Types.::: infty))):ts) + = do apinfty <- applyPS infty + mguPS apinfty $ Types.quantify ty + updateSubstPS (return . unquantifySubst) + + s <- getSubst + let hd = (name, map (tapplyIOP s) iops Types.:::ty) + tl <- inferTypedIOPairss ts + return (hd:tl) +inferTypedIOPairss ((name, (Nothing, Just (iops Types.::: infty))):ts) + = do s <- getSubst + let hd = (name, map (tapplyIOP s) iops Types.::: Types.apply s infty) + tl <- inferTypedIOPairss ts + return (hd:tl) +inferTypedIOPairss ((_nam, (Just _t, Nothing)):ts) = inferTypedIOPairss ts -- pattern including only a type signature. This is still useful when incorporating with MagicHaskeller, but MagH has its own parser, so let's ignore the pattern silently. +inferTypedIOPairss ((_, (Nothing, Nothing)):_) = error "MagicHaskeller.TypedIOPairs.inferTypedIOPairss: impossible" +inferTypedIOPairss [] = return [] + +parseTypedIOPairss' :: (Functor m,MonadPlus m) => TyConLib -> XVarLib -> [Dec] -> PriorSubsts m [(Name, (Maybe Types.Type, Maybe (Types.Typed [IOPair])))] +parseTypedIOPairss' tcl xvl ds + = do tups <- parseIOPairss xvl ds + return $ Map.toList $ Map.fromListWith plus + ([(name, (Just t, Nothing)) | (name, t) <- parseTypes tcl ds] ++ + [(name, (Nothing, Just tiops)) | (name, tiops) <- tups]) +(a,b) `plus` (c,d) = (a `mplus` c, b `mplus` d) + +parseTypes :: TyConLib -> [Dec] -> [(Name,Types.Type)] +parseTypes tcl ds = [ (name, thTypeToType tcl ty) | SigD name ty <- ds ] + + +parseIOPairss :: (Functor m, MonadPlus m) => XVarLib -> [Dec] -> PriorSubsts m [(Name, Types.Typed [IOPair])] +parseIOPairss xvl (FunD funname clauses : decs) + = do tiops <- mapM (clauseToIOPair xvl) clauses + let (iops,t:ts) = unzipTyped tiops + ty <- foldM mgtPS t ts + s <- getSubst + let hd = (funname, map (tapplyIOP s) iops Types.::: ty) + tl <- parseIOPairss xvl decs + return $ hd:tl +parseIOPairss xvl (ValD (VarP name) (NormalB ex) [] : decs) + = do (vout Types.::: tout, _intmap) <- runStateT (inferType (thExpToExpr xvl ex)) IntMap.empty + let hd = (name, [IOP 0 [] vout] Types.::: tout) + tl <- parseIOPairss xvl decs + return $ hd:tl +parseIOPairss xvl (_:decs) = parseIOPairss xvl decs +parseIOPairss _ [] = return [] + +-- ·¿Àë¸À¤¬¤¢¤ë¾ì¹ç¡¤¤½¤Îforall¤Ê¤ä¤Ä¤Ë¥Þ¥Ã¥Á¤·¤Æ½ªÎ»¡¥ +-- ¤Ê¤¤¾ì¹ç¡¤¤½¤Î¤Þ¤Þ´Ø¿ô¤Ë¤·¤Æ½ªÎ»¡¥ +clauseToIOPair :: (Functor m, MonadPlus m) => XVarLib -> Clause -> PriorSubsts m (Types.Typed IOPair) +clauseToIOPair ivl cl = fmap fst $ runStateT (clauseToIOPair' ivl cl) IntMap.empty +clauseToIOPair' ivl (Clause inpats (NormalB ex) []) =do ins <- mapM inferT (reverse $ map (patToExp ivl) inpats) + let (vins,tins) = unzipTyped ins + vout Types.::: tout <- inferT (thExpToExpr ivl ex) + ty <- lift $ applyPS (Types.popArgs tins tout) + return $ normalizeMkIOP vins vout Types.::: ty +clauseToIOPair' _ _ = error "Neither _guards_ nor _where_clauses_ are permitted in clauses representing I/O pairs." +-- In future where-clauses might be supported. + + +matchType :: MonadPlus m => [Types.Type] -> Types.Type -> Types.Type -> PriorSubsts m () +matchType argtys retty ty = mguType argtys retty (Types.quantify ty) >> updateSubstPS (return . unquantifySubst) +unquantifySubst = map (\(v,t) -> (v, Types.unquantify t)) +mguType (t:ts) r (u Types.:->v) = do mguPS t u + s <- getSubst + mguType (map (Types.apply s) ts) (Types.apply s r) v +mguType [] r v = Types.mgu r v +mguType (_:_) _ _ = error "Not enough arguments supplied." + + +inferType, inferT :: MonadPlus m => Expr -> StateT (IntMap.IntMap Types.Type) (PriorSubsts m) (Types.Typed Expr) +inferType e = do e' Types.:::t <- inferT e + s <- lift getSubst + return (tapplyExpr s e' Types.::: Types.apply s t) +inferT v@(U i) = do tenv <- get + case IntMap.lookup i tenv of + Nothing -> do tvid <- lift newTVar + let ty = Types.TV tvid + put $ IntMap.insert i ty tenv + return (v Types.::: ty) + Just ty -> do apty <- lift $ applyPS ty + return (v Types.::: apty) +inferT (C sz (i Types.:::ty) es) + = do es' <- mapM inferT es + lift $ do let (typees, typers) = unzipTyped es' + let tvs = map head $ group $ sort $ Types.tyvars ty + tvid <- reserveTVars $ length tvs + let apty = Types.apply (zip tvs $ map Types.TV [tvid..]) ty + rty <- foldM funApM apty typers + rapty <- applyPS rty + return $ C sz (i Types.:::apty) typees Types.::: rapty +funApM :: MonadPlus m => Types.Type -> Types.Type -> PriorSubsts m Types.Type +funApM (a Types.:-> r) t = fAM a r t +funApM (a Types.:> r) t = fAM a r t +funApM (Types.TV i) t = do tvid <- newTVar + updatePS [(i,t Types.:->Types.TV tvid)] + return $ Types.TV tvid +funApM _ _ = fail "too many arguments applied." +fAM apa r t = do apt <- applyPS t + mguPS apa apt + applyPS r +tapplyIOP :: Types.Subst -> IOPair -> IOPair +tapplyIOP s (IOP bvs ins out) = IOP bvs (map (tapplyExpr s) ins) (tapplyExpr s out) + +tapplyExpr :: Types.Subst -> Expr -> Expr +tapplyExpr sub (C sz (i Types.:::ty) es) = C sz (i Types.:::Types.apply sub ty) (map (tapplyExpr sub) es) +tapplyExpr _ v = v +{- +substitution¤ò°ìÅÙget¤·¤¿¤é¡¤¤½¤ì¤òÁ´ÂΤËÇȵڤµ¤»¤ëɬÍפ¬¤¢¤ë¡© +¤Æ¤æ¡¼¤«¡¤³Æ¥³¥ó¥¹¥È¥é¥¯¥¿¤Îforall¤ÇfreshVar¤·¤¿¤ä¤Ä¤À¤±¤¹¤ì¤Ð¤è¤¤¡© +¹Í¤¨¤ë¤ÎÌÌÅݤ¯¤µ¤¤¤·¡¤Î§Â®¤Ç¤Ï¤Ê¤¤¤Î¤Ç2¥Ñ¥¹¤Ç¡¥ +-} + +-- MagicHaskeller.Types¤ËÃÖ¤¯¤Ù¤­¤È¤¤¤¦µ¤¤¬¤·¤Ê¤¤¤Ç¤â¤Ê¤¤¡¥ +unzipTyped [] = ([],[]) +unzipTyped ((e Types.:::t):ets) = let (es,ts) = unzipTyped ets in (e:es,t:ts) + + +getMbTypedConstr :: XVarLib -> Name -> Maybe (Types.Typed Constr) +getMbTypedConstr xvl name = fmap (mkTypedConstr xvl) $ Map.lookup (nameBase name) (invVarLib xvl) +getTypedConstr :: XVarLib -> Name -> Types.Typed Constr +getTypedConstr xvl name = let c = invVarLib xvl Map.! (nameBase name) in mkTypedConstr xvl c +mkTypedConstr xvl c = c Types.::: PD.dynType (varLib xvl!c) +patToExp ivl (LitP (IntegerL i)) | i>=0 = natToConExp ivl i + | otherwise = cap (mkTypedConstr ivl (negateID ivl)) [natToConExp ivl (-i)] +-- patToExp tcl (LitP (CharL c)) = C (Ctor (ord c) (c¤ËÁêÅö¤¹¤ëÅÛ. ¤¢¤ëÌõ¤Ê¤¤?)) [] +-- patToExp tcl (LitP (StringL str)) = strToConExp tcl str +patToExp ivl (VarP name) = U (strToInt $ nameBase name) +patToExp ivl (TupP pats) = cap (getTypedConstr ivl (tupleDataName (length pats))) (map (patToExp ivl) pats) +patToExp ivl (ConP name pats) = cap (getTypedConstr ivl name) (map (patToExp ivl) pats) +patToExp ivl (InfixP p1 name p2) = cap (getTypedConstr ivl name) (map (patToExp ivl) [p1,p2]) +patToExp ivl (TildeP p) = patToExp ivl p +patToExp ivl (AsP _ _) = error "As (@) patterns not supported." +patToExp ivl WildP = U (strToInt "_") -- will not work correctly if there are more than one wildcards in one I/O pair, I think. +patToExp ivl (RecP _ _) = error "Record patterns not supported." +patToExp ivl (ListP pats) = foldr cons nil $ map (patToExp ivl) pats + where nil = C 1 (getTypedConstr ivl '[]) [] + cons e1 e2 = cap (getTypedConstr ivl '(:)) [e1,e2] +patToExp ivl (SigP pat _t) = patToExp ivl pat -- Or should this cause an error? + +-- Is this encoding really quicker than raw String (or maybe PackedString)? +strToInt [] = 1 +strToInt (x:xs) = ord x + 256 * strToInt xs + +natLimit = 32 +natToConExp ivl i -- x | i > natLimit = C (Ctor i (i¤ËÁêÅö¤¹¤ëÅÛ. ¤¢¤ëÌõ¤Ê¤¤?)) [] + | otherwise = smallNat ivl i +smallNat ivl 0 = C 1 (mkTypedConstr ivl (zeroID ivl)) [] +smallNat ivl i = cap (mkTypedConstr ivl (succID ivl)) [smallNat ivl (i-1)] +-- strToConExp tcl "" = C (Ctor 0 ([]¤ËÁêÅö¤¹¤ëÅÛ)) [] + +thExpToExpr ivl (VarE name) = case getMbTypedConstr ivl name of Nothing -> U (strToInt $ nameBase name) + Just x -> C 1 x [] +thExpToExpr ivl (ConE name) = C 1 (getTypedConstr ivl name) [] +thExpToExpr ivl (LitE (IntegerL i)) | i >= 0 = natToConExp ivl i + | otherwise = cap (mkTypedConstr ivl (negateID ivl)) [natToConExp ivl (-i)] +thExpToExpr ivl (AppE f x) = case thExpToExpr ivl f of C sz c xs -> let thx = thExpToExpr ivl x + in C (sz + size thx) c (xs ++ [thx]) -- O(n^2) + U _ -> error "Only constructor applications are permitted in IO examples." +thExpToExpr ivl (InfixE (Just x) (ConE name) (Just y)) = cap (getTypedConstr ivl name) [thExpToExpr ivl x, thExpToExpr ivl y] +thExpToExpr ivl (InfixE (Just x) (VarE name) (Just y)) = cap (getTypedConstr ivl name) [thExpToExpr ivl x, thExpToExpr ivl y] +thExpToExpr ivl (TupE es) = cap (getTypedConstr ivl (tupleDataName (length es))) (map (thExpToExpr ivl) es) +thExpToExpr ivl (ListE es) = foldr cons nil $ map (thExpToExpr ivl) es + where nil = cap (getTypedConstr ivl '[]) [] + cons e1 e2 = cap (getTypedConstr ivl '(:)) [e1,e2] +thExpToExpr ivl (SigE e _t) = thExpToExpr ivl e +thExpToExpr _ _ = error "Unsupported expression in IO examples." +{- +case¤Î¾ì¹ç¡¤´û¤Ë¤¢¤ëprimitive component¤Ë¹ç¤ï¤»¤ë¤Î¤Ï·ë¹½¤ä¤ä¤³¤·¤¤¡¥¡Ê¤¿¤È¤¨¤Ð¡¤¥³¥ó¥¹¥È¥é¥¯¥¿¤Î½ç½ø¤Å¤±¤È¤«¤ò¹ç¤ï¤»¤ë¤Î¤Ï¤Ã¤Æ¤³¤È¤Í¡¥¡Ë +¥³¥ó¥¹¥È¥é¥¯¥¿¤Î½ç½ø¤Å¤±¤Ïreify¤Ç¥²¥Ã¥È¤·¤¿½ç¤Ë¤¹¤ë¤³¤È¤Ë¤·¤Æ¡¤case¤ÏľÀÜTH¤òÀ¸À®¤¹¤ë¤³¤È¤Ë¤¹¤ë¡¥ +¤³¤ì¤¬²Äǽ¤Ê¤Î¤Ï¡¤¤Þ¤ºanalytical¤ä¤Ã¤Æ¤½¤ì¤«¤ésystematic¤ò¤ä¤ë¤«¤é¡¥ + +¤½¤¦¤Ê¤ë¤È¡¤clauseToIOPair¤È¤«¤ËVarLib¤Ï¤¤¤é¤Ê¤¯¤Ê¤ë¤·¡¤Constr¤ÏCoreExpr¤ÎÂå¤ï¤ê¤ËTH.Exp(¤«TH.Name)¤ò»ý¤Ä¤³¤È¤Ë¤Ê¤ë¡¥ +-} diff --git a/MagicHaskeller/Analytical/Syntax.hs b/MagicHaskeller/Analytical/Syntax.hs new file mode 100644 --- /dev/null +++ b/MagicHaskeller/Analytical/Syntax.hs @@ -0,0 +1,158 @@ +-- +-- (C) Susumu Katayama +-- +module MagicHaskeller.Analytical.Syntax where + +import Control.Monad -- hiding (guard) +import Data.List(nub) + +import qualified MagicHaskeller.Types as Types + +-- +-- Datatypes +-- + +data IOPair = IOP { numUniIDs :: Int -- ^ number of variables quantified with forall + , inputs :: [Expr] -- ^ input example for each argument. The last argument comes first. + , output :: Expr} + deriving (Show,Eq) + +type TBS = [Bool] -- ^ the to-be-sought list +data Expr = E Int -- ^ existential variable. When doing analytical synthesis, there is no functional variable. + | U Int -- ^ universal variable. When doing analytical synthesis, there is no functional variable. + -- Int¤Ç¤Ï¤Ê¤¯TH.Name¤òľÀܻȤä¿Êý¤¬¤è¤¤¡© + | C {sz :: Int, ctor :: Types.Typed Constr, fields :: [Expr]} + deriving (Eq, Show) +type Constr = Int +normalizeMkIOP :: [Expr] -> Expr -> IOPair +normalizeMkIOP ins out = let varIDs = nub $ concatMap vr (out : ins) + tup = zip varIDs [0..] + in mapIOP (mapU (\tv -> case lookup tv tup of Just n -> n)) IOP{numUniIDs = length varIDs, inputs = ins, output = out} +vr (U i) = [i] +vr (C _ _ es) = concatMap vr es +mapU f (U i) = U $ f i +mapU f (C sz c xs) = C sz c $ map (mapU f) xs + +maybeCtor :: Expr -> Maybe (Types.Typed Constr) +maybeCtor (C _ c _) = Just c +maybeCtor _ = Nothing + +hasExistential (E _) = True +hasExistential (U _) = False +hasExistential (C _ _ es) = any hasExistential es + +visibles tbs ins = [ i | (True,i) <- zip tbs ins ] + +-- +-- unification +-- + +type Subst = [(Int,Expr)] + + +unify (C _ i xs) (C _ j ys) | i==j = unifyList xs ys + | otherwise = mzero +unify e f | e==f = return [] +unify (E i) e = bind i e +unify e (E i) = bind i e +unify _ _ = mzero + +unifyList [] [] = return [] +unifyList (x:xs) (y:ys) = do s1 <- unify x y + s2 <- unifyList (map (apply s1) xs) (map (apply s1) ys) + return $ s2 `plusSubst` s1 +unifyList _ _ = error "Partial application to a constructor." -- Can this happen? + +bind i e | i `occursIn` e = mzero -- I think permitting infinite data would break the unification algorithm. + | otherwise = return [(i,e)] + +-- | 'apply' applies a substitution which replaces existential variables to an expression. +apply subst v@(E i) = maybe v id $ lookup i subst +apply subst v@(U _) = v +apply subst (C _ i xs) = cap i (map (apply subst) xs) -- ÃÙ¤¤¤«¤Í + +i `occursIn` (E j) = i==j +i `occursIn` (U _) = False +i `occursIn` (C _ _ xs) = any (i `occursIn`) xs + + +plusSubst :: Subst -> Subst -> Subst +s0 `plusSubst` s1 = [(u, apply s0 t) | (u,t) <- s1] ++ s0 + +emptySubst = [] + + +fresh f e@(E _) = e +fresh f (U i) = E $ f i +fresh f (C s c xs) = C s c (map (fresh f) xs) +-- | fusion of @apply s@ and @fresh f@ +apfresh s e@(E _) = e -- NB: this RHS is incorrect if apfresh is used for UniT (because s may include a replacement of e). +apfresh s (U i) = maybe (E i) id $ lookup i s +apfresh s (C _sz c xs) = cap c (map (apfresh s) xs) +mapE f e@(U _) = e +mapE f (E i) = E $ f i +mapE f (C s c xs) = C s c (map (mapE f) xs) + + +-- Note that numUniIDs will not be touched. +applyIOPs s iops = map (applyIOP s) iops +applyIOP s iop = mapIOP (apply s) iop +mapIOP f (IOP bvs ins out) = IOP bvs (map f ins) (f out) +mapTypee f (x Types.::: t) = f x Types.::: t + + +-- +-- termination +-- + +newtype TermStat = TS {unTS :: [Bool]} deriving Show + +initTS :: TermStat +initTS = TS $ replicate (length termCrit) True +updateTS :: [Expr] -> [Expr] -> TermStat -> TermStat +updateTS bkis is (TS bs) = TS $ zipWith (&&) bs [ bkis < is | (<) <- termCrit ] +evalTS :: TermStat -> Bool +evalTS (TS bs) = or bs + +-- termination criteria. Enumerate anything that come to your mind. (Should this be an option?) +termCrit :: [[Expr]->[Expr]->Bool] +-- termCrit = [fullyLex, aWise, revFullyLex, revAWise ] -- , linear +--termCrit = [aWise,revAWise] +termCrit = [aWise] + +fullyLex, revFullyLex, aWise, revAWise, linear :: [Expr]->[Expr]->Bool +fullyLex = lessRevListsLex cmpExprs +revFullyLex= lessListsLex cmpExprs +aWise = lessRevListsLex cmpExprSzs +revAWise = lessListsLex cmpExprSzs +-- linear is really slow, so is not recommended. +linear ls rs = sum (map size ls) < sum (map size rs) +-- ¤Ç¤â¡¤case¤Ç¤Ö¤Ã¤¿Àڤ俤¢¤È¤Î¤¹¤Ù¤Æ¤Î°ú¿ô¤òÈæ³Ó¤·¤Æ¤¤¤ë¤«¤éÃÙ¤¤¤Î¤Ç¤¢¤Ã¤Æ¡¤°ìÈֺǽé¤ÎÃʳ¬¤Î°ú¿ô¤À¤±¤ÇÈæ³Ó¤¹¤ì¤Ð®¤¤¤Î¤Ç¤Ï¡© +-- ¤Ç¤â¡¤Ackermann's function¤Ç¹Í¤¨¤ë¤È¡¤¤ä¤Ã¤Ñ¤½¤ì¤Ç¤Ï¥À¥á¤Ã¤Ý¤¤¡¥ + +revArgs :: ([Expr]->[Expr]->Bool) -> [Expr]->[Expr]->Bool +revArgs cmp ls rs = cmp (reverse ls) (reverse rs) + +lessRevListsLex cmp = revArgs (lessListsLex cmp) +lessListsLex cmp [] _ = False -- In general, input arguments of BKs should be shorter, and we have to compare only this length. +lessListsLex cmp (e0:es0) (e1:es1) = case cmp e0 e1 of LT -> True + EQ -> lessListsLex cmp es0 es1 + GT -> False +cmpExprss [] [] = EQ +cmpExprss [] _ = LT +cmpExprss _ [] = GT +cmpExprss (e0:es0) (e1:es1) = case cmpExprs e0 e1 of EQ -> cmpExprss es0 es1 + c -> c +cmpExprs (C _ _ fs) (C _ _ gs) = cmpExprss fs gs +cmpExprs _ (C _ _ _) = LT +cmpExprs (C _ _ _) _ = GT +cmpExprs _ _ = EQ + +cmpExprSzs e0 e1 = compare (size e0) (size e1) +size (C sz _ fs) = sz +size _ = 1 -- questionable? +cap con fs = C (1 + sum (map size fs)) con fs + +-- Q: Are existential variables always smaller than constructor applications? A: No, I'm afraid. +-- If we want to make sure the termination, we can always return GT when questionable; +-- if we want to save all questionable expressions, we can always return LT when questionable. diff --git a/MagicHaskeller/Analytical/Synthesize.hs b/MagicHaskeller/Analytical/Synthesize.hs new file mode 100644 --- /dev/null +++ b/MagicHaskeller/Analytical/Synthesize.hs @@ -0,0 +1,408 @@ +-- +-- (C) Susumu Katayama +-- +{-# LANGUAGE CPP #-} +module MagicHaskeller.Analytical.Synthesize where + +import Data.List(transpose) +-- import Control.Monad.Search.RecompDL -- a version using DList, but did not actually improve the efficiency. +import Control.Monad -- hiding (guard) +import Control.Monad.State -- hiding (guard) +import qualified Data.IntMap as IntMap + +import Language.Haskell.TH + +import Control.Monad.Search.Combinatorial +import MagicHaskeller.CoreLang hiding (C) +import qualified MagicHaskeller.Types as Types +import MagicHaskeller.TyConLib +import MagicHaskeller.PriorSubsts hiding (unify) + +import MagicHaskeller.Analytical.Syntax +import MagicHaskeller.Analytical.Parser +import MagicHaskeller.Analytical.UniT +import MagicHaskeller.Analytical.FMExpr + +-- | function specification by examples. +data Fun = BKF {maxNumBVs :: Int, arity :: Int, iopairs :: [IOPair], fmexpr :: FMExpr [IOPair]} -- ^ the function is really a background knowledge (and thus there is no need for loop check) + | Rec {maxNumBVs :: Int, arity :: Int, iopairs :: [IOPair], fmexpr :: FMExpr [IOPair], toBeSought :: TBS} -- ^ it is actually a recursive call. +mkBKFun iops@(iop:_) = BKF {maxNumBVs = maximum $ map numUniIDs iops, arity = length $ inputs iop, iopairs = iops, fmexpr = iopsToFME iops} +mkRecFun ari tbs iops@(iop:_) = Rec {maxNumBVs = maximum $ map numUniIDs iops, arity = ari, iopairs = iops, fmexpr = iopsToVisFME tbs iops, toBeSought = tbs} -- arity = filter id tbs, but it is usually know beforehand +setIOPairs iops recfun@Rec{toBeSought=tbs} = recfun{iopairs = iops, fmexpr = iopsToVisFME tbs iops} +type BK = [Types.Typed Fun] -- ^ background knowledge. + +applyFun s fun = fun{iopairs = applyIOPs s (iopairs fun)} + + +analyticSynth :: Search m => TyConLib -> VarLib -> [Dec] -> [Dec] -> m CoreExpr +analyticSynth tcl vl target bkdec = fst $ analyticSynthAndInfType tcl vl target bkdec +analyticSynthAndInfType :: Search m => TyConLib -> VarLib -> [Dec] -> [Dec] -> (m CoreExpr, Types.Type) +analyticSynthAndInfType tcl vl target bkdec + = case unPS (liftM2 (,) (parseTypedIOPairss tcl xvl target) (parseTypedIOPairss tcl xvl bkdec)) Types.emptySubst 0 of + Nothing -> error "Type error occurred while reading the IO pairs." + Just (([],_),_,_) ->error "TypedIOPairs.analyticSynth*: No I/O pairs are defined as the target." + Just (([(targetFunName, iops@(iop:_) Types.:::ty)],bktups),_,mx) -> + let (bknames, bktiopss) = unzip bktups + (bkiopss, bktypes) = unzipTyped bktiopss + target = mkRecFun aritar tbs iops + tbs = replicate aritar True + aritar = length $ inputs iop + bk = reverse $ zipWith (Types.:::) (map mkBKFun $ bkiopss) bktypes + in (fmap (\e -> napply (length bktups) FunLambda $ napply aritar Lambda (Fix e aritar [aritar-1, aritar-2..0])) $ -- $ Fix e $ map X [arity-1, arity-2 .. 0]) $ -- ËÜÅö¤Ï¤³¤Î·ë²Ì¤Î¤½¤ì¤¾¤ì¤Ë bknames¤òŬÍѤ·¤¿¤¤¤Î¤À¤¬¡¤bknames¤ÊHValue¤¬¤Ê¤¤¤Î¤Ç.... ¤Æ¤æ¡¼¤«¡¤Exp¤Ê¤éºî¤ì¤ë¡¥CoreExpr¤â¡¤BK¤¬Á´ÉôVarLib¤Ë¤Ï¤¤¤Ã¤Æ¤¤¤ì¤Ðºî¤ì¤ë¡¥ + analSynthm {- analSynthNoUniT ¤³¤Ã¤Á¤À¤È¤Á¤ç¤Ã¤È¤¤¤¤²Ã¸º¤Ç¤Á¤ç¤Ã¤È®¤¤ -} bk (target Types.:::ty) + ,ty) + _ -> error "TypedIOPairs.analyticSynth*: More than one I/O pairs are defined as the target." + where xvl = mkXVarLib vl + + +analSynth, analSynthm :: Search m => BK -> Types.Typed Fun -> m CoreExpr +analSynth bk tfun@(fun Types.::: _) | any hasExistential $ map output $ iopairs fun = fmap fst $ runStateT (analSynthUTm bk tfun) emptySt + | otherwise = analSynthm bk tfun +analSynthm bk tfun + = others `mplus` delay bkRelated + where newbk = tfun : bk + bkRelated = headSpine analSynth introBKm newbk tfun + others = headSpine analSynthm (introConstr +++ introVarm +++ ndelayIntro 2 introCase) newbk tfun +headSpine rec intro bk tfun + = do (hd, subfuns, mbpivot) <- intro bk tfun + subexps <- mapM (\subfun -> let arisub = arity $ Types.typee subfun in fmap (\e -> Fix e arisub (mkArgs mbpivot arisub)) $ rec bk subfun) subfuns + return (hd subexps) +#ifdef DEBUG +headSpine_debug rec trs intro bk tfun + = do (hd, subfuns, mbpivot) <- intro bk tfun + subexps <- zipWithM (\tr subfun -> let arisub = arity $ Types.typee subfun in fmap (\e -> Fix e arisub (mkArgs mbpivot arisub)) $ rec tr bk subfun) trs subfuns + return (hd subexps) +#endif + +analSynthUTm :: Search m => BK -> Types.Typed Fun -> UniT m CoreExpr +-- analSynthm ([], _, _) = mzero -- If there is no example, nothing can be done. (But is this line necessary?) +analSynthUTm bk (fun Types.::: ty) + = do + s <- gets subst + let aptfun = applyFun s fun Types.::: ty + newbk = aptfun : bk + headSpine analSynthUTm introAny newbk aptfun + +mkArgs Nothing arisub = [arisub-1,arisub-2..0] +mkArgs (Just pivot) arisub = take pivot [arisub,arisub-1..] ++ [arisub-pivot-1,arisub-pivot-2..0] + +#ifdef DEBUG +analyticSynthNoUniT_debug :: Search m => Tree (Introducer m) -> TyConLib -> VarLib -> [Dec] -> [Dec] -> m CoreExpr +analyticSynthNoUniT_debug tree tcl vl target bkdec + = case unPS (liftM2 (,) (parseTypedIOPairss tcl xvl target) (parseTypedIOPairss tcl xvl bkdec)) Types.emptySubst 0 of + Nothing -> error "Type error occurred while reading the IO pairs." + Just (([],_),_,_) ->error "TypedIOPairs.analyticSynth*: No I/O pairs are defined as the target." + Just (([(targetFunName, iops@(iop:_) Types.:::ty)],bktups),_,mx) -> + let (bknames, bktiopss) = unzip bktups + (bkiopss, bktypes) = unzipTyped bktiopss + target = mkRecFun aritar tbs iops + tbs = replicate aritar True + aritar = length $ inputs iop + bk = reverse $ zipWith (Types.:::) (map mkBKFun $ bkiopss) bktypes + in (fmap (\e -> napply (length bktups) FunLambda $ napply aritar Lambda (Fix e aritar [aritar-1, aritar-2..0])) $ -- $ Fix e $ map X [arity-1, arity-2 .. 0]) $ -- ËÜÅö¤Ï¤³¤Î·ë²Ì¤Î¤½¤ì¤¾¤ì¤Ë bknames¤òŬÍѤ·¤¿¤¤¤Î¤À¤¬¡¤bknames¤ÊHValue¤¬¤Ê¤¤¤Î¤Ç.... ¤Æ¤æ¡¼¤«¡¤Exp¤Ê¤éºî¤ì¤ë¡¥CoreExpr¤â¡¤BK¤¬Á´ÉôVarLib¤Ë¤Ï¤¤¤Ã¤Æ¤¤¤ì¤Ðºî¤ì¤ë¡¥ + analSynthNoUniT_debug tree bk (target Types.:::ty) + ) + _ -> error "TypedIOPairs.analyticSynth*: More than one I/O pairs are defined as the target." + where xvl = mkXVarLib vl +-- analSynthNoUniT is inaccurate, but should work in most cases. This can be used in place of analSynthm +analSynthNoUniT bk tfun + = headSpine analSynthNoUniT (introConstr +++ introVarm +++ ndelayIntro 2 introCase +++ ndelayIntro 1 introBKm) (tfun:bk) tfun +analSynthNoUniT_debug (Br intro trs) bk tfun + = headSpine_debug analSynthNoUniT_debug trs intro (tfun:bk) tfun + + +data Tree x = Br x [Tree x] deriving Show +tryall, tryVar :: Search m => Tree (IntroUniT m) +tryall = Br introAny (repeat tryall) +tryVar = Br introVarUTm [] +tryVarm :: (Functor m, MonadPlus m) => Tree (Introducer m) +tryVarm = Br introVarm [] + +analyticSynth_debug :: Search m => Tree (IntroUniT m) -> TyConLib -> VarLib -> [Dec] -> [Dec] -> m CoreExpr +analyticSynth_debug tree tcl vl target bkdec + = do ((tgt,bktups),_,mx) <- + unPS (liftM2 (,) (parseTypedIOPairss tcl xvl target) (parseTypedIOPairss tcl xvl bkdec)) Types.emptySubst 0 + case tgt of + [] -> error "analyticSynth: No I/O pairs are defined as the target." + [(targetFunName, iops@(iop:_) Types.:::ty)] -> + let (bknames, bktiopss) = unzip bktups + (bkiopss, bktypes) = unzipTyped bktiopss + target = mkRecFun aritar tbs iops + tbs = replicate aritar True + aritar = length $ inputs iop + bk = reverse $ zipWith (Types.:::) (map mkBKFun $ bkiopss) bktypes + in fmap (\(e,_st) -> napply (length bktups) FunLambda $ napply aritar Lambda (Fix e aritar [aritar-1, aritar-2..0])) $ -- $ Fix e $ map X [arity-1, arity-2 .. 0]) $ -- ËÜÅö¤Ï¤³¤Î·ë²Ì¤Î¤½¤ì¤¾¤ì¤Ë bknames¤òŬÍѤ·¤¿¤¤¤Î¤À¤¬¡¤bknames¤ÊHValue¤¬¤Ê¤¤¤Î¤Ç.... ¤Æ¤æ¡¼¤«¡¤Exp¤Ê¤éºî¤ì¤ë¡¥CoreExpr¤â¡¤BK¤¬Á´ÉôVarLib¤Ë¤Ï¤¤¤Ã¤Æ¤¤¤ì¤Ðºî¤ì¤ë¡¥ + runStateT (analSynthUT_debug tree bk (target Types.::: ty)) emptySt -- ONLY DIFFER HERE. + _ -> error "analyticSynth: More than one I/O pairs are defined as the target." + where xvl = mkXVarLib vl + +-- | 'analSynthUT_debug' can be used to try only the given introducer at each selection point. @analSynthUT = analSynthUT_debug tryall@ +analSynthUT_debug :: Search m => Tree (IntroUniT m) -> BK -> Types.Typed Fun -> UniT m CoreExpr +analSynthUT_debug (Br intro iss) bk (fun Types.::: ty) + = do + s <- gets subst + let aptfun = applyFun s fun Types.::: ty + newbk = aptfun : bk + (hd, subfuns, mbpivot) <- intro newbk aptfun + subexps <- zipWithM (\is subfun -> let arisub = arity $ Types.typee subfun in fmap (\e -> Fix e arisub (mkArgs mbpivot arisub)) $ analSynthUT_debug is newbk subfun) iss subfuns + return (hd subexps) +#endif + +type Introducer m = BK -> Types.Typed Fun -> m ([CoreExpr] -> CoreExpr, [Types.Typed Fun], Maybe Int) +type IntroUniT m = Introducer (UniT m) +-- NB: We should not use @StateT Env@ where @Env=(BK,TBS)@ because the Env affects only subexpressions. + +il +++ ir = \bk iops -> il bk iops `mplus` ir bk iops +ndelayIntro n intro = \e a -> ndelay n $ intro e a + +introAny :: Search m => IntroUniT m +introAny = introConstr +++ {- +/ -} ( + introVarUTm +++ + ndelayIntro 1 introBKUTm +++ + ndelayIntro 2 introCase ) + +(+/) :: MonadPlus m => IntroUniT [] -> IntroUniT m -> IntroUniT m +m +/ n = \bk iops -> + do st <- get + case runStateT (m bk iops) st of [] -> n bk iops + ts -> StateT $ \_ -> msum $ map return ts +liftList :: MonadPlus m => StateT s [] a -> StateT s m a +liftList = mapStateT (msum . map return) + +introVarm, introConstr, introCase :: (Functor m, MonadPlus m) => Introducer m -- introConstr¤Ç¤Ï¡¤¼ÂºÝ¤Ë¤ÏCoreExpr¤ÏConstr¤Ç¤è¤¤¡¥ +introBKm :: (Search m) => Introducer m -- introConstr¤Ç¤Ï¡¤¼ÂºÝ¤Ë¤ÏCoreExpr¤ÏConstr¤Ç¤è¤¤¡¥ +introVarUTm, introBKUTm :: MonadPlus m => IntroUniT m +-- introVarUTm¤Ï°ìÏ¢¤ÎIgor´Ø·¸¤ÎÏÀʸ¤Ë¤Ï¤Ê¤¤¤â¤Î¤Î¡¤introBK¤¬Í­¸ú¤ËƯ¤¯¤Ë¤ÏɬÍס¥¤³¤ì¤¬¤Ê¤¤¤È¡¤f¤òºî¤ë¤Î¤ËBK¤È¤·¤Æf¤ò»È¤Ã¤Æ¤â¡¤introBK¤À¤±¤Ç½ª¤ï¤Ã¤Æ¤¯¤ì¤º¡¤À¸À®¤µ¤ì¤Ê¤¤¡¥ +{- introBK¤Î¤¢¤È¤ÎintroVarUTm¤òintroBK¤Ë´Þ¤á¤è¤¦¤È¤·¤Æ¡¤¤ä¤Ã¤Ñ»ß¤á¤¿¡¥ +introVarUTm (iops,_,_,True) = mzero +introVarUTm (iops,_,_,False) = msum $ map (\(ix,_) -> return (const (X ix), [])) $ filter (\(_,inp) -> inp == map output iops) $ zip [0..] $ transpose $ map inputs iops +-} +-- introVarUTm (iops,_,_,_) = msum $ map (\(ix,_) -> return (const (X ix), [])) $ filter (\(_,inp) -> inp == map output iops) $ zip [0..] $ transpose $ map inputs iops +introVarUTm b f = liftList $ introVar (zipWithM_ appUnifyUT) b f +-- introVarm b f = introVar (zipWithM_ unify) b f *************************************** ¤³¤ì¤Ï¥Ç¥Ð¥Ã¥°»þ¤ËÍ­ÍѤʤ³¤È¤â¡¥ +introVarm = introVar (\a b -> guard $ a==b) + +introVar :: MonadPlus m => ([Expr] -> [Expr] -> m ()) -> Introducer m +introVar cmp _ (fun Types.::: ty) + = do let (argtys, retty) = Types.splitArgs ty + iops = iopairs fun + arifun = arity fun + let trins = transpose $ map inputs iops +-- (ix,inps Types.::: argty) <- msum $ map return $ zip [0..] trins + (ix,argty,inps) <- msum [ return t | t@(_,aty,_) <- zip3 [0..] argtys $ visibles (toBeSought fun) trins, aty == retty ] + +-- The following four lines should be equivalent to + cmp (map output iops) inps +-- but use of Maybe and simpler substitutions should be good for efficiency. +{- + st0 <- get + case runStateT (zipWithM_ appUnifyUT (map output iops) inps) st0{subst=[]} of + Just ((),st) -> put (st{subst= subst st `plusSubst` subst st0}) + Nothing -> mzero +-} + return (const (X ix), [], Nothing) + +introConstr bk (fun Types.::: ty) + = let argtys = Types.getArgs ty + iops = iopairs fun + in + case [ output iop | iop <- iops ] of + outs@(C _ (cid Types.::: cty) flds : rest) + | all (`sConstrIs` cid) rest -> return (foldl (:$) (Primitive cid), + zipWith (\iops retty -> setIOPairs iops fun Types.::: Types.popArgs argtys retty) + (transpose [ divideIOP iop | iop <- iops ]) + (case Types.revSplitArgs cty of (_,fieldtys,_) -> fieldtys), + Nothing) + _ -> mzero +divideIOP (IOP bvs ins out) = map (IOP bvs ins) $ fields out -- The actual number of buondVars may reduce, but not updating the field would not hurt. + +shareConstr (C _ (cid Types.::: _) _ : iops) = all (`sConstrIs` cid) iops +shareConstr _ = False +-- type¤¬°ã¤¦¤ÈƱ¤¸cid¤ò°Û¤Ê¤ëconstructor¤Ç»È¤¤ÆÀ¤ë¾ì¹ç¡¤type¤´¤ÈÈæ³Ó¤¹¤ëɬÍפ¬¤¢¤ë¤¬¡¤¸½ºß¤Ï¤½¤¦¤Ç¤Ï¤Ê¤¤¤Î¤Ç¡¥ +C _ (c Types.::: _) _ `sConstrIs` cid = cid==c +_ `sConstrIs` cid = False + + +select [] [] = [] +select (b:bs) (p:ps) | b = (p, False:bs) : rest + | otherwise = rest + where rest = [ (result, b:newbs) | (result,newbs) <- select bs ps ] + +introCase bk (fun Types.::: ty) = msum $ reverse $ zipWith introCase' [0..] $ select (toBeSought fun) trins + where trins = transpose $ map inputs iops + (argtys,retty) = Types.splitArgs ty + iops = iopairs fun + arifun = arity fun + introCase' :: MonadPlus m => + Int -- ^ the pivot position + -> ([Expr],TBS) -- ^ (the pivot expression for each I/O pair, the next TBS) + -> m ([CoreExpr] -> CoreExpr, [Types.Typed Fun], Maybe Int) + introCase' pos (pivots, tbs) -- includes variable cases. Overlapping patterns are not supported yet. + = case mapM maybeCtor pivots of + Nothing -> mzero + Just ctors + -> let + pipairs = zip pivots iops :: [(Expr,IOPair)] + ts = IntMap.toList $ IntMap.fromListWith (\(t,xs) (_,ys) -> (t,xs++ys)) $ + zipWith (\(c Types.::: ct) x -> (c,(ct,[x]))) ctors pipairs + :: [(Constr, (Types.Type, [(Expr,IOPair)]))] + -- Array.accum can also be used instead of IntMap because we can tell the range from that of VarLib. + hd ces = Case (X pos) + (zipWith (\(constr, (_, (pivot,_):_)) ce -> (constr, length (fields pivot), ce)) + ts + ces) + iopss = [ Rec { maxNumBVs = maxNumBVs fun, + arity = arifun-1+lenflds, + iopairs = iops, + fmexpr = iopsToVisFME newtbs iops, + toBeSought = newtbs + } + Types.::: Types.popArgs (dropNth pos argtys) (Types.popArgs (Types.getArgs cty) retty) + | (_c, (cty, nextpipairs@((C _ _ flds', _):_))) <- ts, + let lenflds = length flds' + iops = [ IOP bvs (reverse flds ++ is) o | (C _ _c flds, IOP bvs is o) <- nextpipairs ] + newtbs = replicate lenflds True ++ tbs + ] + in return (hd, iopss, Just (arifun-pos-1)) + +dropNth pos bs = case splitAt pos bs of (tk,_:dr) -> tk ++ dr + + + +introBKm bk tfun = fromMx $ toMx $ introBK subtractIOPairsFromIOPairsBKm subtractIOPairsFromIOPairsm bk tfun +introBKUTm bk tfun = liftList $ introBK (const subtractIOPairsFromIOPairsBKUTm) (const subtractIOPairsFromIOPairsUTm) bk tfun +introBK subBK sub bk (fun Types.:::ty) = do + let (argtys, retty) = Types.splitArgs ty + (ix, bkfun Types.::: bkty) <- msum $ map return $ tail $ zip [0..] bk + -- The tail function here is used to avoid generating expressions like + -- fix (\fa x1 ... xn -> fa ...). + -- Such expressions would be excluded by the loop checker even without the tail function, + -- but we exclude them beforehand for efficiency reasons. + let (bkargtys, bkretty) = Types.splitArgs bkty + substy <- Types.match bkretty retty + iopss <- case bkfun of BKF{maxNumBVs=addendum} -> subBK (-addendum) (iopairs fun) bkfun + Rec{maxNumBVs=addendum} -> sub (-addendum) initTS (iopairs fun) bkfun + return (foldl (:$) (FunX ix), + [ setIOPairs iops fun Types.::: tys + | iops Types.::: tys <- reverse $ + zipWith (\x retty -> x Types.::: Types.popArgs argtys retty) + (transpose iopss) + (map (Types.apply substy) bkargtys) ], + Nothing) + + + +subtractIOPairsFromIOPairsBKUTm :: MonadPlus m => [IOPair] -> Fun -> UniT m [[IOPair]] +{- +subtractIOPairsFromIOPairsBK funs bks = foldr (liftM2 (:)) (return []) $ map (flip subtractIOPairs bks) funs +-} +subtractIOPairsFromIOPairsBKUTm [] bkf = return [] +subtractIOPairsFromIOPairsBKUTm (fun:funs) bkf = do + iops <- subtractIOPairsBKUTm fun bkf + iopss <- subtractIOPairsFromIOPairsBKUTm funs bkf -- iops¤Ï¡¤subfunction¤¬Ê£¿ô¤¢¤Ã¤Æ¡¤¤½¤ì¤ésubfunctions¤Î¤½¤ì¤¾¤ì¤Ë´Ø¤·¤ÆIOPair1¸Ä¤º¤Ä¤Ë²á¤®¤Ê¤¤¡¥ + return (iops:iopss) +-- Applying substitutions to funs is not currently necessary (because funs does not include existential variables), but that will be useful in future versions which fill gaps of input examples. + +{- +subtractIOPairs :: IOPair -> [IOPair] -> [[IOPair]] -- Æ⦥ꥹ¥È¤Î´ð¿ô¤Ïfun¤Îarity, ³°Â¦¤Ïbk¤ÎIO pair¤Î¤¦¤Ámatch¤¹¤ë¤Î¤Ï¤¤¤¯¤Ä¤¢¤ë¤« + -- ¤Æ¤æ¡¼¤«¡¤Æ⦤Ïbk¤Îarity¤Ç¤Ï¡© +subtractIOPairs fun bkpairs = [ iops | bk <- bkpairs, iops <- subtractIOPair fun bk ] +-} +subtractIOPairsBKUTm :: MonadPlus m => IOPair -> Fun -> UniT m [IOPair] -- Æ⦥ꥹ¥È¤Î´ð¿ô¤Ïfun¤Îarity, ³°Â¦¤Ïbk¤ÎIO pair¤Î¤¦¤Ámatch¤¹¤ë¤Î¤Ï¤¤¤¯¤Ä¤¢¤ë¤« + -- ¤Æ¤æ¡¼¤«¡¤Æ⦤Ïbk¤Îarity¤Ç¤Ï¡© +subtractIOPairsBKUTm tgt bkf = do + s <- gets subst + let aptgt = applyIOP s tgt + apbkf = applyIOPs s $ iopairs bkf + bkiop <- msum $ map return apbkf + subtractIOPairUTm aptgt bkiop +subtractIOPairsFromIOPairsUTm :: MonadPlus m => TermStat -> [IOPair] -> Fun -> UniT m [[IOPair]] +{- +subtractIOPairsFromIOPairs funs bks = foldr (\fun rest -> do iops <- subtractIOPairs fun bks + iopss <- rest + return (iops:iopss)) (return []) funs +-} +subtractIOPairsFromIOPairsUTm ts [] bkf = return [] +subtractIOPairsFromIOPairsUTm ts (fun:funs) bkf = do + (iops,newts) <- subtractIOPairsUTm ts fun bkf + iopss <- subtractIOPairsFromIOPairsUTm newts funs bkf -- iops¤Ï¡¤subfunction¤¬Ê£¿ô¤¢¤Ã¤Æ¡¤¤½¤ì¤ésubfunctions¤Î¤½¤ì¤¾¤ì¤Ë´Ø¤·¤ÆIOPair1¸Ä¤º¤Ä¤Ë²á¤®¤Ê¤¤¡¥ + return (iops:iopss) +subtractIOPairsUTm :: MonadPlus m => TermStat -> IOPair -> Fun -> UniT m ([IOPair], TermStat) -- Æ⦥ꥹ¥È¤Î´ð¿ô¤Ïfun¤Îarity, ³°Â¦¤Ïbk¤ÎIO pair¤Î¤¦¤Ámatch¤¹¤ë¤Î¤Ï¤¤¤¯¤Ä¤¢¤ë¤« + -- ¤Æ¤æ¡¼¤«¡¤Æ⦤Ïbk¤Îarity¤Ç¤Ï¡© +subtractIOPairsUTm ts tgt bkf = do + s <- gets subst + let aptgt = applyIOP s tgt + bktbs = toBeSought bkf + -- apbkf = applyIOPs s bkf + apvistgt = reverse $ visibles (reverse bktbs) $ reverse $ inputs aptgt + bkiop <- msum $ map return $ iopairs bkf + let visbki = visibles bktbs $ inputs bkiop + guard $ evalTS $ updateTS visbki apvistgt ts -- apply¤¹¤ë¤Þ¤¨¤Îbkf¤ÇÅ굡Ū¤Ëfilter¤·¤Æ¤ß¤¿¤±¤É¡¤¤¤¤Þ¤¤¤Á¡¥ + let apvisbki = map (apply s) visbki + iops <- subtractIOPairUTm aptgt bkiop{inputs=apvisbki, output=apply s $ output bkiop} + let newts = updateTS apvisbki apvistgt ts -- This makes sure that the generated program does not go into a loop. + guard $ evalTS newts +-- guard $ lessExprss (reverse bkis) (reverse apis) + return (iops, newts) + +-- Î㤨¤Ð¡¤join [x,y] [z,w] = [x,y,z,w]¤«¤ébk [a,b] [c,d] = [a,c,b,d]¤ò°ú¤¯¤³¤È¤ò¹Í¤¨¤ë¡¥ +-- join [x,y] [z,w] = bk (f [x,y] [z,w]) (g [x,y] [z,w])¤Ë¤ª¤¤¤Æf [x,y] [z,w] = [x,z], g [x,y] [z,w] = [y,w]¤Ê¤Î¤Ç¡¤ +-- subtractIOPair IOP{inputs=[[x,y],[z,w]],output=[x,y,z,w]} IOP{inputs=[[a,b],[c,d]],output=[a,c,b,d]} = [IOP{inputs=[[x,y],[z,w]],output=[x,z]}, IOP{inputs=[[x,y],[z,w]],output=[y,w]}] +-- ¤È¤¤¤¦¤³¤È¤Ë¤Ê¤ë¡¥ +subtractIOPairUTm :: MonadPlus m => IOPair -> IOPair -> UniT m [IOPair] +subtractIOPairUTm fun bkiop + = do frbkiop <- freshIOP bkiop + unifyUT (output frbkiop) (output fun) + s <- gets subst + return [ fun{output=apply s o} | o <- inputs frbkiop ] -- This @apply@ is necessary here because introBKm will soon forget the substitution. + +subtractIOPairsFromIOPairsm :: Int -- maxNumBVs¤Ç¥²¥Ã¥È¤Ç¤­¤ëÃÍ¡¥ + -> TermStat -> [IOPair] -> Fun -> [] [[IOPair]] +subtractIOPairsFromIOPairsm addendum ts tgt bkf = subtractIOPairsFromIOPairsmFME addendum ts tgt bkf addendum +subtractIOPairsFromIOPairsmFME :: Int -> TermStat -> [IOPair] -> Fun -> Int -> [] [[IOPair]] +{- +subtractIOPairsFromIOPairsBK funs bks = foldr (liftM2 (:)) (return []) $ map (flip subtractIOPairs bks) funs +-} +subtractIOPairsFromIOPairsmFME addendum ts [] bkf offset = return [] +subtractIOPairsFromIOPairsmFME addendum ts (fun:funs) bkf offset = do + (iops,newts) <- subtractIOPairsmFME ts fun bkf offset + iopss <- subtractIOPairsFromIOPairsmFME addendum newts funs bkf (offset+addendum) -- iops¤Ï¡¤subfunction¤¬Ê£¿ô¤¢¤Ã¤Æ¡¤¤½¤ì¤ésubfunctions¤Î¤½¤ì¤¾¤ì¤Ë´Ø¤·¤ÆIOPair1¸Ä¤º¤Ä¤Ë²á¤®¤Ê¤¤¡¥ + return (iops:iopss) +-- Applying substitutions to funs is not currently necessary (because funs does not include existential variables), but that will be useful in future versions which fill gaps of input examples. + +subtractIOPairsmFME :: TermStat -> IOPair -> Fun -> Int -> [([IOPair], TermStat)] -- ÊÖ¤êÃͤÎ[IOPair]¤Ï³Æ°ú¿ô¤ËÂбþ +subtractIOPairsmFME ts tgtiop bkf offset = do + let vistgt = reverse $ visibles (reverse $ toBeSought bkf) $ reverse $ inputs tgtiop + visbkis <- unifyingIOPairs (output tgtiop) (fmexpr bkf) offset + let iops = [ tgtiop{output=o} | o <- visbkis ] + let newts = updateTS visbkis vistgt ts -- This makes sure that the generated program does not go into a loop. + guard $ evalTS newts +-- guard $ lessExprss (reverse bkis) (reverse apis) + return (iops, newts) + + +subtractIOPairsFromIOPairsBKm :: Int -- maxNumBVs¤Ç¥²¥Ã¥È¤Ç¤­¤ëÃÍ¡¥ + -> [IOPair] -> Fun -> [] [[IOPair]] +subtractIOPairsFromIOPairsBKm addendum tgt bkf = subtractIOPairsFromIOPairsBKmFME addendum tgt (iopsToFME $ iopairs bkf) addendum +subtractIOPairsFromIOPairsBKmFME :: Int -> [IOPair] -> FMExpr [IOPair] -> Int -> [] [[IOPair]] +{- +subtractIOPairsFromIOPairsBK funs bks = foldr (liftM2 (:)) (return []) $ map (flip subtractIOPairs bks) funs +-} +subtractIOPairsFromIOPairsBKmFME addendum [] bkf offset = return [] +subtractIOPairsFromIOPairsBKmFME addendum (fun:funs) bkf offset = do + iops <- subtractIOPairsBKmFME fun bkf offset + iopss <- subtractIOPairsFromIOPairsBKmFME addendum funs bkf (offset+addendum) -- iops¤Ï¡¤subfunction¤¬Ê£¿ô¤¢¤Ã¤Æ¡¤¤½¤ì¤ésubfunctions¤Î¤½¤ì¤¾¤ì¤Ë´Ø¤·¤ÆIOPair1¸Ä¤º¤Ä¤Ë²á¤®¤Ê¤¤¡¥ + return (iops:iopss) +-- Applying substitutions to funs is not currently necessary (because funs does not include existential variables), but that will be useful in future versions which fill gaps of input examples. + + + +subtractIOPairsBKmFME :: IOPair -> FMExpr [IOPair] -> Int -> [] [IOPair] -- ÊÖ¤êÃͤÎ[IOPair]¤Ï³Æ°ú¿ô¤ËÂбþ +subtractIOPairsBKmFME tgtiop bkfme offset = do + visbkis <- unifyingIOPairs (output tgtiop) bkfme offset + return [ tgtiop{output=o} | o <- visbkis ] + + +unifyingIOPairs :: Expr -> FMExpr [IOPair] -> Int -> [] [Expr] +unifyingIOPairs e fme 0 = [ inputs iop | (iops, _) <- unifyFME e fme, iop <- iops ] +unifyingIOPairs e fme offset = [ map (mapE (offset+) . apfresh s) $ inputs iop | (iops, s) <- unifyFME e fme, iop <- iops ] diff --git a/MagicHaskeller/Analytical/UniT.hs b/MagicHaskeller/Analytical/UniT.hs new file mode 100644 --- /dev/null +++ b/MagicHaskeller/Analytical/UniT.hs @@ -0,0 +1,40 @@ +-- +-- (C) Susumu Katayama +-- +module MagicHaskeller.Analytical.UniT where + +import Control.Monad -- hiding (guard) +import Control.Monad.State -- hiding (guard) + +import MagicHaskeller.Analytical.Syntax + +type UniT = StateT St +data St = St {subst::Subst, nextVar :: Int} deriving Show + +emptySt = St {subst=[], nextVar=0} + +freshVar :: Monad m => UniT m Expr +freshVar = do st <- get + let nv = nextVar st + put st{nextVar = succ nv} + return $ E nv +freshIOP (IOP n ins out) = do st <- get + let nv = nextVar st + put st{nextVar = nv + n} + return $ IOP 0 (map (fresh (nv+)) ins) (fresh (nv+) out) + +applyUT :: Monad m => Expr -> UniT m Expr +applyUT ex = do s <- gets subst + return $ apply s ex +applyIOPUT iop = do s <- gets subst + return $ applyIOP s iop + +unifyUT :: MonadPlus m => Expr -> Expr -> UniT m () +unifyUT e1 e2 = case unify e1 e2 of Just s -> modify (\st -> st{subst = s `plusSubst` subst st}) + Nothing -> mzero +{- Obviously this is slower, but I do not remember why I used this. +unifyUT e1 e2 = do s <- unify e1 e2 + modify (\st -> st{subst = s `plusSubst` subst st}) +-} +appUnifyUT e1 e2 = do s <- gets subst + unifyUT (apply s e1) (apply s e2) diff --git a/MagicHaskeller/Classification.hs b/MagicHaskeller/Classification.hs --- a/MagicHaskeller/Classification.hs +++ b/MagicHaskeller/Classification.hs @@ -1,4 +1,7 @@ -{-# OPTIONS_GHC -fglasgow-exts -cpp #-} +-- +-- (c) Susumu Katayama +-- +{-# OPTIONS_GHC -cpp -XFlexibleInstances #-} {-# LANGUAGE UndecidableInstances, OverlappingInstances, TemplateHaskell #-} -- x #define TESTEQ @@ -18,6 +21,7 @@ import Data.Complex import MagicHaskeller.MHTH +import MagicHaskeller.TimeOut import MagicHaskeller.T10 import MagicHaskeller.Classify(diffSortedBy, diffSortedByBot) diff --git a/MagicHaskeller/Classify.hs b/MagicHaskeller/Classify.hs --- a/MagicHaskeller/Classify.hs +++ b/MagicHaskeller/Classify.hs @@ -1,9 +1,9 @@ -- --- (c) Susumu Katayama 2009 +-- (c) Susumu Katayama -- {-# OPTIONS -XMagicHash -cpp #-} module MagicHaskeller.Classify(randomTestFilter, filterBF, filterRc, filterDB -- , filterDBPos - , ofilterDB, opreexecute, CmpBot -- used by ClassifyDM.hs + , ofilterDB, opreexecute, CmpBot, cmpBot -- used by ClassifyDM.hs , diffSortedBy, diffSortedByBot, FiltrableBF ) where @@ -24,10 +24,9 @@ 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) +import MagicHaskeller.T10(mergesortWithBy, mergeWithBy, mergesortWithByBot, mergeWithByBot) #ifdef DEBUG import Test.QuickCheck @@ -36,6 +35,7 @@ import MagicHaskeller.Expression import MagicHaskeller.ProgramGenerator +import MagicHaskeller.Options import Language.Haskell.TH.Ppr -- import ReadLambdaExpr(exprToTHExp) @@ -48,13 +48,13 @@ -- 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 +randomTestFilter md = filterBF (extractTCL md) (extractRTrie md) (opt $ extractCommon md) +filterBF :: FiltrableBF m => TyConLib -> RTrie -> Opt () -> 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 ([], op) -> fmap snd . ofilter (op,pto) . 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) @@ -65,11 +65,11 @@ 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). +type CmpBot k = (k->k->Ordering, Opt ()) -- 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) + ofilter :: CmpBot k -> m (k,e) -> m (k,e) instance FiltrableBF Matrix where sfilter = sfilterMx ofilter = ofilterMx @@ -90,7 +90,7 @@ sfilterMx op mx = trace "sfilterMx" $ unscanlByList op $ repEqClsBy op mx -filterDB :: TyConLib -> RTrie -> Maybe Int -> Type -> DBound AnnExpr -> DBound AnnExpr +filterDB :: TyConLib -> RTrie -> Opt () -> Type -> DBound AnnExpr -> DBound AnnExpr filterDB = filterBF {- filterDBPos :: TyConLib -> RTrie -> Type -> DBound (Possibility AnnExpr) -> DBound (Possibility AnnExpr) @@ -100,7 +100,7 @@ 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 :: TyConLib -> RTrie -> Opt () -> Type -> Recomp AnnExpr -> Recomp AnnExpr filterRc = filterBF -- x ¤³¤Î[([k],e)]¤ÎÉôʬ¤Ï¡¤ËÜÅö¤Î¤È¤³¤íStreamTrie¤Ç¼ÂÁõ¤·¤¿Êý¤¬¸úΨŪ¤Ê¤Ï¤º¡¥ @@ -150,8 +150,7 @@ 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 +liftCmpBot len (cmp,pto) xs ys = unsafeWithPTOOpt pto $ liftCmp len cmp xs ys {- | otherwise = liftCmpBot' len cmp xs ys liftCmpBot' 0 _ _ _ = Just EQ @@ -164,8 +163,10 @@ c -> trace "otherwise" c -} +cmpBot (cmp,pto) x y = unsafeWithPTOOpt pto $ cmp x y #else liftCmpBot len (cmp,_pto) xs ys = Just $ liftCmp len cmp xs ys +cmpBot (cmp,_pto) x y = Just $ cmp x y #endif -- dlb = deleteListBy @@ -275,20 +276,20 @@ sfilterDB :: CmpBot k -> DBound ([k],e) -> DBound ([k],e) sfilterDB cmp (DB f) = DB $ \n -> mergesortWithByBot (\x@(_,i) y@(_,j) -> if i 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) +ofilterDB :: CmpBot k -> DBound (k,e) -> DBound (k,e) +ofilterDB cmp (DB f) = DB $ \n -> mergesortWithByBot const (\((k,_),_) ((l,_),_) -> cmpBot 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 +ofilterRc :: CmpBot k -> Recomp (k,e) -> Recomp (k,e) +ofilterRc cmp rc = let sorted = mapDepth (mergesortWithByBot const op) rc + cumulative = scanlRc (mergeWithByBot const op) [] sorted + in zipDepth3Rc (\_ -> diffSortedByBot op) sorted cumulative + where op (k,_) (l,_) = cmpBot 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 +ofilterMx :: CmpBot k -> Matrix (k,e) -> Matrix (k,e) +ofilterMx cmp (Mx xss) = let sorted = map (mergesortWithByBot const op) xss + cumulative = scanl (mergeWithByBot const op) [] sorted + in Mx $ zipWith (diffSortedByBot op) sorted cumulative + where op (k,_) (l,_) = cmpBot 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 diff --git a/MagicHaskeller/ClassifyDM.hs b/MagicHaskeller/ClassifyDM.hs --- a/MagicHaskeller/ClassifyDM.hs +++ b/MagicHaskeller/ClassifyDM.hs @@ -1,5 +1,5 @@ -- --- (c) Susumu Katayama 2009 +-- (c) Susumu Katayama -- module MagicHaskeller.ClassifyDM(filterDM, filterList, filterListDB, filterDMlite, spreexecuteDM) where -- , filterDMTI) where @@ -14,16 +14,16 @@ #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.Classify(opreexecute, ofilterDB, CmpBot, cmpBot) -- ofilterDB ¤Ï¤³¤Ã¤Á¤ÇÄêµÁ¤µ¤ì¤Æ¤¤¤Æ¤â¤¤¤¤¤è¤¦¤Ê¤â¤Î¡¥ import MagicHaskeller.Expression -import MagicHaskeller.ProgramGenerator(Opt(..), Common(..)) +import MagicHaskeller.ProgramGenerator(Common(..)) +import MagicHaskeller.Options(Opt(..)) select :: DBound ([[Dynamic]], AnnExpr) -> DBound ([Dynamic], AnnExpr) -- select (DB f) = DB $ \n -> map (\((xss,ae),i) -> (((xss!!n), ae),i)) $ f n @@ -45,11 +45,11 @@ = 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) + mergesortWithByBot const (\(AE _ k) (AE _ l) -> cmpBot (op, opt cmn) 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)) . + (nthCompareBot (nrands $ opt cmn) db (op, opt cmn)) . map (\ae -> sprDM (uncurryDyn (mkUncurry $ tcl cmn) typ) rndss ae db) filterListDB :: Common -> Type -> [AnnExpr] -> DBound [AnnExpr] filterListDB cmn typ aes @@ -60,11 +60,11 @@ = 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) + mapDepthDB $ mergesortWithByBot const (\((AE _ k),_) ((AE _ l),_) -> cmpBot (op, opt cmn) 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 nthCompareBot (nrands $ opt cmn) d (op, timeout $ opt cmn) k l) . + (\(k,_) (l,_) -> nthCompareBot (nrands $ opt cmn) d (op, 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¤¬¤Ç¤­¤º¡¤·ë²Ì¤Ï¤¤¤Þ¤¤¤Á¡¥ @@ -74,10 +74,10 @@ = 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) + mapDepthDB $ mergesortWithByBot const (\((AE _ k),_) ((AE _ l),_) -> cmpBot (op, opt cmn) 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 . + shrink const (\k l -> nthCompareBot (nrands $ opt cmn) d (op, 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 @@ -89,7 +89,7 @@ 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 +listCmpBot len (cmp,pto) xs ys = unsafeWithPTOOpt pto $ listCmp len cmp xs ys #else listCmpBot len cmp xs ys = Just $ listCmp len cmp xs ys #endif diff --git a/MagicHaskeller/ClassifyTr.hs b/MagicHaskeller/ClassifyTr.hs --- a/MagicHaskeller/ClassifyTr.hs +++ b/MagicHaskeller/ClassifyTr.hs @@ -1,20 +1,22 @@ -- --- (c) Susumu Katayama 2009 +-- (c) Susumu Katayama -- module MagicHaskeller.ClassifyTr where import MagicHaskeller.T10 import Control.Monad.Search.Combinatorial import Control.Monad -import MagicHaskeller.MHTH(unsafeWithPTO) +import MagicHaskeller.TimeOut + -- Just for filterTr import MagicHaskeller.MyDynamic import MagicHaskeller.Instantiate import MagicHaskeller.Expression -import MagicHaskeller.ProgramGenerator(Opt(..), Common(..)) +import MagicHaskeller.ProgramGenerator(Common(..)) +import MagicHaskeller.Options(Opt(..)) import MagicHaskeller.Types import MagicHaskeller.ClassifyDM(spreexecuteDM) - +import MagicHaskeller.Classify(cmpBot) import Debug.Trace @@ -22,11 +24,11 @@ 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 ([], op) -> \x -> (undefined, undefined, mapDepth (mergesortWithByBot const (\(AE _ k) (AE _ l) -> cmpBot (op, opt cmn) 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) + unsafeCmp ks ls = unsafeWithPTOOpt (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 diff --git a/MagicHaskeller/Combinators.hs b/MagicHaskeller/Combinators.hs --- a/MagicHaskeller/Combinators.hs +++ b/MagicHaskeller/Combinators.hs @@ -1,5 +1,5 @@ -- --- (c) Susumu Katayama 2009 +-- (c) Susumu Katayama -- module MagicHaskeller.Combinators where import MagicHaskeller.ExprStaged diff --git a/MagicHaskeller/CoreLang.lhs b/MagicHaskeller/CoreLang.lhs --- a/MagicHaskeller/CoreLang.lhs +++ b/MagicHaskeller/CoreLang.lhs @@ -1,12 +1,12 @@ -- --- (c) Susumu Katayama 2009 +-- (c) Susumu Katayama -- 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 #-} +{-# OPTIONS -cpp -XExistentialQuantification -XRankNTypes #-} -- workaround Haddock invoked from Cabal unnecessarily chasing imports. (If cpp fails, haddock ignores the remaining part of the module.) #ifndef __GLASGOW_HASKELL__ -- x #hoge @@ -19,10 +19,12 @@ import Debug.Trace -import MagicHaskeller.MyDynamic +import qualified MagicHaskeller.PolyDynamic as PD +-- import MagicHaskeller.MyDynamic import Data.Char(chr,ord) - +import MagicHaskeller.TyConLib +import MagicHaskeller.ReadTHType(thTypeToType) #ifdef FORCE import Control.Parallel.Strategies #endif @@ -31,14 +33,24 @@ import Data.Bits import Data.HashTable(hashInt, prime) +import Data.Function(fix) + infixl :$ -data CoreExpr = S | K | I | B | C | S' | B' | C' +data CoreExpr = S | K | I | B | C | S' | B' | C' | Y | Lambda CoreExpr | X Int -- de Bruijn notation + | FunLambda CoreExpr | FunX Int -- different system of de Bruijn notation for functions, used by IOPairs.hs | Tuple Int | Primitive Int | CoreExpr :$ CoreExpr + | Case CoreExpr [(Int,Int,CoreExpr)] -- the case expression. [(primitive ID of the constructor, arity of the constructor, rhs of ->)] + | Fix CoreExpr Int [Int] -- Fix expr n is === foldl (:$) (Y :$ FunLambda (napply n Lambda expr)) (map X is) +{- + | FixCase [(Int,Int,CoreExpr)] -- FixCase ts === (Y :$ Lambda (Lambda (Case (X 0) ts))) + -- See notes on July 3, 2010 +-} + | VarName String -- This is only used for pretty printing IOPairs.Expr. Use de Bruijn variables for other purposes. 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 @@ -70,13 +82,6 @@ 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 @@ -94,31 +99,227 @@ readsPrec _ str = [(error "ReadS Exp is not implemented yet", str)] -type VarLib = Array Int (Exp,Dynamic) +type VarLib = Array Int PD.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, .... +exprToTHExp, exprToTHExpLite :: VarLib -> CoreExpr -> Exp +exprToTHExp vl e = exprToTHExp' True vl $ lightBeta e +exprToTHExpLite vl e = exprToTHExp' False vl $ lightBeta e +exprToTHExp' pretty vl e = x2hsx (ord 'a'-1) (ord 'a' -1) e + where x2hsx dep fdep (Lambda e) = + case x2hsx (dep+1) fdep e of LamE pvars expr -> LamE (pvar:pvars) expr + expr -> LamE [pvar] expr + where var = mkName [chr (dep+1)] + pvar | not pretty || 0 `occursIn` e = VarP var + | otherwise = WildP + x2hsx dep fdep (FunLambda e) = + case x2hsx dep (fdep+1) e of LamE pvars expr -> LamE (pvar:pvars) expr + expr -> LamE [pvar] expr + where var = mkName ['f',chr (fdep+1)] + pvar | not pretty || 0 `funOccursIn` e = VarP var + | otherwise = WildP + x2hsx dep fdep (X n) = VarE (mkName [chr (dep - n)]) -- X n¤ÏX 0, X 1, .... + x2hsx dep fdep (FunX n) = VarE (mkName ['f',chr (fdep - n)]) -- X n¤ÏX 0, X 1, .... -- x2hsx _ (Qualified con) = VarE (mkName (pl ! con)) - x2hsx _ (Primitive n) = 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 + x2hsx _ _ (Primitive n) = case PD.dynExp (vl ! n) of ConE name -> ConE $ mkName $ nameBase name + VarE name -> VarE $ mkName $ nameBase name + e -> e + x2hsx dep fdep (Primitive n :$ e0 :$ e1) + = let hsx0 = x2hsx dep fdep e0 + hsx1 = x2hsx dep fdep e1 + in case PD.dynExp (vl!n) of + e@(VarE name) | head (nameBase name) `elem` "!@#$%&*+./<=>?\\^|-~" + -> InfixE (Just hsx0) (VarE $ mkName $ nameBase name) (Just hsx1) + | otherwise -> (VarE (mkName $ nameBase name) `AppE` hsx0) `AppE` hsx1 + e@(ConE name) | namestr == ":" -> case hsx1 of ListE hsxs -> ListE (hsx0 : hsxs) + ConE n | nameBase n == "[]" -> ListE [hsx0] + _ -> InfixE (Just hsx0) (ConE $ mkName ":") (Just hsx1) + | head namestr == ':' -> InfixE (Just hsx0) (ConE $ mkName namestr) (Just hsx1) + | otherwise -> (ConE (mkName namestr) `AppE` hsx0) `AppE` hsx1 + where 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) + e -> (e `AppE` hsx0) `AppE` hsx1 + x2hsx dep fdep (Y :$ FunLambda e) = case x2hsx dep fdep (FunLambda e) of LamE [WildP] expr -> expr + LamE (WildP:pvs) expr -> LamE pvs expr + expr -> VarE 'fix `AppE` expr + -- This is still necessary because systematic synthesizer still uses Lambda and X even for functions. + x2hsx dep fdep (Y :$ Lambda e) = case x2hsx dep fdep (Lambda e) of LamE [WildP] expr -> expr + LamE (WildP:pvs) expr -> LamE pvs expr + expr -> VarE 'fix `AppE` expr + x2hsx dep fdep (e0 :$ e1) = x2hsx dep fdep e0 `AppE` x2hsx dep fdep e1 + x2hsx dep fdep (Case ce ts) = CaseE (x2hsx dep fdep ce) (map (tsToMatch dep fdep) ts) +-- x2hsx dep fdep (Fix ce n is) = x2hsx dep fdep $ foldl (:$) (Y :$ FunLambda (napply n Lambda ce)) (map X is) -- let¤ò»È¤Ã¤Æ½ñ¤¤¤¿Êý¤¬¤¤¤¤´¶¤¸¤Ë¤Ê¤ë¡¥ + x2hsx dep fdep (Fix ce n is) + = case x2hsx dep fdep (FunLambda (napply n Lambda ce)) of + LamE (WildP:ps) e -> foldl AppE (LamE ps e) $ map (x2hsx dep fdep . X) is + + +-- let ¤Î¤¢¤È case¤¬¤¢¤ë¾ì¹ç¤Ë¤µ¤é¤Ërefactor¤·¤Æ¤¿¤Î¤À¤¬¡¤ +-- \a -> let fa (b@0) = 0 +-- fa (b@succc) | succc > 0 = GHC.Enum.succ (GHC.Enum.succ (GHC.Enum.succ (fa c))) +-- where c = succc - 1 +-- in fa a +-- ¤ß¤¿¤¤¤Ê¤Î¤¬¤Ç¤­¤Æ¤á¤ó¤É¤¯¤µ¤¤¡¥ + +-- ¤Æ¤æ¡¼¤«¡¤pretty print¤·¤¹¤®¤ë¤È¡¤ExecuteAPI¤¹¤ë¤È¤­µÕ¤ËÃÙ¤½¤¦¡¥ + LamE (VarP name : ps) (CaseE (VarE n) ms) + | VarP n `elem` ps -> LetE [FunD name (map (\(Match p b decls) -> Clause (map (replacePat n p) ps) b decls) ms)] + (foldl AppE (VarE name) $ map (x2hsx dep fdep . X) is) + LamE (VarP name : ps) e -> LetE [FunD name [Clause ps (NormalB e) []]] + (foldl AppE (VarE name) $ map (x2hsx dep fdep . X) is) +-- x2hsx dep (FixCase ts) = x2hsx dep (Y :$ Lambda (Lambda (Case (X 0) ts))) + x2hsx dep _ (VarName str) = VarE (mkName str) + x2hsx _ _ Y = VarE 'fix + x2hsx _ _ e = error ("exprToTHExp: converting" ++ show e) + replacePat name new (VarP o) | o==name = AsP name new + replacePat _ _ old = old + tsToMatch dep fdep (ctor, arity, expr) + = case PD.dynExp (vl ! ctor) of + ConE name -> case x2hsx dep fdep (napply arity Lambda expr) of + LamE pvars ex -> case compare (length pvars) arity of + LT -> error "too few lambda abstractions in Case...can't happen!" + EQ -> Match (mkPat nameb pvars) (NormalB ex) [] + GT -> Match (mkPat nameb tk) (NormalB $ LamE dr ex) [] + where (tk,dr) = splitAt arity pvars + ex -- -- | not pretty && nameb == "[]" -> Match (ConP '[] []) (NormalB ex) [] + | otherwise -> Match (ConP (mkName nameb) []) (NormalB ex) [] + where nameb = nameBase name + mkPat ":" [pv1,pv2] = InfixP pv1 (mkName ":") pv2 + mkPat (':':_) [pv1,pv2] = InfixP pv1 (mkName nameb) pv2 + mkPat nmb pvs = ConP (mkName nameb) pvs + VarE name | nameBase name == "succ" -> + case x2hsx (dep+1) fdep expr of -- ¤³¤³¤Îcase¤ÏºÇ½éx2hsx dep $ Lambda expr¤Ë¤·¤Æ¤¤¤¿¤Î¤À¤¬¡¤WildP¤Ë¤Ê¤Ã¤Æ¤·¤Þ¤¦¤Èguard¤Ç¤­¤Ê¤¯¤Ê¤ë¤·¡¤¤«¤È¤¤¤Ã¤ÆCase¤ÎÆ⦤ÇWildP¤Ø¤ÎÃÖ´¹¤ò¤ä¤é¤Ê¤¤¤È¤¹¤ë¤È¤ß¤Ë¤¯¤¤¤·¡¤¤³¤Î¥Ñ¥¿¡¼¥ó¤À¤±WildP¤ò»ß¤á¤ë¤¯¤é¤¤¤Ê¤éLambda¤Îʬ¤òŸ³«¤·¤¿Êý¤¬Áᤤ¤ä¡¤¤Ã¤Æ¤³¤È¤Ç¡¥ + ex -> Match (VarP succn) (GuardedB [(NormalG (InfixE (Just $ VarE succn) (VarE $ mkName ">") (Just $ LitE $ IntegerL 0)),ex)]) [ValD (VarP name) (NormalB (InfixE (Just $ VarE succn) (VarE $ mkName "-") (Just $ LitE (IntegerL 1)))) []] + where str = [chr (dep+1)] + name = mkName str + succn = mkName ("succ"++str) + | nameBase name == "negate" -> + case x2hsx (dep+1) fdep expr of + ex -> Match (VarP negn) (GuardedB [(NormalG (InfixE (Just $ VarE negn) (VarE $ mkName "<") (Just $ LitE $ IntegerL 0)),ex)]) [ValD (VarP name) (NormalB ((VarE 'negate) `AppE` (VarE negn))) []] + where str = [chr (dep+1)] + name = mkName str + negn = mkName ("neg"++str) + LitE lit -> Match (LitP lit) (NormalB $ x2hsx dep fdep expr) [] + e -> error (pprint e ++ " : non-constructor where a constructor is expected.") + n `occursIn` Lambda e = succ n `occursIn` e + n `occursIn` FunLambda e = n `occursIn` e + -- n `occursIn` FixCase ts = any (\(_,a,ce) -> (n+a+2) `occursIn` ce) ts + n `occursIn` X m = n==m + n `occursIn` (f :$ e) = (n `occursIn` f) || (n `occursIn` e) + n `occursIn` Case x ts = n `occursIn` x || any (\(_,a,ce) -> (n+a) `occursIn` ce) ts + n `occursIn` Fix e m is = n `elem` is || (n+m) `occursIn` e + _ `occursIn` _ = False +n `funOccursIn` Lambda e = n `funOccursIn` e +n `funOccursIn` FunLambda e = succ n `funOccursIn` e +n `funOccursIn` FunX m = n==m +n `funOccursIn` (f :$ e) = (n `funOccursIn` f) || (n `funOccursIn` e) +n `funOccursIn` Case x ts = n `funOccursIn` x || any (\(_,a,ce) -> n `funOccursIn` ce) ts +n `funOccursIn` Fix e _ _ = succ n `funOccursIn` e +_ `funOccursIn` _ = False + + +lightBeta :: CoreExpr -> CoreExpr +lightBeta (Fix e m is) | 0 `funOccursIn` e = Fix (lightBeta e) m is + | otherwise = liftFun 0 $ nlift 0 m $ foldr ($) (lightBeta e) $ zipWith replace [m-1,m-2..0] $ map (m+) is +lightBeta (Lambda e) = Lambda $ lightBeta e +lightBeta (FunLambda e) = FunLambda $ lightBeta e +lightBeta (Lambda e :$ X n) = lightBeta $ nlift 0 1 $ replace 0 n e + +lightBeta (f :$ e) = lightBeta f :$ lightBeta e +lightBeta (Case x ts) = Case (lightBeta x) (map (\(c,a,ce) -> (c,a,lightBeta ce)) ts) +lightBeta e = e + +replace o n e@(X i) | i==o = X n +replace o n (Lambda e) = Lambda (replace (succ o) (succ n) e) +replace o n (FunLambda e) = FunLambda $ replace o n e +replace o n (f :$ e) = replace o n f :$ replace o n e +replace o n (Case x ts) = Case (replace o n x) (map (\(c,a,ce) -> (c,a,replace (o+a) (n+a) ce)) ts) +replace o n (Fix e m is) = Fix (replace (o+m) (n+m) e) m (map (\x -> if x==o then n else x) is) +replace o n e = e + +liftFun th (FunX i) | th (c,a,liftFun th ce)) ts) +liftFun th (Fix e m is) = Fix (liftFun (succ th) e) m is +liftFun _ e = e +nlift th n (X i) | th (c,a,nlift (th+a) n ce)) ts) +nlift th n (Fix e m is) = Fix (nlift (th+m) n e) m (map (nliftInt th n) is) +nlift th n e = e +nliftInt th n i | th < i = i-n + | otherwise = i + + +napply n f x = iterate f x !! n + + + +isObviouslyBoring :: Exp -> Bool +isObviouslyBoring = iOB [] +iOB patss (LamE pats expr) = iOB (reverse pats:patss) expr +iOB _ (VarE _) = False +iOB _ (ConE _) = False +iOB patss (InfixE (Just e1) o (Just e2)) = iOB patss e1 || iOB patss e2 +iOB patss (ListE es) = any (iOB patss) es +iOB patss (CaseE e ts) = iOB patss e || any iOBMatch ts + where iOBMatch (Match _ (NormalB ce) _) = iOB patss ce + iOBMatch (Match _ (GuardedB ts) _) = any (iOB patss . snd) ts +iOB patss ce@(AppE f e) = any (matchExp ce) patss || iOB patss f || iOB patss e +matchExp (AppE f e) (WildP:pats) = matchExp f pats +matchExp (AppE f (VarE n1)) (VarP n2:pats) = nameBase n1 == nameBase n2 && matchExp f pats +matchExp (VarE n1) [VarP n2] = nameBase n1 == nameBase n2 +matchExp _ _ = False + +-- Another 'Primitive' moved from MagicHaskeller.lhs, which should be renamed in some way.... +type Primitive = (HValue, Exp, Type) +newtype HValue = HV (forall a. a) + +primitivesToTCL :: [Primitive] -> TyConLib +primitivesToTCL ps = let (_,_,ts) = unzip3 ps in thTypesToTCL ts +-- thTypesToTCL encloses defaultTyCons + +primitivesToVL :: TyConLib -> [Primitive] -> VarLib +primitivesToVL tcl ps + = listArray (0, length ps + 7) (map (\ (HV x, e, ty) -> PD.unsafeToDyn tcl (thTypeToType tcl ty) x e) ps + ++ defaultPrimitives) + +-- | 'defaultVarLib' can be used as a VarLib for testing and debugging. +defaultVarLib :: VarLib +defaultVarLib = listArray (0, length defaultPrimitives - 1) defaultPrimitives + + +-- ¤Ç¤â¡¤¥Ç¥Ð¥Ã¥°ÌÜŪ¤Ç¡¤Int¤À¤±¤¸¤ã¤Ê¤¯¤Æ¥ê¥¹¥È¤È¤«¤âdefaultVarLib¤Ë´Þ¤á¤¿¤¤¡¥ + + + + + + + +-- | @defaultPrimitives@ is the set of primitives that we want to make sure to appear in VarLib but may not appear in the primitive set with which to synthesize. +-- In other words, it is the set of primitives we want to make sure to assign IDs to. +defaultPrimitives :: [PD.Dynamic] +defaultPrimitives + = [ + $(PD.dynamic [|defaultTCL|] [|(+)::Int->Int->Int|]), + $(PD.dynamic [|defaultTCL|] [|False::Bool|]), + $(PD.dynamic [|defaultTCL|] [|True::Bool|]), + $(PD.dynamic [|defaultTCL|] [|[]::[a]|]), + $(PD.dynamic [|defaultTCL|] [|(:)::a->[a]->[a]|]), + $(PD.dynamic [|defaultTCL|] [|0::Int|]), -- What if, e.g., Integer instead of Int is used? + $(PD.dynamic [|defaultTCL|] [|succ::Int->Int|]), + $(PD.dynamic [|defaultTCL|] [|negate::Int->Int|])] + +-- succ, viewed as a constructor, can be converted into n+k pattern while postprocessing, but what can I do for negate? +-- Maybe I could say @ case x of _ | x<0 -> ... where i = -x @, so I can avoid introducing a new variable. +-- ... but then, what if x is not actually a variable? +-- ... Uh, n+k pattern can not yet be handled by TH. (Try @runQ [| case 3 of k+1 -> k |] >>= print@ in GHCi.) +-- The above are dealt with by CoreLang.exprToTHExp. \end{code} diff --git a/MagicHaskeller/DebMT.lhs b/MagicHaskeller/DebMT.lhs --- a/MagicHaskeller/DebMT.lhs +++ b/MagicHaskeller/DebMT.lhs @@ -1,7 +1,6 @@ -- --- (c) Susumu Katayama 2009 +-- (c) Susumu Katayama -- - \begin{code} {-# OPTIONS -cpp #-} module MagicHaskeller.DebMT where @@ -27,32 +26,7 @@ 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 @@ -62,6 +36,8 @@ lookupMT mt (t0:->t1) = lookupMT (lookupMT (funMT mt) t0) t1 +encode :: Type -> Int -> (Type, Decoder) + 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 ] @@ -71,7 +47,6 @@ decodeVar (Dec tvs margin) tv = case tvs !? tv of Nothing -> tv+margin Just ntv -> ntv -encode :: Type -> Int -> (Type, Decoder) encode = Types.normalizeVarIDs diff --git a/MagicHaskeller/Execute.hs b/MagicHaskeller/Execute.hs --- a/MagicHaskeller/Execute.hs +++ b/MagicHaskeller/Execute.hs @@ -1,5 +1,5 @@ -- --- (c) Susumu Katayama 2009 +-- (c) Susumu Katayama -- {-# OPTIONS -XMagicHash #-} module MagicHaskeller.Execute(unsafeExecute, unDeBruijn) where @@ -7,7 +7,6 @@ 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((!)) @@ -20,7 +19,10 @@ undeb dep (Lambda e) = lambda (dep+1) (undeb (dep+1) e) undeb dep (X n) = X (dep-n) +undeb dep (Y :$ e) = case undeb dep e of K :$ und -> und -- fix (\_ -> foo) = foo + unde -> Y :$ unde undeb dep (e0 :$ e1) = undeb dep e0 :$ undeb dep e1 +undeb dep (Fix e n is) = undeb dep $ foldl (:$) (Y :$ FunLambda (napply n Lambda e)) (map X is) undeb dep e = e -- well, B' is not so efficient. @@ -53,7 +55,7 @@ unsafeExecute :: VarLib -> CoreExpr -> Dynamic unsafeExecute vl e = exe (unDeBruijn e) where exe (e0 :$ e1) = dynAppErr "apply" (exe e0) (exe e1) - exe (Primitive n) = snd (vl!n) + exe (Primitive n) = fromPD (vl!n) exe S = $(dynamic [|defaultTCL|] [| s :: (b->c->a) -> (b->c) -> b -> a |]) exe K = $(dynamic [|defaultTCL|] [| const :: a->b->a |]) exe I = $(dynamic [|defaultTCL|] [| id :: a->a |]) @@ -62,9 +64,11 @@ 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 Y = $(dynamic [|defaultTCL|] [| fix :: (a->a)->a |]) 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 +fix f = let x = f x in x diff --git a/MagicHaskeller/ExecuteAPI610.hs b/MagicHaskeller/ExecuteAPI610.hs new file mode 100644 --- /dev/null +++ b/MagicHaskeller/ExecuteAPI610.hs @@ -0,0 +1,513 @@ +-- +-- (c) Susumu Katayama +-- +{-# OPTIONS -fth -fglasgow-exts #-} +-- compile with -package ghc +module MagicHaskeller.ExecuteAPI610 {- (loadObj, prepareAPI, executeAPI, unsafeExecuteAPI) -} where +import qualified HscMain +import GHC +import GHC.Exts +import GHC.Paths(libdir) -- as instructed in http://haskell.org/haskellwiki/GHC/As_a_library +import DynFlags (DynFlag, defaultDynFlags, PackageFlag(ExposePackage)) -- , glasgowExtsFlags) ¤Ïexport¤µ¤ì¤Æ¤¤¤Ê¤¤¤é¤·¤¤. +import SrcLoc (SrcSpan(..), noSrcSpan, noSrcLoc, interactiveSrcLoc, Located(L), noLoc) + +-- import MyCorePrep ( corePrepExpr ) +import CorePrep(corePrepExpr) -- ¥³¥ó¥Ñ¥¤¥ë¤¬Ä̤é¤Ê¤¤¤Î¤Ç¥ª¥ê¥¸¥Ê¥ë¤Ë¤·¤Æ¤ß¤ë + +import FastString +import ByteCodeGen ( coreExprToBCOs ) + +-- import MyLink -- ( HValue, linkExpr, initDynLinker ) +import Linker -- ¥³¥ó¥Ñ¥¤¥ë¤¬Ä̤é¤Ê¤¤¤Î¤Ç¥ª¥ê¥¸¥Ê¥ë¤Ë¤·¤Æ¤ß¤ë + +-- import Flattening +import HscTypes -- ( HscEnv(..), Session(..), withSession, InteractiveContext(..), mkTypeEnv ) -- also import instance MonadIO Ghc +import SimplCore +-- import SimplOnce -- ¥³¥ó¥Ñ¥¤¥ë¤¬Ä̤é¤Ê¤¤¤Î¤Ç¥³¥á¥ó¥È¥¢¥¦¥È +import VarEnv ( emptyTidyEnv ) +import CoreSyn ( CoreExpr, Expr(..), Bind(..) ) -- compiler/coreSyn/CoreSyn.lhs +import CoreTidy ( tidyExpr ) + + +import Parser (parseStmt) +import Lexer +import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnType ) +import Desugar (deSugarExpr) +import PrelNames ( iNTERACTIVE ) +import ErrUtils +import StringBuffer (stringToStringBuffer) +import Outputable (ppr, pprPanic, showSDocDebug, showSDoc) +import TypeRep (pprType, Type) + +import CoreLint (lintUnfolding) +import VarSet (varSetElems) +import Panic (panic) + +import Var -- (Var(..)) + +import System.IO +import System.IO.Unsafe + +import Data.IORef + +import System.Exit +import Control.Monad(when) +-- import Control.Monad.Trans(liftIO) + +import MagicHaskeller.MyDynamic +import qualified MagicHaskeller.CoreLang as CoreLang +import Language.Haskell.TH as TH hiding (ppr) + +import Data.List(isSuffixOf) + +-- prelude/TysPrim. +import TysPrim(anyPrimTy) + +import Bag +import RdrName +import OccName +import Convert +import HsUtils +import HsExpr + +-- ºÇ¸å¤ÎCoreExpr ---> CoreExpr¤ÇÍפë¤â¤Î¡¥ +import IdInfo +import Data.Char(ord,chr) +import qualified Data.Map as Map +import qualified MagicHaskeller.Types as Types +import Data.List +import Unique +import Id + +import UniqSupply + +import ByteCodeLink(linkBCO,extendClosureEnv) +import ByteCodeAsm(UnlinkedBCO(unlinkedBCOName)) + +import Data.Array + +-- #define PRELINK + +pathToGHC :: FilePath -- path to GHC, e.g. "/usr/lib/ghc-6.10.4". 'libdir' can be used instead. +pathToGHC = libdir + +loadObj :: [String] -- ^ visible modules (including package modules). You may omit the Prelude. + -> IO (CoreLang.VarLib -> CoreLang.CoreExpr -> Dynamic) +loadObj fss = fmap unsafeExecuteAPI $ prepareAPI fss + +-- Just follow http://haskell.org/haskellwiki/GHC/As_a_library +-- ÌäÂê¤Ï¡¤¤¹¤Ç¤ËÆɤޤì¤Æ¤¤¤ëmodule¤Ï¤É¤¦¤¹¤ë¤«¤Ã¤Æ¤³¤È¤À¤±¤É¡¤:load¥³¥Þ¥ó¥ÉƱÍͺÆÆɤ߹þ¤ß +{- addNonPackageTarget¤Ã¤Æ¤Î¤òÄêµÁ¤·¤¿¤Î¤Ç¡¤Ê¬¤±¤ëɬÍפϤʤ¯¤Ê¤Ã¤¿¤Ï¤º¡¥ +prepareAPI :: [FilePath] -- ^ modules to be loaded (except package modules) + -> [FilePath] -- ^ visible modules (including package modules) + -> IO Session +prepareAPI fss allfss +-} +prepareAPI :: [String] -- ^ visible modules (including package modules) + -> IO HscEnv +prepareAPI fss + = defaultErrorHandler defaultDynFlags $ + runGhc (Just pathToGHC) $ do + liftIO $ hPutStrLn stderr "setting up flags" + + dfs <- getSessionDynFlags +-- when (flags dfs /= flags defaultDynFlags) $ error "flags are different" + let newf = dfs{opt_P = "-DTEMPLATE_HASKELL" : "-DCLASSIFY" : "-DCHTO" : opt_P dfs, -- defaultDynFlags¤Î¥½¡¼¥¹¤¬·ë¹½»²¹Í¤Ë¤Ê¤Ã¤¿¤ê¡¥ + packageFlags = [ ExposePackage "ghc" ], + flags = Opt_TemplateHaskell : Opt_Cpp : + Opt_MagicHash : + Opt_RankNTypes : + filter (/=Opt_MonomorphismRestriction) (flags dfs)} -- Was: Opt_TH -- ¤Æ¤æ¡¼¤«¡¤LibTH¤ò¤³¤³¤ÇÆɤà¤Ë¤Ï¤¤¤í¤ó¤Ê¥Õ¥é¥°¤¬.... + setSessionDynFlags newf -- result abandoned + -- ¥½¡¼¥¹¤Ë¤è¤ë¤È·ë²Ì¤ÏDynamic linking¤Î»þ¤ËɬÍפäƤ³¤È¤À¤±¤É¡¤¤Þ¡¤´ðËÜŪ¤Ë¤ÏDynamic linking¤Ïunsupported¤Ã¤Æ¤³¤È¤«¡¥ + -- http://hackage.haskell.org/trac/ghc/wiki/DynamicLinking + -- ...°ã¤¦¡¥¤½¤Îdynamic linking¤Ç¤Ï¤Ê¤¤¡¥ + + liftIO $ hPutStrLn stderr "loading modules" -- This IS necessary. + ts <- mapM (\fs -> guessTarget fs Nothing) fss + setTargets ts + sf <- defaultCleanupHandler newf (load LoadAllTargets) + case sf of Succeeded -> return () + Failed -> error "failed to load modules" + + liftIO $ hPutStrLn stderr "setting up modules" + modules <- mapM (\fs -> findModule (mkModuleName fs) Nothing) ("Prelude":"MagicHaskeller":fss) + setContext [] modules + +#ifdef PRELINK + -- prelink! + newdfs <- getSessionDynFlags + initDynLinker newdfs +#endif + + getSession +{- +-- | @addNonPackageTarget@ adds a target only if the target is not a package module. +-- This function assumes there is no package module in the target set of the session. +addNonPackageTarget :: Target -> IO () +addNonPackageTarget target@(Target targetid _) + = catchDyn (addTarget target >> depanal [] False >> return ()) + (\str -> if "is a package module" `isSuffixOf` str then removeTarget targetid else throwDyn str) +-- depanal¤¬Nothing¤òÊÖ¤¹¾ì¹ç¡¤·ë¶É¸å¤Îload¤¬fail¤¹¤ëÌõ¤À¤¬¡¤ÌÌÅݤʤΤǤ³¤ÎÃʳ¬¤Ç¤ÏÊüÃ֥ץ쥤¤Ã¤Æ¤³¤È¤Ç¡¥ +-} + +-- At least I should use a customized version of toString.... +unsafeExecuteAPI :: HscEnv -> CoreLang.VarLib -> CoreLang.CoreExpr -> Dynamic +unsafeExecuteAPI session vl cece = unsafeToDyn undefined undefined (unsafeCoerce# $ unsafePerformIO $ executeAPI session vl cece) undefined -- unsafeCoerce# is necessary to convert from Dynamic.HValue to HValue. +executeAPI :: HscEnv -> CoreLang.VarLib -> CoreLang.CoreExpr -> IO a +executeAPI session vl cece = executeTHExp session (CoreLang.exprToTHExp vl cece) +executeTHExp :: HscEnv -> TH.Exp -> IO a +executeTHExp session the = unwrapCore session =<< compileCoreExpr session the + + +compileCoreExpr :: HscEnv -> TH.Exp -> IO CoreSyn.CoreExpr +compileCoreExpr hscEnv the + = -- defaultErrorHandler defaultDynFlags $ -- thread killed ¤òɽ¼¨¤µ¤»¤¿¤¤¾ì¹ç¤Ï¤³¤Ã¤Á¡¥ +{- + do res <- compileExpr session $ TH.pprint $ CoreLang.exprToTHExp cece + case res of Nothing -> hPutStrLn stderr "Could not execute" >> error "could not execute" + Just hv -> return hv +-} + + +-- do mbt <- strToCore hscEnv ("let __cmCompileExpr = " ++ TH.pprint the) + + do mbt <- stmtToCore hscEnv $ wrapLHsExpr $ thExpToLHsExpr the + case mbt of Nothing -> error ("could not compile " ++ TH.pprint the ++ " to core.") + Just ([i ], ce) -> return ce + + +-- unwrapCore, unwrapCore' ¤ÎξÊý¤¬Àµ¤·¤¯Æ°¤¯¡¥unwrapCore¤Ïghc6.8¤ÇÆ°¤¤¤Æ¤¤¤¿¤Î¤ò»ý¤Ã¤Æ¤­¤¿¤â¤Î¤Ç¡¤compileExprHscMain¤ÎÊý¤ò¥³¥á¥ó¥È¥¢¥¦¥È¤·¤ÆrunCoreExpr¤Ë¤¹¤ë¤È¿§¡¹¤Ï¤·¤ç¤ëÂå¤ï¤ê¤ËÀµ¤·¤¯Æ°¤«¤Ê¤¤¡¥ +unwrapCore, unwrapCore' :: HscEnv -> CoreSyn.CoreExpr -> IO a +unwrapCore hscEnv ce = do -- iohvs <- runCoreExpr hscEnv ce -- (removeIdInfo ce) + iohvs <- unsafeCoerce# $ compileExprHscMain hscEnv ce + [hv] <- iohvs + return hv + +unwrapCore' hscEnv ce = fmap head $ unsafeCoerce# =<< HscMain.compileExpr hscEnv (srcLocSpan interactiveSrcLoc) ce + + +runCoreExpr, runPrepedCoreExpr :: HscEnv -> CoreExpr -> IO a +runCoreExpr hscEnv ce + = -- repeatIO 10 $ + do + let dfs = hsc_dflags hscEnv + pe <- corePrepExpr dfs ce -- runPrepedCoreExpr¤È¤Î°ã¤¤¤Ï¤³¤ÎcorePrepExpr¤¬¤¢¤ë¤«¤É¤¦¤«¤À¤± + + bcos <- -- repeatIO 10 $ + coreExprToBCOs dfs pe + +#ifdef PRELINK + hv <- linkTheExpr bcos +#else + hv <-linkExpr hscEnv noSrcSpan bcos +#endif + return $ unsafeCoerce# hv + +runPrepedCoreExpr hscEnv ce + = -- repeatIO 10 $ + do + let dfs = hsc_dflags hscEnv + + bcos <- coreExprToBCOs dfs ce + -- repeatIO 10 $ +#ifdef PRELINK + hv <- linkTheExpr bcos +#else + hv <-linkExpr hscEnv noSrcSpan bcos +#endif + return $ unsafeCoerce# hv + +#ifdef PRELINK +-- | If already prelinked linkTheExpr can be used in place of linkExpr. +linkTheExpr :: UnlinkedBCO -> IO HValue +linkTheExpr ulbco + = do pls <- readIORef v_PersistentLinkerState + let ie = itbl_env pls + ce = closure_env pls + nm = unlinkedBCOName ulbco + fixIO (\hv -> linkBCO ie (extendClosureEnv ce [(nm,hv)]) ulbco) +#endif + + +stmtToCore hscEnv pst = do let dfs = hsc_dflags hscEnv + icxt = hsc_IC hscEnv + (tcmsgs, mbtc) <- tcRnStmt hscEnv icxt pst + case mbtc of Nothing -> perror dfs tcmsgs + Just (ids, tc_expr) -> do -- desugar + let typeEnv = mkTypeEnv (map AnId (ic_tmp_ids icxt)) + (desmsgs, mbds) <- deSugarExpr hscEnv iNTERACTIVE (ic_rn_gbl_env icxt) typeEnv tc_expr + case mbds of Nothing -> perror dfs desmsgs + Just ds -> return (Just (ids, ds)) +perror dfs msg = printErrorsAndWarnings dfs msg >> return Nothing + +unwrapLStmt (L _ (LetStmt (HsValBinds (ValBindsIn bg _)))) = unL $ head $ bagToList bg +unL (L _ x) = x + +thExpToStmt :: TH.Exp -> HsExpr.LStmt RdrName.RdrName +thExpToStmt = wrapLHsExpr . thExpToLHsExpr +wrapLHsExpr :: HsExpr.LHsExpr RdrName.RdrName -> HsExpr.LStmt RdrName.RdrName +wrapLHsExpr expr = noLoc $ LetStmt (HsValBinds (ValBindsIn (Bag.unitBag (HsUtils.mk_easy_FunBind noSrcSpan (Unqual $ mkOccName OccName.varName "__cmCompileExpr") [] expr)) [])) +thExpToLHsExpr :: TH.Exp -> HsExpr.LHsExpr RdrName.RdrName +thExpToLHsExpr e = case Convert.convertToHsExpr noSrcSpan e of + Left msg -> error $ showSDoc msg + Right expr -> expr + +instance Show b => Show (Expr b) where + showsPrec p (Var var) = ("Var "++) . (showSDocDebug (ppr var) ++) + showsPrec _ (Lit l) = ("Lit "++) . shows l + showsPrec _ (App e0@(App _ _) e1) = shows e0 . (" `App` "++) . showParen True (shows e1) + showsPrec _ (App e0 e1) = showParen True (shows e0) . (" `App` "++) . showParen True (shows e1) + showsPrec _ (Lam v e) = ('\\':) . shows v . shows e + showsPrec _ (Let bs e) = ("let"++) . shows bs . (" in "++) . shows e + showsPrec _ (Case _ _ _ _) = ("case"++) + showsPrec _ (Cast e t) = ("Cast "++) . showParen True (shows e) . (""++) + showsPrec _ (Note _ _) = ("Note"++) + showsPrec _ (Type t) = (showSDoc (pprType t) ++) +instance Show b => Show (Bind b) where + showsPrec _ (NonRec b e) = (' ':) . shows b . (" = "++) . shows e + showsPrec _ (Rec ts ) = ("rec { "++) . foldr (.) id (map hoge ts) . (" } "++) +hoge :: Show b => (b, Expr b) -> ShowS +hoge (b, e) = shows b . (" = "++) . shows e . (" ; "++) + + + +-- remove the type info to see if they are necessary even when there is no ad-hoc polymorphism +removeTInfo :: Expr b -> Expr b +removeTInfo (App e0 e1) = App (removeTInfo e0) (removeTInfo e1) +removeTInfo (Lam v e) = Lam v (removeTInfo e) +removeTInfo (Let bs e) = Let (rtis bs) (removeTInfo e) +removeTInfo (Type t) = Type anyPrimTy +removeTInfo (Cast e t) = Cast (removeTInfo e) t +removeTInfo e = e + +rtis (NonRec b e) = NonRec b (removeTInfo e) +rtis (Rec ts) = Rec [ (b, removeTInfo e) | (b,e) <- ts ] + +compileExprHscMain :: HscEnv -> CoreExpr -> IO HValue +compileExprHscMain hscEnv ce + = do let dflags = hsc_dflags hscEnv + smpl <- simplifyExpr dflags ce + prep <- corePrepExpr dflags smpl + bcos <- coreExprToBCOs dflags prep + linkExpr hscEnv noSrcSpan bcos + + +directLoadObj :: [String] -- ^ visible modules (including package modules). You may omit the Prelude. + -> [(a, TH.Exp, TH.Type)] + -> IO (CoreLang.CoreExpr -> Dynamic) +directLoadObj fss tups + = defaultErrorHandler defaultDynFlags $ do + hscEnv <- prepareAPI fss + +#ifdef PRELINK + hPutStrLn stderr "prelink! (temporarily)" + compileExpr hscEnv "([], (:), list_para)" +-- compileExpr session "([]::[a], (:)::a->[a]->[a], list_para::[b]->a->(b->[b]->a->a)->a)" +-- compileExpr "([]::[Char], (:)::Char->[Char]->[Char], list_para::[Char]->Int-> +#endif + + gm <- mkGlobalAr hscEnv tups + return $ unsafeDirectExecuteAPI hscEnv gm + +unsafeDirectExecuteAPI hscEnv gm ce = unsafePerformIO $ directExecuteAPI hscEnv gm ce +directExecuteAPI :: HscEnv -> GlobalAr -> CoreLang.CoreExpr -> IO a +directExecuteAPI hscEnv gm ce + = runCoreExpr hscEnv $ ceToCSCE gm ce + + +-- Note: MagicHaskeller.Primitive = (HValue, TH.Exp, TH.Type) +-- Use +-- typeToTHType :: TyConLib -> Types.Type -> TH.Type +-- if necessary. TyConLib can be undefined here. +compileVar :: HscEnv -> (a, TH.Exp, TH.Type) -> IO CoreSyn.CoreExpr +compileVar hscEnv (_, the, ty) + = do csce <- compileCoreExpr hscEnv the -- ¤³¤ì¤À¤È¡¤[| (==)::Char->Char->Bool |]¤ß¤¿¤¤¤Ê¾ì¹ç¤Ëthe¤¬Ã±¤ËVarE '(==)¤Ë¤Ê¤Ã¤Æ¤¦¤Þ¤¯¤¤¤«¤Ê¤¤¡¥(ad hoc¤Êtyvar¤¬instantiate¤µ¤ì¤Ê¤¤) + -- Just (_,csce) <- strToCore session ("let __compileExpr = ("++TH.pprint the ++")::"++TH.pprint (unforall ty)) + let unr = unwrap csce + putStrLn ("csce = "++show unr) + case ty of TH.ForallT tvs [] _ -> do let dfs = hsc_dflags hscEnv + simplifyExpr dfs $ foldl CoreSyn.App unr $ replicate (length tvs) $ CoreSyn.Type anyPrimTy + -- CorePrep ¤Ï ÉÔÍפʤϤº¤Ç¤Ï¤¢¤ë¤¬¡¤¤É¤¦¤¹¤ë¤è¡© + _ -> return unr +unwrap (Let (Rec ((_,e):_)) _) = e +-- unwrap (Let (Rec [(_,e)]) _) = e -- ¤³¤Ã¤Á¤À¤È¤Ê¤¼¤«¥À¥á¤Ç¡¤¤½¤ÎÊդ˥Х°¤Î¤Ë¤Û¤Ò¤¬.... +unwrap st = error (show st) +unforall (TH.ForallT _ _ t) = t +unforall t = t + +type GlobalMap = Map.Map String CoreSyn.CoreExpr -- String¤ÎÂå¤ï¤ê¤ËTH.Name¤Ê¤É¤Ë¤·¤è¤¦¤È¤¹¤ë¤È¡¤¤Á¤ã¤ó¤Èequivalence¤¬»×¤¤Ä̤ê¤Î·ë²Ì¤Ë¤Ê¤Ã¤Æ¤¯¤ì¤Ê¤¤¡¥¡¥ +mkGlobalMap :: HscEnv -> [(a, TH.Exp, TH.Type)] -> IO GlobalMap +-- ¤Æ¤æ¡¼¤«¡¤CoreLang.CoreExpr¤ÎPrimitive¤¬CoreSyn.CoreExpr¤Î¾ðÊó¤ò»ý¤Ä¤Î¤¬Â®¤¤¡¥ +-- data CoreExpr a = ... ¤ß¤¿¤¤¤Ë¤·¤Æ¡¤CoreExpr CoreSyn.CoreExpr¤ß¤¿¤¤¤Ë»È¤¦¡¥ +mkGlobalMap hscEnv tups = do ces <- mapM (compileVar hscEnv) tups + return $ Map.fromList $ zip (map (\(_,b,_) -> thToBaseString b) tups) ces + + +{- +-- See Linker.linkDependencies +linkDeps :: Session -> [Module] -> IO Bool +linkDeps session mods = + +¤Æ¤æ¡¼¤«ºÇ½é¤Ë"([],(:),list_para,lines,take)"¤ß¤¿¤¤¤Ê¤Î¤òcompileExpr¤·¤Æ¤·¤Þ¤¨¤Ðprelink¤µ¤ì¤ë¤Î¤Ç¤Ï¡© + + +-- obtain the set of modules required to be linked +cscesToNeededModules :: [CoreSyn.CoreExpr] -> [Module] +cscesToNeededModules csces = [ GHC.nameModule n | csce <- csces, + var <- csceToVars' csce [], + let n = Var.varName n, + isExternalName n, + not (isWiredInName n) ] + +-- Should I define instance Generic (Expr b)? +csceToVars' :: CoreSyn.CoreExpr -> [Var.Var] -> [Var.Var] +csceToVars' (Var var) = (var:) +csceToVars' (App e0 e1) = csceToVars' e0 . csceToVars' e1 +csceToVars' (Lam _ e) = csceToVars' e +csceToVars' (Let (NonRec _ e0) e1) = csceToVars' e0 . csceToVars' e1 +csceToVars' (Let (Rec tups) e) = foldr (.) (csceToVars' e) [ csceToVars' a | (_,a) <- tups ] +csceToVars' (Case e _ _ tups) = foldr (.) (csceToVars' e) [ csceToVars' a | (_,_,a) <- tups ] +csceToVars' (Cast e _) = csceToVars' e +csceToVars' (Note _ e) = csceToVars' e +csceToVars' _ = id -- Lit case and Type case + +-} + + +thExpToCSCE :: GlobalMap -> TH.Exp -> CoreSyn.CoreExpr +thExpToCSCE gm ce = ctc [] ce + where ctc pvs (TH.LamE pvars e) = foldr CoreSyn.Lam (ctc (pvars++pvs) e) (map (mkStrVar . show . unVarP) pvars) + ctc pvs (e0 `TH.AppE` e1) = ctc pvs e0 `CoreSyn.App` ctc pvs e1 + ctc pvs (InfixE (Just e0) e (Just e1)) = lup e `CoreSyn.App` ctc pvs e0 `CoreSyn.App` ctc pvs e1 + ctc pvs (TH.VarE name) | VarP name `elem` pvs = CoreSyn.Var $ mkStrVar $ show name + -- VarE¤Î¾ì¹ç¡¤lambda bound¤Î¾ì¹ç¤È¡¤global¤Î¾ì¹ç¤È¤Ç°·¤¤¤¬°Û¤Ê¤ë¡¥ + -- ¥¹¥³¡¼¥×¤ò¤Þ¤¸¤á¤Ë¹Í¤¨¤ë¤È¡¤lambda bound¤«¤É¤¦¤«¤ò¥Á¥§¥Ã¥¯¤·¤Æ¤«¤églobal¤Ë¤¢¤ë¤«¤É¤¦¤«¤ò¤ß¤ë¤³¤È¤Ë¤Ê¤ë¡¥ + ctc pvs e = lup e + lup e = case Map.lookup (thToBaseString e) gm of Nothing -> error (show e ++ ", i.e.,\n" ++ TH.pprint e ++ " : could not convert to CoreSyn.CoreExpr") + Just csce -> csce +thToBaseString (ConE name) = nameBase name +thToBaseString (VarE name) = nameBase name + +unVarP (TH.VarP n) = n +mkIntVar i = Id.mkUserLocal (mkVarOcc [chr i]) (Unique.getUnique i) anyPrimTy noSrcSpan +mkStrVar str = Id.mkUserLocal (mkVarOcc str) (Unique.getUnique $ mkFastString str) anyPrimTy noSrcSpan + + +type GlobalAr = Array Int CoreSyn.CoreExpr +mkGlobalAr :: HscEnv -> [(a, TH.Exp, TH.Type)] -> IO GlobalAr +mkGlobalAr hscEnv tups = do ces <- mapM (compileVar hscEnv) tups + return $ listArray (0, length tups - 1) ces + +ceToCSCE :: GlobalAr -> CoreLang.CoreExpr -> CoreSyn.CoreExpr +ceToCSCE ga ce = ctc (ord 'a'-1) ce + where ctc dep (CoreLang.Lambda e) = CoreSyn.Lam (mkIntVar (dep+1)) $ ctc (dep+1) e + ctc dep (CoreLang.X n) = CoreSyn.Var $ mkIntVar (dep-n) + ctc dep (CoreLang.Primitive n) = ga ! n + ctc dep (e0 CoreLang.:$ e1) = ctc dep e0 `CoreSyn.App` ctc dep e1 + + + + +es = map mkIntVar [ord 'e'..] +as = map mkIntVar [128..] -- ̵Íý¤¬¤¢¤ë? +xs = map mkIntVar [192..] +hd = mkIntVar (ord 'a') -- ¤³¤ì¤Ï°ú¿ô¤Ë¤·¤Æ¤âÎɤ¤ + +mkTV :: Int -> Types.Type +mkTV = Types.TV +tvrs = map mkTV [1..] +tvas = map mkTV [2000..] +tvr = mkTV 0 + +-- ({} \ hd e1..em a1..an -> {hd e1..em a1..an} let x1 = {e1 a1..an} e1 a1..an in {hd x1 e2..em a1..an} let x2 = {e2 a1..an} e2 a1..an in .. {hd x1..xm-1 em a1..an} let xm = {em a1..an} em a1..an in {hd x1..xm} hd x1..xm +-- ¤Æ¤«¡¤°ìÈ־夬emptyVarSet¤Ç¤¢¤ë¤³¤È¤ò½ü¤±¤Ð¡¤¤¢¤È¤Ïundefined¤Ç¤¤¤¤¤Ï¤º¡¥... ¤È»×¤Ã¤¿¤±¤É¡¤schemeE¤ÎÄêµÁ¤ò¸«¤¿´¶¤¸let bindings¤Î±¦ÊդΰìÈÖ³°Â¦¤Ë´Ø¤·¤Æ¤ÏɬÍפߤ¿¤¤¡¥see notes on Aug. 12, 2008 +-- ({} \ hd e1..em a1..an -> let x1 = {e1 a1..an} e1 a1..an in let x2 = {e2 a1..an} e2 a1..an in .. let xm = {em a1..an} em a1..an in hd x1..xm +-- ¤È¤¤¤¦ÄøÅ٤ξðÊ󤬤¢¤ì¤Ð½½Ê¬¡¥ + +-- (\hd e1..em a1..an -> let x1 = e1 a1..an in .. let xm = em a1..an in hd x1..xm) :: (r1->..->rm->r) -> (a1->..->an->r1)->..->(a1->..->an->rm) -> a1->..->an -> r +hdmnPreped :: Int -> Int -> CoreSyn.CoreExpr +hdmnPreped m 0 = hdmn m 0 -- ÍפÏid¤òÀ¸À®¤¹¤ë¤Ã¤Æ¤³¤È¡¥ +hdmnPreped m n = lambdas $ lets $ foldl CoreSyn.App (CoreSyn.Var hd) (map CoreSyn.Var mxs) + where + mes = take m es + mxs = take m xs + nas = take n as + lambdas = flip (foldr ($)) (map CoreSyn.Lam (hd : mes ++ nas)) + lets = flip (foldr CoreSyn.Let) binds + where binds = zipWith CoreSyn.NonRec mxs $ map appa1an mes + where appa1an var = foldl CoreSyn.App (CoreSyn.Var var) $ map CoreSyn.Var nas +-- CorePrep Á°¤Î¤â¤Î¤òÀ¸À®¤¹¤ë¾ì¹ç +-- (\hd e1..em a1..an -> hd (e1 a1..an) .. (em a1..an)) :: (r1->..->rm->r) -> (a1->..->an->r1)->..->(a1->..->an->rm) -> a1->..->an -> r +hdmn m n = lambdas $ foldl CoreSyn.App (CoreSyn.Var hd) $ map appa1an mes + where appa1an var = foldl CoreSyn.App (CoreSyn.Var var) $ map CoreSyn.Var nas + mes = take m es + nas = take n as + lambdas = flip (foldr ($)) (map CoreSyn.Lam (hd : mes ++ nas)) + +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 + + +-- (\e1..em a1..an -> let x1 = e1 a1..an in .. let xm = em a1..an in ai x1 .. xm) -- more exactly, not ai but ai-1 because (!!) counts starting 0 +-- :: (a1->..->(r1->..->rm->r)->..->an->r1)->..->(a1->..->(r1->..->rm->r)->..->an->rm) -> +-- a1->..->(r1->..->rm->r)->..->an -> r +-- aimnPreped i m 0 = aimn i m 0 -- ¤³¤ì¤Ï¤¢¤ê¤¨¤Ê¤¤¥±¡¼¥¹ +aimnPreped i m n = lambdas $ foldl CoreSyn.App (CoreSyn.Var (as!!i)) (map CoreSyn.Var mxs) + where mes = take m es + mxs = take m xs + nas = take n as + lambdas = flip (foldr ($)) (map CoreSyn.Lam (mes ++ nas)) + lets = flip (foldr CoreSyn.Let) binds + where binds = zipWith CoreSyn.NonRec mxs $ map appa1an mes + where appa1an var = foldl CoreSyn.App (CoreSyn.Var var) $ map CoreSyn.Var nas +-- CorePrepÁ°¤Î¤â¤Î¤òÀ¸À®¤¹¤ë¾ì¹ç +-- (\e1..em a1..an -> ai (e1 a1..an) .. (em a1..an)) -- more exactly, not ai but ai-1 because (!!) counts starting 0 +-- :: (a1->..->(r1->..->rm->r)->..->an->r1)->..->(a1->..->(r1->..->rm->r)->..->an->rm) -> +-- a1->..->(r1->..->rm->r)->..->an -> r +aimn i m n = lambdas $ foldl CoreSyn.App (CoreSyn.Var (as!!i)) $ map appa1an mes + where appa1an var = foldl CoreSyn.App (CoreSyn.Var var) $ map CoreSyn.Var nas + mes = take m es + nas = take n as + lambdas = flip (foldr ($)) (map CoreSyn.Lam (mes ++ nas)) + +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 i tvas of (tk,_:dr) -> tk ++ hdty : take (n-i-1) dr -- hdmnty¤È¤Î°ã¤¤¤Ï¤³¤³¤À¤± + +mkHdmn :: HscEnv -> Int -> Int -> IO Dynamic +mkHdmn hscEnv m n = do let ce = hdmn m n + val <- runCoreExpr hscEnv ce + return $ unsafeToDyn undefined (hdmnty m n) val undefined -- (CoreLang.exprToTHExp undefined ce) CoreLang¤Ç¤Ï¤Ê¤¯¤ÆCoreSyn¤«¤é +mkAimn :: HscEnv -> Int -> Int -> Int -> IO Dynamic +mkAimn hscEnv i m n = do let ce = aimn i m n + val <- runCoreExpr hscEnv ce + return $ unsafeToDyn undefined (aimnty i m n) val undefined -- (CoreLang.exprToTHExp undefined ce) + +-- ¤³¤Ã¤«¤é¥×¥í¥Õ¥¡¥¤¥ëÍÑ + + +repeatN n f x = force $ map f $ replicate n x +repeatIO n act = fmap force $ sequence $ replicate n act + +-- force (x:xs) = all (x==) xs `seq` x +force = foldr1 seq + +instance Eq (Expr a) where + Var i == Var j = True -- i==j + Lit l == Lit m = l==m + App f e == App g i = g==f && e==i + Lam b e == Lam c f = {- b==c && -} e==f + Let b e == Let c f = {- b==c && -} e==f + Case e b t ab == Case f c u bc = e==f {- && b==c && t==u && ab == bc -} + Cast e c == Cast f d = e==f {- && c==d -} + Note n e == Note m f = {- n==m && -} e==f + Type t == Type u = True -- t==u + + + diff --git a/MagicHaskeller/ExprStaged.hs b/MagicHaskeller/ExprStaged.hs --- a/MagicHaskeller/ExprStaged.hs +++ b/MagicHaskeller/ExprStaged.hs @@ -1,5 +1,5 @@ -- --- (c) Susumu Katayama 2009 +-- (c) Susumu Katayama -- {-# OPTIONS -O -fglasgow-exts #-} module MagicHaskeller.ExprStaged where @@ -141,8 +141,6 @@ 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) diff --git a/MagicHaskeller/Expression.hs b/MagicHaskeller/Expression.hs --- a/MagicHaskeller/Expression.hs +++ b/MagicHaskeller/Expression.hs @@ -1,5 +1,5 @@ -- --- (c) Susumu Katayama 2009 +-- (c) Susumu Katayama -- module MagicHaskeller.Expression(module MagicHaskeller.Expression, module MagicHaskeller.ExprStaged, CoreExpr) where import MagicHaskeller.CoreLang @@ -166,6 +166,10 @@ replaceVars dep e argss = [e] cvtAvails = unzip . tkr10 . annotate + +tkr10 :: [(Type,Int)] -> [(Type,[Int])] +tkr10 = mergesortWithBy (\ (k,is) (_,js) -> (k,is++js)) (\ (k,_) (l,_) -> k `compare` l) . map (\(k,i)->(k,[i])) + -- annotate$B$O(BsplitAvails$B$NA0=hM}$H$7$F$b;H$($k!%(B annotate :: [Type] -> [(Type,Int)] diff --git a/MagicHaskeller/FakeDynamic.hs b/MagicHaskeller/FakeDynamic.hs --- a/MagicHaskeller/FakeDynamic.hs +++ b/MagicHaskeller/FakeDynamic.hs @@ -1,5 +1,5 @@ -- --- (c) Susumu Katayama 2009 +-- (c) Susumu Katayama -- {-# OPTIONS -XMagicHash -XExistentialQuantification -XPolymorphicComponents #-} module MagicHaskeller.FakeDynamic( @@ -9,10 +9,11 @@ dynApply, dynApp, dynAppErr, - dynType, unsafeFromDyn, -- :: Dynamic -> a unsafeToDyn, -- :: Type -> a -> Dynamic - aLittleSafeFromDyn -- :: Type -> Dynamic -> a + aLittleSafeFromDyn, -- :: Type -> Dynamic -> a + fromPD, + dynamic, dynamicH -- I (susumu) believe this is enough, provided unsafeFromDyn does not invoke typeOf for type checking. (Otherwise there would be ambiguity error.) ) where @@ -24,13 +25,18 @@ import MagicHaskeller.TyConLib import Control.Monad -infixl `dynApp` +import qualified MagicHaskeller.PolyDynamic as PD -newtype Dynamic = Dynamic (forall a. a) +import MagicHaskeller.ReadTHType(thTypeToType) +import MagicHaskeller.ReadTypeRep(trToType) +import Language.Haskell.TH hiding (Type) +import MagicHaskeller.MHTH +import Data.Typeable(typeOf) -unsafeFromDyn :: Dynamic -> a -unsafeFromDyn (Dynamic v) = v + +newtype Dynamic = Dynamic {unsafeFromDyn::forall a. a} + unsafeToDyn :: TyConLib -> Type -> a -> e -> Dynamic unsafeToDyn _ tr a e = Dynamic (unsafeCoerce# a) @@ -53,5 +59,26 @@ 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." +fromPD :: PD.Dynamic -> Dynamic +fromPD = Dynamic . PD.unsafeFromDyn + + +-- °Ê²¼¤ÏMyDynamic¤«¤é¤È¤Ã¤Æ¤­¤¿¤â¤Î¤Ç¡¤PolyDynamic¤Ë¤¢¤ë¤Î¤ÈÁ´¤¯Æ±¤¸¡¥ +{- +$(dynamic [|tcl|] [| (,) :: forall a b. a->b->(a,b) |]) +¤Î¤è¤¦¤Ë¤Ç¤­¤ë¤è¤¦¤Ë¤¹¤ë¡¥CLEAN¤Îdynamic¤ß¤¿¤¤¤Ê´¶¤¸¡¥ +-} +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' +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 diff --git a/MagicHaskeller/GetTime.hs b/MagicHaskeller/GetTime.hs new file mode 100644 --- /dev/null +++ b/MagicHaskeller/GetTime.hs @@ -0,0 +1,39 @@ +-- +-- (c) Susumu Katayama +-- +module MagicHaskeller.GetTime where +import System.CPUTime +import System.Time -- better than Time in Haskell98 Library in that the former supports pretty printing TimeDiff. +import System.IO +import Control.Monad(liftM2) + +batchWrite :: FilePath -> [IO a] -> IO () +batchWrite filename ios = do is <- batchRun ios + hPutStrLn stderr (showCPUTime (sum is) ++ " seconds in total.") + writeFile filename $ unlines $ map showCPUTime is +batchRun :: [IO a] -> IO [Integer] +batchRun [] = return [] +batchRun (io:ios) = liftM2 (:) (fmap snd $ time io) (batchRun ios) + +time :: IO a -> IO (a, Integer) +time act = do beginCT <- getClockTime + begin <- getCPUTime + result <- act + end <- getCPUTime + endCT <- getClockTime + hPutStrLn stderr (showZero (timeDiffToString (diffClockTimes endCT beginCT)) ++ " in real,") +-- hPutStrLn stderr (shows (end-begin) " plusminus " ++ shows cpuTimePrecision " picoseconds spent.") + hPutStrLn stderr (showCPUTime (end-begin) ++ " seconds in CPU time spent.") + return (result, end-begin) + +showZero "" = "0 secs" +showZero s = s + +showCPUTime :: Integer -> String +showCPUTime t = let s = show t + l = length s + (p,f) = splitAt (l - 12) s + in case compare l 12 of GT -> p ++ '.' : take (13 - lenPrec) f + EQ -> "0." ++ take (13 - lenPrec) f + LT -> "0." ++ replicate (12-l) '0' ++ take (12 - lenPrec) s +lenPrec = length (show cpuTimePrecision) diff --git a/MagicHaskeller/Instantiate.hs b/MagicHaskeller/Instantiate.hs --- a/MagicHaskeller/Instantiate.hs +++ b/MagicHaskeller/Instantiate.hs @@ -1,5 +1,5 @@ -- --- (c) Susumu Katayama 2009 +-- (c) Susumu Katayama -- {-# OPTIONS -fglasgow-exts -cpp #-} module MagicHaskeller.Instantiate(mkRandTrie, RTrie, -- arbitraries, diff --git a/MagicHaskeller/LibTH.hs b/MagicHaskeller/LibTH.hs --- a/MagicHaskeller/LibTH.hs +++ b/MagicHaskeller/LibTH.hs @@ -1,5 +1,5 @@ -- --- (c) Susumu Katayama 2009 +-- (c) Susumu Katayama -- -- This file is supposed to be used with Version 0.8.5 of MagicHaskeller. -- For previous versions, try: @@ -10,6 +10,7 @@ import MagicHaskeller import System.Random(mkStdGen) +import Control.Monad(liftM2) initialize, init075 :: IO () initialize = do setPrimitives (list ++ nat ++ natural ++ mb ++ bool ++ $(p [| (hd :: (->) [a] (Maybe a), (+) :: Int -> Int -> Int, (+) :: Integer -> Integer -> Integer) |])) @@ -19,6 +20,16 @@ init075 = do setPG $ mkMemo075 (list ++ nat ++ natural ++ mb ++ bool ++ $(p [| ((+) :: Int -> Int -> Int, (+) :: Integer -> Integer -> Integer) |] )) setDepth 10 +-- The @tv1@ option prevents type variable @a@ in @forall a. E1(a) -> E2(a) -> ... -> En(a) -> a@ from matching n-ary functions where n>=2. +-- This can safely be used if @(,)@ and @uncurry@ are in the primitive set, +-- because @forall a b c. E1(a->b->c) -> E2(a->b->c) -> ... -> En(a->b->c) -> a -> b -> c@ and @forall a b c. E1((a,b)->c) -> E2((a,b)->c) -> ... -> En((a,b)->c) -> (a,b) -> c@ are isomorphic, and thus the latter can always be used instead of the former. + +inittv1 = do setPG $ mkPGOpt (options{primopt = Nothing, tv1 = True}) + (list ++ nat ++ natural ++ mb ++ bool ++ tuple ++ $(p [| (hd :: (->) [a] (Maybe a), (+) :: Int -> Int -> Int, (+) :: Integer -> Integer -> Integer) |] )) + setDepth 10 + +tuple = $(p [| ((,) :: a -> b -> (a,b), uncurry :: (a->b->c) -> (->) (a,b) c) |]) + -- 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) |])) @@ -45,7 +56,7 @@ -- 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, nat, natural, list', list, bool, boolean, eq, intinst, list1, list2, list3, nats, tuple, 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)) |] ) @@ -58,8 +69,8 @@ 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' = $(p [| ([], (:), foldr :: (b -> a -> a) -> a -> (->) [b] a) |] ) +list = $(p [| ([], (:), list_para :: (->) [b] (a -> (b -> [b] -> a -> a) -> a)) |] ) -- List paramorphism list_para :: [b] -> a -> (b -> [b] -> a -> a) -> a @@ -71,6 +82,39 @@ iF :: Bool -> a -> a -> a iF True t f = t iF False t f = f + +-- | 'postprocess' replaces uncommon functions like paramorphisms with well-known functions. In future it can do some refactoring. +postprocess :: Exp -> ExpQ +{- This type of patterns is not available yet. +postprocess (AppE (AppE (AppE (VarE 'iF) p) t) f) = [| if $(postprocess p) then $(postprocess t) else $(postprocess f) |] +postprocess (AppE (AppE (AppE (VarE 'nat_para) i) x) f) = [| let {np 0 = $(postprocess x); np (n+1) = $(postprocess f) n (np n)} in np (abs $(postprocess i)) |] +postprocess (AppE (AppE (AppE (VarE 'list_para) xs) x) f) = [| let {lp [] = $(postprocess x); lp (y:ys) = $(postprocess f) y ys (lp ys)} in lp $(postprocess xs) |] +-} +postprocess (AppE (AppE (AppE (VarE name) p) t) f) + = case nameBase name of + "iF" -> [| if $(postprocess p) then $(postprocess t) else $(postprocess f) |] + "nat_para" -> [| let {np 0 = $(postprocess t); np n = let i=n-1 in $(postprocess f) i (np i)} in np (abs $(postprocess p)) |] + "list_para" -> [| let {lp [] = $(postprocess t); lp (y:ys) = $(postprocess f) y ys (lp ys)} in lp $(postprocess p) |] +postprocess (AppE f x) = [| $(postprocess f) $(postprocess x) |] +-- postprocess (VarE 'iF) = [| \p t f -> if p then t else f |] -- This pattern is actually unnecessary because only eta-long normal expressions will be generated. +-- ... +postprocess (InfixE me1 op me2) = let fmapM f Nothing = return Nothing + fmapM f (Just x) = fmap Just (f x) + in liftM2 (\e1 e2 -> InfixE e1 op e2) (fmapM postprocess me1) (fmapM postprocess me2) +postprocess (LamE pats e) = fmap (LamE pats) (postprocess e) +postprocess (TupE es) = fmap TupE (mapM postprocess es) +postprocess (ListE es) = fmap ListE (mapM postprocess es) +postprocess (SigE e ty) = fmap (`SigE` ty) (postprocess e) +postprocess e = return e + +{- +postprocess :: Exp -> Exp +postprocess (AppE (AppE (AppE (VarE 'iF) p) t) f) = CondE (postprocess p) (postprocess t) (postprocess f) +postprocess (VarE 'iF) = LamE [ VarP n | n <- names ] (CondE p t f) + where names@[p,t,f] = [ mkName [n] | n <- "ptf" ] +postprocess +-} + boolean = $(p [| ((&&) :: Bool -> Bool -> Bool, diff --git a/MagicHaskeller/MHTH.lhs b/MagicHaskeller/MHTH.lhs --- a/MagicHaskeller/MHTH.lhs +++ b/MagicHaskeller/MHTH.lhs @@ -1,46 +1,21 @@ -- --- (c) Susumu Katayama 2009 +-- (c) Susumu Katayama -- -MHTH is consisted of combinators which include quasi-quotes. They are moved from MagicHaskeller.lhs because Haddock dislikes quasi-quotes. +MHTH used to consist 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 +module MagicHaskeller.MHTH(expToExpExp, typeToExpType, decsToExpDecs) 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) +import MagicHaskeller.ReadTHType(showTypeName, plainTV, unPlainTV) -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)) @@ -81,7 +56,7 @@ 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 ns [] t) = [| ForallT (map (plainTV . mkName) $(return $ ListE $ map (LitE . StringL . showTypeName . unPlainTV) 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)) |] @@ -100,6 +75,13 @@ patToExpPat (ListP ps) = [| ListP $(liftM ListE $ mapM patToExpPat ps) |] patToExpPat (SigP p t) = [| SigP $(patToExpPat p) $(typeToExpType t) |] +decsToExpDecs ds = fmap ListE $ mapM decToExpDec ds +decToExpDec (FunD name clauses) = [| FunD (mkName $(nameToNameStr showTypeName name)) $(liftM ListE $ mapM clauseToExpClause clauses) |] +decToExpDec (ValD pat (NormalB e) decs) = [| ValD $(patToExpPat pat) (NormalB $(expToExpExp e)) $(liftM ListE $ mapM decToExpDec decs) |] +decToExpDec (SigD name ty) = [| SigD (mkName $(nameToNameStr showTypeName name)) $(typeToExpType ty) |] +decToExpDec d = error (show d ++ " : unsupported") + +clauseToExpClause (Clause pats (NormalB e) decs) = [| Clause $(liftM ListE $ mapM patToExpPat pats) (NormalB $(expToExpExp e)) $(liftM ListE $ mapM decToExpDec decs) |] #endif instance Ord Type where diff --git a/MagicHaskeller/MemoToFiles.hs b/MagicHaskeller/MemoToFiles.hs new file mode 100644 --- /dev/null +++ b/MagicHaskeller/MemoToFiles.hs @@ -0,0 +1,86 @@ +-- +-- (c) Susumu Katayama +-- +module MagicHaskeller.MemoToFiles where +import System.IO +import System.Directory(doesFileExist, createDirectoryIfMissing) +import MagicHaskeller.ShortString +import Data.ByteString.Char8 as C +import Data.ByteString.Lazy.Char8 as LC + +import Control.Monad.Search.Combinatorial +import MagicHaskeller.DebMT +import MagicHaskeller.Types + +import MagicHaskeller.PriorSubsts +import Data.Monoid +import Data.Ix + + + +-- copied from ProgGen.lhs. toMemoºï¤Ã¤Æ·¿ÊѤ¨¤¿¡¥¤Æ¤æ¡¼¤«¤½¤ì°ÊÁ°¤Ë¡¤»¶¤é¤Ð¤Ã¤Æ¤ëfreezePS¤òProgramGeneratorÊÕ¤ê¤Ë¤Þ¤È¤á¤¿¤¤µ¤¤â +freezePS :: Search m => Type -> PriorSubsts m (Bag e) -> m (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) $ unPS ps emptySubst (mxty+1) + in mergesortDepthWithBy (\(xs,k,i) (ys,_,_) -> (xs `mappend` ys, k, i)) (\(_,k,_) (_,l,_) -> k `compare` l) $ fps mxty ps + -- in toMemo $ mergesortDepthWithBy (\(xs,k,i) (ys,_,_) -> (xs `mappend` ys, k, i)) (\ (_,k,_) (_,l,_) -> normalize (apply k ty) `compare` normalize (apply l ty)) $ 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. + +-- ¤³¤ì¤Ã¤ÆProgGen¸ÂÄ꤫ +memoPSRTIO :: ShortString b => + MemoCond + -> MapType (Matrix (Possibility b)) + -> (Type -> PriorSubsts (RecompT IO) [b]) -- ^ This will be used instead if the entry is not found. + -> Type -> PriorSubsts (RecompT IO) [b] +memoPSRTIO policy mt f t = PS $ \subst mx -> + let (tn, decoder) = encode t mx + in (fmap (\ (exprs, sub, m) -> (exprs, retrieve decoder sub `plusSubst` subst, mx+m)) $ (memoRTIO policy mt (\u -> freezePS u (f u)) tn)) + + +memoRTIO :: ShortString b => + MemoCond -- IO¤òÊÖ¤¹¡¥¤Ä¤Þ¤ê¡¤¥á¥â¥ê¤ä¥Ï¡¼¥É¥Ç¥£¥¹¥¯¤Î¶õ¤­¤Ë¤è¤Ã¤Æ¤âÊѤ¨¤é¤ì¤ë¤è¤¦¤Ë¤¹¤ë¡¥ + -> MapType (Matrix b) -- ^ Memoization table for the Ram case. + -> (Type -> RecompT IO b) -- ^ This will be used instead if the entry is not found. + -> Type -> RecompT IO b +memoRTIO policy mt f t = RcT $ memoer policy mt (\ty -> unRcT (f ty)) t +memoer :: ShortString b => + MemoCond + -> MapType (Matrix b) + -> (Type -> Int -> IO [b]) + -> Type -> Int -> IO [b] +memoer policy mt f ty depth + = do memotype <- policy ty depth + case memotype of Recompute -> compute + Ram -> return $ unMx (lookupMT mt ty) !! depth + Disk fp -> let directory = fp++shows depth "/" -- care about Windows later.... + filepath = directory ++ show ty + in do createDirectoryIfMissing True directory + memoToFile readsBriefly showsBriefly filepath compute + where compute = f ty depth +data MemoType = Recompute -- ^ Recompute instead of memoizing. + | Ram -- ^ Use the memoization table based on lazy evaluation, like in older versions. + | Disk FilePath -- ^ Use the directory specified by @FilePath@ as the persistent memoization table. +type MemoCond = Type -> Int -> IO MemoType + + +-- | General-purposed memoizer (This could be put in a different module.) +memoToFile :: (C.ByteString -> Maybe (a,C.ByteString)) -> (a -> LC.ByteString -> LC.ByteString) + -> FilePath -- ^ where to memoize + -> IO a -- ^ invoked if there is no such file + -> IO a +memoToFile parser printer filepath compute + = let write = do result <- compute + LC.writeFile filepath (printer result LC.empty) + return result + in do there <- doesFileExist filepath + if there then do cs <- C.readFile filepath -- Read strictly, and close (not semi-close) it. System.IO.readFile cannot achieve this behavior. + case parser cs of Just (x,_) -> return x + _ -> do -- If the file is broken, just fix it. ¤Ç¤â狼¤¬½ñ¤­¹þ¤ßÃæ¤À¤Èº¤¤ë? + System.IO.hPutStrLn stderr ("File " ++ filepath ++ " was broken.") + write + else write diff --git a/MagicHaskeller/MyCheck.hs b/MagicHaskeller/MyCheck.hs --- a/MagicHaskeller/MyCheck.hs +++ b/MagicHaskeller/MyCheck.hs @@ -1,5 +1,5 @@ -- --- (c) Susumu Katayama 2009 +-- (c) Susumu Katayama -- {- rewrite of QuickCheck.Arbitrary in the form specialized for each type diff --git a/MagicHaskeller/MyDynamic.hs b/MagicHaskeller/MyDynamic.hs --- a/MagicHaskeller/MyDynamic.hs +++ b/MagicHaskeller/MyDynamic.hs @@ -1,5 +1,5 @@ -- --- (c) Susumu Katayama 2009 +-- (c) Susumu Katayama -- # ifdef REALDYNAMIC module MagicHaskeller.MyDynamic(module MagicHaskeller.PolyDynamic, dynamic, dynamicH) where @@ -8,32 +8,3 @@ 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 diff --git a/MagicHaskeller/Options.hs b/MagicHaskeller/Options.hs new file mode 100644 --- /dev/null +++ b/MagicHaskeller/Options.hs @@ -0,0 +1,136 @@ +module MagicHaskeller.Options where +import System.Random(mkStdGen, StdGen) +import MagicHaskeller.Execute(unsafeExecute) +import MagicHaskeller.MemoToFiles(MemoCond, MemoType(..)) +import MagicHaskeller.CoreLang +import MagicHaskeller.MyDynamic + + +-- | 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. + , memodepth :: Int -- ^ memoization depth. (Sub)expressions within this size are memoized, while greater expressions will be recomputed (to save the heap space). Only effective when using 'ProgGen' and unless using the 'everythingIO' family. + , memoCond :: MemoCond -- ^ This represents which memoization table to be used based on the query type and the search depth, when using the 'everythingIO' family. + , execute :: VarLib -> CoreExpr -> Dynamic -- timeout ¤Ï¤³¤ÎÃæ¤Ç¤ä¤ë¤Ù¤­¡¥IO Dynamic¤Î¾ì¹ç¤ËunsafePerformIO¤ò2²ó¤ä¤ë¤ÈÊѤʤ³¤È¤Ë¤Ê¤ê¤½¤¦¤Ê¤Î¤Ç¡¥ + , 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. + , forcibleTimeout :: Bool -- ^ If this option is @True@, 'System.Posix.Process.forkProcess' instead of 'Control.Concurrent.forkIO' is used for timeout. + -- The former is much heavier than the latter, but is more preemptive and thus is necessary for interrupting some infinite loops. + -- This record is ignored if FORCIBLETO is not defined. + , 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. + , tvndelay:: Int -- ^ Each time the type variable which appears in the return type of a function (e.g. @b@ in @foldr::(a->b->b)->b->[a]->b@) + -- is expanded to a function type, the search priority of the current computation is lowered by this number. + -- It's default value is 1, which means there is nothing special, and the priority for each expression corresponds + -- to the number of function applications in the expression. + -- + -- Example: when tvndelay = 1, + -- + -- The priority of + -- + -- > \xs -> foldr (\x y -> x+y) 0 xs + -- + -- is 5, + -- because there are five @$@'s in + -- + -- > \xs -> ((foldr $ (\x y -> ((+) $ x) $ y)) $ 0) xs + -- + -- + -- The priority of + -- + -- > \xs ys -> foldr (\x y zs -> x : y zs) (\ws->ws) xs ys + -- + -- is 7, + -- because there are seven @$@'s in + -- + -- > \xs ys -> (((foldr $ (\x y zs -> (((:) $ x) $ y) $ zs)) $ (\ws->ws)) $ xs) $ ys + -- + -- + -- Example: when tvndelay = 2, + -- + -- The priority of + -- + -- > \xs -> foldr (\x y -> x+y) 0 xs + -- + -- is 5, + -- because there are five @$@'s in + -- + -- > \xs -> ((foldr $ (\x y -> ((+) $ x) $ y)) $ 0) xs + -- + -- The priority of + -- + -- > \xs ys -> foldr (\x y zs -> x : y zs) (\ws->ws) xs ys + -- + -- is 8, + -- because there are eight @$@'s in + -- + -- > \xs ys -> (((foldr $ (\x y zs -> (((:) $ x) $ y) $ zs)) $ (\ws->ws)) $ xs) $$ ys + -- + -- where @$$@ denotes the function application caused by expanding a type variable into a function type. + , 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 +-- > , memodepth = 10 +-- > , memoCond = \ _type depth -> return $ if depth < 10 then Ram else Recompute +-- > , execute = unsafeExecute +-- > , timeout = Just 20000 +-- > , forcibleTimeout = False +-- > , guess = False +-- > , contain = True +-- > , constrL = False +-- > , tv1 = False +-- > , stdgen = mkStdGen 123456 +-- > , nrands = repeat 5 +-- > } + +options :: Opt a +options = Opt{ primopt = Nothing + , memodepth = 10 + , memoCond = \ _ty d -> return $ if d<10 then Ram else Recompute + , execute = unsafeExecute + , timeout = Just 20000 + , forcibleTimeout = False + , guess = False + , contain = True + , constrL = False + , tvndelay = 1 + , 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 +-} diff --git a/MagicHaskeller/PolyDynamic.hs b/MagicHaskeller/PolyDynamic.hs new file mode 100644 --- /dev/null +++ b/MagicHaskeller/PolyDynamic.hs @@ -0,0 +1,107 @@ +-- +-- (c) Susumu Katayama +-- +-- Dynamic with unsafe execution. + +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +module MagicHaskeller.PolyDynamic ( + Dynamic(..), + fromDyn, -- :: Type -> Dynamic -> a -> a + fromDynamic, -- :: Type -> Dynamic -> Maybe a + dynApply, + dynApp, + dynAppErr, + unsafeToDyn -- :: Type -> a -> Dynamic + , aLittleSafeFromDyn -- :: Type -> Dynamic -> a + , fromPD, dynamic,dynamicH + -- I (susumu) believe the above is enough, provided unsafeFromDyn does not invoke typeOf for type checking. (Otherwise there would be ambiguity error.) + ) where + + +import Data.Typeable +import Data.Maybe + +import GHC.Exts(unsafeCoerce#) + +import MagicHaskeller.Types +import MagicHaskeller.TyConLib +import Control.Monad + +import Language.Haskell.TH hiding (Type) + +import Debug.Trace + +import MagicHaskeller.ReadTypeRep(trToType) +import MagicHaskeller.ReadTHType(typeToTHType) + + +import MagicHaskeller.ReadTHType(thTypeToType) +import MagicHaskeller.MHTH +import Data.Typeable(typeOf) + + +infixl `dynApp` + +data Dynamic = Dynamic {dynType::Type, unsafeFromDyn::forall a. a, dynExp::Exp} +-- CoreExpr¤ÏPrimitive¤¬Dynamic¤ò»È¤Ã¤Æ¤¤¤ë¤Î¤Ç¡¤Exp¤ÎÂå¤ï¤ê¤Ë»È¤¦¤Èhiboot¤·¤Ê¤¤¤È¤¤¤±¤Ê¤¯¤Ê¤ë¡¥ + +unsafeToDyn :: TyConLib -> Type -> a -> Exp -> Dynamic +unsafeToDyn tcl tr a e = Dynamic tr (unsafeCoerce# a) e +-- unsafeToDyn tcl tr a e = Dynamic tr (unsafeCoerce# a) (SigE e (typeToTHType tcl tr)) -- ¤³¤Ã¤Á¤Ï¤³¤Ã¤Á¤ÇÊØÍø¤Ã¤Ý¤¤¤Î¤À¤¬¡¥ + +aLittleSafeFromDyn :: Type -> Dynamic -> a +aLittleSafeFromDyn tr (Dynamic t o _) + = case mgu tr t of + Just _ -> o + Nothing -> error ("aLittleSafeFromDyn: type mismatch between "++show tr++" and "++show t) +fromDyn :: Typeable a => TyConLib -> Dynamic -> a -> a +fromDyn tcl (Dynamic t o _) dflt + = case mgu (trToType tcl (typeOf dflt)) t of + Just _ -> o + Nothing -> dflt +fromDynamic :: MonadPlus m => Type -> Dynamic -> m a +fromDynamic tr (Dynamic t o _) = mgu tr t >> return o + +instance Show Dynamic where + showsPrec _ (Dynamic t _ e) = ("':) + +-- (f::(a->b)) `dynApply` (x::a) = (f a)::b +dynApply :: Dynamic -> Dynamic -> Maybe Dynamic +dynApply (Dynamic t1 f e1) (Dynamic t2 x e2) = + case mguFunAp t1 t2 of + Just t3 -> -- trace ("dynApply t1 = "++ show t1++", and t2 = "++show t2++", and t3 = "++show t3) $ + Just (Dynamic t3 ((unsafeCoerce# f) x) (AppE e1 e2)) + Nothing -> Nothing + +dynApp :: Dynamic -> Dynamic -> Dynamic +dynApp = dynAppErr "" +dynAppErr :: String ->Dynamic -> Dynamic -> Dynamic +dynAppErr s f x = case dynApply f x of + Just r -> r + Nothing -> error ("Type error in dynamic application.\n" ++ + "Can't apply function " ++ show f ++ + " to argument " ++ show x ++ "\n" ++ s) + +fromPD = id + + +-- °Ê²¼¤ÏMyDynamic¤«¤é¤È¤Ã¤Æ¤­¤¿¤â¤Î¤Ç¡¤PolyDynamic¤Ë¤¢¤ë¤Î¤ÈÁ´¤¯Æ±¤¸¡¥ +{- +$(dynamic [|tcl|] [| (,) :: forall a b. a->b->(a,b) |]) +¤Î¤è¤¦¤Ë¤Ç¤­¤ë¤è¤¦¤Ë¤¹¤ë¡¥CLEAN¤Îdynamic¤ß¤¿¤¤¤Ê´¶¤¸¡¥ +-} +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' +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) |] -- ¤³¤Ã¤Á¤Ï¤³¤Ã¤Á¤ÇÊØÍø¤Ã¤Ý¤¤¤Î¤À¤¬¡¥ +px eqtcl e ty = [| unsafeToDyn $eqtcl (thTypeToType $eqtcl $(typeToExpType ty)) $(return se) $(expToExpExp e) |] + where se = SigE e ty diff --git a/MagicHaskeller/PriorSubsts.lhs b/MagicHaskeller/PriorSubsts.lhs --- a/MagicHaskeller/PriorSubsts.lhs +++ b/MagicHaskeller/PriorSubsts.lhs @@ -1,5 +1,5 @@ -- --- (c) Susumu Katayama 2009 +-- (c) Susumu Katayama -- \begin{code} {-# OPTIONS -cpp -fglasgow-exts #-} @@ -7,6 +7,7 @@ import Control.Monad import Control.Monad.Search.Combinatorial +-- import Control.Monad.Search.BalancedMerge import MagicHaskeller.Types import Data.Array.IArray import Data.Monoid @@ -17,6 +18,9 @@ import Debug.Trace +-- sumPS :: [PriorSubsts Matrix a] -> PriorSubsts Matrix a +-- sumPS pss = PS $ \s i -> sumMx [ f s i | PS f <- pss] + 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) @@ -36,6 +40,7 @@ -- 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) +ndelayPS n (PS f) = PS g where g s i = ndelay n (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 #-} @@ -96,6 +101,10 @@ mguPS, matchPS :: MonadPlus m => Type -> Type -> PriorSubsts m () mguPS t0 t1 = do subst <- mgu t0 t1 updatePS subst +-- ¤Æ¤æ¡¼¤«mgtPS¤òmguPS¤ÎÄêµÁ¤Ë¤·¤Æ¤â¤¤¤¤¤¯¤é¤¤¡¥ +mgtPS :: MonadPlus m => Type -> Type -> PriorSubsts m Type +mgtPS t1 t2 = do mguPS t1 t2 + applyPS t1 {-# SPECIALIZE varBindPS :: TyVar -> Type -> PriorSubsts [] () #-} varBindPS :: MonadPlus m => TyVar -> Type -> PriorSubsts m () varBindPS v t = do subst <- varBind v t diff --git a/MagicHaskeller/ProgGen.lhs b/MagicHaskeller/ProgGen.lhs --- a/MagicHaskeller/ProgGen.lhs +++ b/MagicHaskeller/ProgGen.lhs @@ -1,8 +1,8 @@ -- --- (c) Susumu Katayama 2009 +-- (c) Susumu Katayama -- \begin{code} -{-# OPTIONS -cpp -fglasgow-exts #-} +{-# OPTIONS -cpp #-} module MagicHaskeller.ProgGen(ProgGen(PG)) where import MagicHaskeller.Types @@ -16,6 +16,7 @@ import Data.Ix(inRange) import MagicHaskeller.ProgramGenerator +import MagicHaskeller.Options(Opt(..)) import MagicHaskeller.Classify import System.Random(mkStdGen) @@ -32,6 +33,7 @@ import Data.Monoid +import MagicHaskeller.MemoToFiles hiding (freezePS,fps) -- x #define DESTRUCTIVE traceTy _ = id @@ -73,27 +75,27 @@ lookupMT mt fty lookupFunsPoly :: (Search m, Expression e) => Generator m e -> Generator m e -lookupFunsPoly behalf memodeb@(memodepth,(mt,_,_)) avail reqret +lookupFunsPoly behalf memodeb@(mt,_,cmn) avail reqret = PS (\subst mx -> let (tn, decoder) = encode (popArgs avail reqret) mx - in ifDepth (<= memodepth) + in ifDepth (<= memodepth (opt cmn)) (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) + unifyingPrograms ty px@(PG x) = fmap (toAnnExpr $ reducer px) $ catBags $ fmap (\ (es,_,_) -> es) $ unifyingPossibilities ty x + unifyingProgramsIO ty px@(PG x) = fmap (toAnnExpr $ reducer px) $ catBags $ fmap (\ (es,_,_) -> es) $ unifyingPossibilitiesIO ty x extractCommon (PG (_,_,cmn)) = cmn -unifyingPossibilities :: Search m => Type -> (Int, MemoDeb CoreExpr) -> m ([CoreExpr],Subst,Int) +unifyingPossibilities :: Search m => Type -> MemoDeb CoreExpr -> m ([CoreExpr],Subst,Int) unifyingPossibilities ty memodeb = unPS (mguProgs memodeb [] ty) emptySubst 0 +unifyingPossibilitiesIO :: Type -> MemoDeb CoreExpr -> RecompT IO ([CoreExpr],Subst,Int) +unifyingPossibilitiesIO ty memodeb = unPS (mguProgsIO memodeb [] ty) emptySubst 0 + type MemoDeb a = (MemoTrie a, ([Prim],[Prim]), Common) --- 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 @@ -102,10 +104,10 @@ -- 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])) + listrie = mkMT (tcl cmn) (\ty -> freezePS ty (let (avail,t) = splitArgs ty in mguFuns (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 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])) + memoTrie = mkMT (tcl cmn) (\ty -> freezePS ty (let (avail,t) = splitArgs ty in mguFuns memoDeb avail t :: PriorSubsts BF [CoreExpr])) #endif -- We need to specialize the type (to BF) in order to avoid ambiguity. in memoDeb @@ -123,13 +125,20 @@ 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] +type Generator m e = MemoDeb e -> [Type] -> Type -> PriorSubsts m [e] +mguProgramsIO, mguProgsIO :: Generator (RecompT IO) CoreExpr +mguProgramsIO memodeb = applyDo (mguProgsIO memodeb) +mguProgsIO memodeb@(mt,_,cmn) = wind (>>= (return . fmap Lambda)) (\avail reqret -> reorganize (\newavail -> (\memodeb avail reqr -> memoPSRTIO (memoCond $ opt cmn) -- (\_ty _dep -> return (Disk "/tmp/memo/mlist") {- ¤È¤ê¤¢¤¨¤º¤³¤ì¤Ç¥Æ¥¹¥È -}) + mt + (\ty -> let (av,rr) = splitArgs ty in generateFuns mguProgramsIO memodeb av rr) + (popArgs avail reqr)) memodeb newavail reqret) avail) + + + mguPrograms, mguProgs, mguFuns :: Search m => Generator m CoreExpr mguPrograms memodeb = applyDo (mguProgs memodeb) @@ -147,7 +156,7 @@ generateFuns :: (Search m) => Generator m CoreExpr -- ^ recursive call -> Generator m CoreExpr -generateFuns rec memodeb@(_, md@(_, (primgen,primmono),cmn)) avail reqret +generateFuns rec memodeb@(_, (primgen,primmono),cmn) avail reqret = let behalf = rec memodeb avail lltbehalf = lookupListrie (opt cmn) rec memodeb avail -- heuristic filtration lenavails = length avail @@ -155,10 +164,10 @@ 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 ) + in fromAssumptions (PG memodeb) lenavails behalf mguPS reqret avail `mplus` msum (map (rg (PG memodeb) lenavails fe lltbehalf behalf reqret) primgen ++ map (retPrimMono (PG memodeb) lenavails lltbehalf behalf mguPS reqret) primmono ) #ifdef DESTRUCTIVE -lookupListrie rec (memodepth, (trie, (primgen,_),tcl,rtrie)) avail t = rec (memodepth,((snd trie, snd trie), (primgen,[]), tcl, rtrie)) avail t +lookupListrie rec (trie, (primgen,_),tcl,rtrie) avail t = rec ((snd trie, snd trie), (primgen,[]), tcl, rtrie) avail t filtExprs = filterExprs #else lookupListrie opt rec memodeb avail t diff --git a/MagicHaskeller/ProgGenSF.lhs b/MagicHaskeller/ProgGenSF.lhs --- a/MagicHaskeller/ProgGenSF.lhs +++ b/MagicHaskeller/ProgGenSF.lhs @@ -1,9 +1,9 @@ -- --- (c) Susumu Katayama 2009 +-- (c) Susumu Katayama -- \begin{code} -{-# OPTIONS -fglasgow-exts -cpp #-} +{-# OPTIONS -cpp -XRelaxedPolyRec #-} module MagicHaskeller.ProgGenSF(ProgGenSF, PGSF) where import MagicHaskeller.Types import MagicHaskeller.TyConLib @@ -21,6 +21,7 @@ import MagicHaskeller.Instantiate import MagicHaskeller.ProgramGenerator +import MagicHaskeller.Options(Opt(..)) import MagicHaskeller.Expression @@ -63,8 +64,8 @@ type MemoTrie e = (TypeTrie e, ExpTrie e) -lmt :: Expression e => (Int, MemoDeb e) -> Type -> Matrix e -lmt (_,memoDeb@((_,mt),_,cmn)) fty = traceExpTy fty $ +lmt :: Expression e => MemoDeb e -> Type -> Matrix e +lmt memoDeb@((_,mt),_,cmn) fty = traceExpTy fty $ lookupMT mt fty -- ¤³¤Ã¤Á¤À¤Èlookup -- filtBF cmn fty $ matchFunctions (maxBound', memoDeb) fty -- ¤³¤Ã¤Á¤À¤Èrecompute @@ -91,25 +92,20 @@ 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) + matchingPrograms ty (PGSF x) = fromMx $ matchProgs x ty + unifyingPrograms ty px@(PGSF x) = catBags $ fromDB $ fmap (\ (es,_,_) -> map (toAnnExpr $ reducer px) es) $ unifyingPossibilities ty 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 :: Expression e => MemoDeb e -> Type -> Matrix AnnExpr +matchProgs memodeb ty = fmap (toAnnExprWindWind (reducer $ PGSF 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 = +lookupFuns :: (Expression e, Ord e) => MemoDeb e -> [Type] -> Type -> BF e +lookupFuns memodeb@((_,mt),_,tcl,rtrie) avail reqret = {- #ifdef CLASSIFY fmap fromAnnExpr $ toRc $ filterDM tcl rtrie ty $ fromRc $ fmap (toAnnExprWind ty) $ @@ -120,26 +116,21 @@ where ty = popArgs avail reqret -} -specializedPossibleTypes :: Expression e => Type -> (Int, MemoDeb e) -> Recomp Type +specializedPossibleTypes :: Expression e => Type -> 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) + typeTrie = mkMTty (tcl cmn) (\ty -> freezePS ty (specTypes memoDeb ty)) + expTrie = mkMTexp (tcl cmn) (\ty -> filtBF cmn ty $ matchFunctions memoDeb ty) in memoDeb where qtlopt = splitPrims txsopt qtl = splitPrims txs @@ -184,60 +175,45 @@ -- ¤À¤«¤é¤³¤½¡¤runAnotherPSŪ¤ËemptySubst¤ËÂФ·¤Æ¼Â¹Ô¤·¤¿Êý¤¬¸úΨŪ¤Ê¤Ï¤º¡© ¤Ç¤â¡¤Substitution¤Ã¤Æ¤½¤ó¤Ê¤Ë¤Ç¤«¤¯¤Ê¤é¤Ê¤«¤Ã¤¿¤Î¤Ç¤Ï¡©FiniteMap¤Ç¤âassoc list¤Ç¤âÊѤï¤é¤Ê¤«¤Ã¤¿µ¤¤¬¡¥ -specializedTypes :: (Search m, Expression e) => (Int, MemoDeb e) -> [Type] -> Type -> PriorSubsts m ([Type],Type) +specializedTypes :: (Search m, Expression e) => 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, specCases, specCases' :: (Search m, Expression e) => 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 = wind_ (\avail reqret -> reorganize_ (\newavail -> uniExprs_ 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 +specCases memodeb avail reqret = reorganize_ (\newavail -> uniExprs_ memodeb newavail reqret) avail -} -uniExprs_ :: (Search m, Expression e) => (Int, MemoDeb e) -> [Type] -> Type -> PriorSubsts m () +uniExprs_ :: (Search m, Expression e) => 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 +lookupUniExprs :: Expression e => MemoDeb e -> [Type] -> Type -> Int -> PriorSubsts [] (ExpTip e) +lookupUniExprs memodeb@((mt,_),_,_) avail t depth = lookupNormalized (\tn -> unMx (lmtty mt tn) !! depth) avail t -makeUniExprs :: Expression e => (Int, MemoDeb e) -> [Type] -> Type -> Int -> PriorSubsts [] Type +makeUniExprs :: Expression e => 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 +specTypes :: (Search m, Expression e) => 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Àè¤Ç´û¤Ë¤ä¤é¤ì¤Æ¤¤¤ë¤Î¤ÇÉÔÍ× @@ -255,7 +231,7 @@ 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 +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 @@ -276,7 +252,7 @@ do tvid <- reserveTVars numtvs -- ¤³¤Î¡ÊºÇ½é¤Î¡ËID¤½¤Î¤â¤Î¡Ê¤Ä¤Þ¤êÊÖ¤êÃͤÎtvID¡Ë¤Ï¤¹¤°¤Ë»È¤ï¤ì¤Ê¤¯¤Ê¤ë -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTV¤Èapply¤Ïhylo-fusion¤Ç¤­¤ë¤Ï¤º¤À¤¬¡¤¾¡¼ê¤Ë¤µ¤ì¤ë¡© -- -- unitSubst¤òinline¤Ë¤·¤Ê¤¤¤ÈÂÌÌܤ« - mkSubsts tvid reqret + mkSubsts (tvndelay $ opt cmn) tvid reqret fas (mapTV (tvid+) ty) gentvar <- applyPS (TV tvid) @@ -284,7 +260,7 @@ guard (orderedAndUsedArgs gentvar) fas gentvar -type Generator m e = (Int,MemoDeb e) -> [Type] -> Type -> PriorSubsts m [e] +type Generator m e = MemoDeb e -> [Type] -> Type -> PriorSubsts m [e] unifyableExprs :: Expression e => Generator DBound e unifyableExprs memodeb avails ty = convertPS fromRc $ unifyableExprs' memodeb avails ty @@ -292,8 +268,8 @@ 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 +lookupTypeTrie :: Expression e => MemoDeb e -> Type -> Recomp ([e], Subst, Int) +lookupTypeTrie ((mt,_), _, _) t = Rc $ \depth -> let Mx xss = lmtty mt t in [ (yss!!depth, s, i) | (Mx yss, s, i) <- xss !! depth ] @@ -313,17 +289,17 @@ tokoro10fst = mergesortWithBy const (\ (k,_,_) (l,_,_) -> k `compare` l) -- entry for memoization -matchFunctions :: Expression e => (Int, MemoDeb e) -> Type -> DBound e +matchFunctions :: Expression e => 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 :: Expression e => 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 +matchFuns' rec md@(_, (_,(primgen,primmono)),cmn) avail reqret + = let behalf = rec md avail + lltbehalf = lookupListrie lenavails rec md avail -- heuristic filtration lenavails = length avail -- fe :: Type -> Type -> [CoreExpr] -> [CoreExpr] -- ^ heuristic filtration fe = filtExprs (guess $ opt cmn) @@ -333,8 +309,8 @@ 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 +lookupListrie lenavails rec memodeb@(_,_,cmn) avail t + | constrL opts = matchAssumptions (PGSF memodeb) lenavails t avail | guess opts = do args <- rec memodeb avail t let args' = filter (not.isClosed.toCE) args diff --git a/MagicHaskeller/ProgGenXF.lhs b/MagicHaskeller/ProgGenXF.lhs --- a/MagicHaskeller/ProgGenXF.lhs +++ b/MagicHaskeller/ProgGenXF.lhs @@ -1,9 +1,9 @@ -- --- (c) Susumu Katayama 2009 +-- (c) Susumu Katayama -- \begin{code} -{-# OPTIONS -fglasgow-exts -cpp #-} +{-# OPTIONS -cpp -XRelaxedPolyRec #-} module MagicHaskeller.ProgGenXF(ProgGenXF) where import MagicHaskeller.Types import MagicHaskeller.TyConLib @@ -20,6 +20,7 @@ import MagicHaskeller.Instantiate import MagicHaskeller.ProgramGenerator +import MagicHaskeller.Options(Opt(..)) import MagicHaskeller.Expression @@ -63,11 +64,11 @@ type MemoTrie = (TypeTrie, ExpTrie) -lmt :: (Int, MemoDeb) -> Type -> Matrix AnnExpr -lmt (_,memoDeb@((_,mt),_,cmn)) fty = +lmt :: 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 +-- filtBF cmn fty $ matchFunctions 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 @@ -86,8 +87,8 @@ 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) + matchingPrograms ty (PGXF x) = fromMx $ matchProgs x ty + unifyingPrograms ty px@(PGXF x) = fromRc $ catBags $ fmap (\ (es,_,_) -> map (toAnnExpr $ reducer px) es) $ unifyingPossibilities ty x extractCommon (PGXF (_,_,cmn)) = cmn unifyingPossibilities ty memodeb = unPS (unifyableExprs memodeb [] ty) emptySubst 0 @@ -97,8 +98,8 @@ -- ¤Æ¤æ¡¼¤«¡¤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 +matchProgs :: MemoDeb -> Type -> Matrix AnnExpr +matchProgs memodeb ty = fmap (toAnnExprWindWind (reducer $ PGXF 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¤Î¤È¤³¤í¤òÊѤ¨¤ë¤Ù¤·¡¥ @@ -116,27 +117,22 @@ where ty = popArgs avail reqret -} -specializedPossibleTypes :: Type -> (Int, MemoDeb) -> Recomp Type +specializedPossibleTypes :: Type -> 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)) + typeTrie = mkMTty (tcl cmn) (\ty -> freezePS ty (specTypes memoDeb ty)) expTrie = mkMTexp (tcl cmn) (\ty -> -- fmap (aeToME (tcl cmn) (rt cmn) ty) $ - filtBF cmn ty $ toMx $ matchFunctions (maxBound', memoDeb) ty) + filtBF cmn ty $ toMx $ matchFunctions memoDeb ty) in memoDeb where qtlopt = splitPrims txsopt qtl = splitPrims txs @@ -172,64 +168,47 @@ 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 :: (Search m) => 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, specCases, specCases' :: (Search m) => 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 = wind_ (\avail reqret -> reorganize_ (\newavail -> uniExprs_ 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 +specCases memodeb avail reqret = reorganize_ (\newavail -> uniExprs_ memodeb newavail reqret) avail -} -uniExprs_ :: (Search m) => (Int, MemoDeb) -> [Type] -> Type -> PriorSubsts m () +uniExprs_ :: (Search m) => 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 +lookupUniExprs :: MemoDeb -> [Type] -> Type -> Int -> PriorSubsts [] (Matrix AnnExpr) +lookupUniExprs ((mt,_),_,_) avail t depth = lookupNormalized (\tn -> unMx (lmtty mt tn) !! depth) avail t -makeUniExprs :: (Int, MemoDeb) -> [Type] -> Type -> Int -> PriorSubsts [] Type +makeUniExprs :: 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 +specTypes :: (Search m) => 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Àè¤Ç´û¤Ë¤ä¤é¤ì¤Æ¤¤¤ë¤Î¤ÇÉÔÍ× @@ -247,7 +226,7 @@ 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 +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 @@ -268,7 +247,7 @@ do tvid <- reserveTVars numtvs -- ¤³¤Î¡ÊºÇ½é¤Î¡ËID¤½¤Î¤â¤Î¡Ê¤Ä¤Þ¤êÊÖ¤êÃͤÎtvID¡Ë¤Ï¤¹¤°¤Ë»È¤ï¤ì¤Ê¤¯¤Ê¤ë -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTV¤Èapply¤Ïhylo-fusion¤Ç¤­¤ë¤Ï¤º¤À¤¬¡¤¾¡¼ê¤Ë¤µ¤ì¤ë¡© -- -- unitSubst¤òinline¤Ë¤·¤Ê¤¤¤ÈÂÌÌܤ« - mkSubsts tvid reqret + mkSubsts (tvndelay $ opt cmn) tvid reqret fas (mapTV (tvid+) ty) gentvar <- applyPS (TV tvid) @@ -276,7 +255,7 @@ guard (orderedAndUsedArgs gentvar) fas gentvar -type Generator m e = (Int,MemoDeb) -> [Type] -> Type -> PriorSubsts m [e] +type Generator m e = MemoDeb -> [Type] -> Type -> PriorSubsts m [e] unifyableExprs :: Generator Recomp AnnExpr unifyableExprs memodeb avails ty = unifyableExprs' memodeb avails ty @@ -284,8 +263,8 @@ unifyableExprs' memodeb = applyDo (wind (fmap (map (mapCE Lambda))) (lookupNormalized (lookupTypeTrie memodeb))) -lookupTypeTrie :: (Int, MemoDeb) -> Type -> Recomp ([AnnExpr], Subst, Int) -lookupTypeTrie memodeb@(_, ((mt,_), _, _)) t +lookupTypeTrie :: 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 ] @@ -305,18 +284,18 @@ tokoro10fst = mergesortWithBy const (\ (k,_,_) (l,_,_) -> k `compare` l) -- entry for memoization -matchFunctions :: (Int, MemoDeb) -> Type -> Recomp AnnExpr +matchFunctions :: 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 -> [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 +matchFuns' rec md@(_, (_,(primgen,primmono)),cmn) avail reqret + = let behalf = rec md avail + lltbehalf = lookupListrie lenavails rec md avail -- heuristic filtration lenavails = length avail -- fe :: Type -> Type -> [CoreExpr] -> [CoreExpr] -- ^ heuristic filtration fe = filtExprs (guess $ opt cmn) @@ -327,8 +306,8 @@ 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 +lookupListrie lenavails rec memodeb@(_,_,cmn) avail t + | constrL opts = matchAssumptions (PGXF memodeb) lenavails t avail | guess opts = do args <- rec memodeb avail t let args' = filter (not.isClosed.toCE) args diff --git a/MagicHaskeller/ProgramGenerator.lhs b/MagicHaskeller/ProgramGenerator.lhs --- a/MagicHaskeller/ProgramGenerator.lhs +++ b/MagicHaskeller/ProgramGenerator.lhs @@ -1,22 +1,7 @@ -- --- (c) Susumu Katayama 2009 +-- (c) Susumu Katayama -- -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 #-} @@ -31,7 +16,6 @@ import Data.List(partition, sortBy) import Data.Ix(inRange) -import System.Random(mkStdGen) import MagicHaskeller.Instantiate import MagicHaskeller.Expression @@ -46,8 +30,7 @@ import MagicHaskeller.MyDynamic -import MagicHaskeller.Execute(unsafeExecute) - +import MagicHaskeller.Options -- replacement of LISTENER. Now replaced further with |guess| -- listen = False @@ -63,8 +46,13 @@ 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, unifyingPrograms :: Search m => Type -> a -> m AnnExpr matchingPrograms ty memodeb = unifyingPrograms (quantify ty) memodeb + -- | Use memoization requiring IO + matchingProgramsIO, unifyingProgramsIO :: Type -> a -> RecompT IO AnnExpr -- Should I define SearchT? + matchingProgramsIO ty memodeb = unifyingProgramsIO (quantify ty) memodeb + unifyingProgramsIO = unifyingPrograms + -- Another option might be to create @newtype MemoToFile = NT (RecompT (StateT Params IO))@, and define @instance Search MemoToFile@. One drawback of this approach is that @Params@ is separated from @Options@. extractCommon :: a -> Common extractTCL :: ProgramGenerator a => a -> TyConLib extractTCL = tcl . extractCommon @@ -77,82 +65,17 @@ 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) +-- avail$B$K$7$m(BType$B$K$7$m(Bapply$B$5$l$F$$$k!%(B +-- $B$@$+$i$3$=!$(BrunAnotherPS$BE*$K(BemptySubst$B$KBP$7$F ([Type] -> Type -> PriorSubsts m a) -> [Type] -> Type -> PriorSubsts m a applyDo fun avail ty = do subst <- getSubst fun (map (apply subst) avail) (apply subst ty) @@ -248,7 +171,7 @@ 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$:$@$,!$>!!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$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!$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 @@ -470,17 +358,17 @@ isUsed _ _ = False -mkSubsts :: Search m => Int -> Type -> PriorSubsts m Int -mkSubsts tvid reqret = base `mplus` delayPS recurse +mkSubsts :: Search m => Int -> Int -> Type -> PriorSubsts m Int +mkSubsts n tvid reqret = base `mplus` ndelayPS n 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) + arity <- mkSubsts n tvid (TV v :-> reqret) return (arity+1) -mkSubst :: Search m => Int -> Type -> PriorSubsts m Int -mkSubst tvid reqret = base `mplus` delayPS first +mkSubst :: Search m => Int -> Int -> Type -> PriorSubsts m Int +mkSubst n tvid reqret = base `mplus` ndelayPS n 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 diff --git a/MagicHaskeller/ReadDynamic.hs b/MagicHaskeller/ReadDynamic.hs --- a/MagicHaskeller/ReadDynamic.hs +++ b/MagicHaskeller/ReadDynamic.hs @@ -1,5 +1,5 @@ -- --- (c) Susumu Katayama 2009 +-- (c) Susumu Katayama -- -- -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 diff --git a/MagicHaskeller/ReadTHType.lhs b/MagicHaskeller/ReadTHType.lhs --- a/MagicHaskeller/ReadTHType.lhs +++ b/MagicHaskeller/ReadTHType.lhs @@ -1,10 +1,10 @@ -- --- (c) Susumu Katayama 2009 +-- (c) Susumu Katayama -- \begin{code} {-# OPTIONS -fglasgow-exts -cpp #-} -module MagicHaskeller.ReadTHType(thTypeToType, typeToTHType, showTypeName) where +module MagicHaskeller.ReadTHType(thTypeToType, typeToTHType, showTypeName, plainTV, unPlainTV) where import MagicHaskeller.Types as Types import MagicHaskeller.TyConLib @@ -57,16 +57,26 @@ -} typeToTHType :: TyConLib -> Types.Type -> TH.Type typeToTHType tcl ty = (case tyvars ty of [] -> id - tvs -> TH.ForallT (map tvToName $ nub tvs) []) + tvs -> TH.ForallT (map (plainTV . tvToName) $ nub tvs) []) (typeToTHType' tcl 0 ty) -typeToTHType' (_,ar) k (TC tc) | tc >= 0 = TH.ConT (TH.mkName name) +typeToTHType' (_,ar) k (TC tc) | tc >= 0 = if name == "[]" then ListT else 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') +-- tvToName = TH.mkName . return . chr . (+ ord 'a') + +-- Maybe this should be dealt with by the version number of template-haskell, but how can I tell the number in the source code? +#if __GLASGOW_HASKELL__<=610 +plainTV = id +unPlainTV = id +#else +plainTV = PlainTV +unPlainTV (PlainTV v) = v +#endif +tvToName n = TH.mkName ('t':show n) -- secionedArrow = TH.ConT ''(->) -- ‘½•ª‚±‚Á‚¿‚Å‚àOK sectionedArrow = TH.ConT (mkName "GHC.Prim.(->)") diff --git a/MagicHaskeller/ReadTypeRep.hs b/MagicHaskeller/ReadTypeRep.hs --- a/MagicHaskeller/ReadTypeRep.hs +++ b/MagicHaskeller/ReadTypeRep.hs @@ -1,5 +1,5 @@ -- --- (c) Susumu Katayama 2009 +-- (c) Susumu Katayama -- module MagicHaskeller.ReadTypeRep where import Data.Typeable diff --git a/MagicHaskeller/RunAnalytical.hs b/MagicHaskeller/RunAnalytical.hs new file mode 100644 --- /dev/null +++ b/MagicHaskeller/RunAnalytical.hs @@ -0,0 +1,171 @@ +-- +-- (C) Susumu Katayama +-- + +module MagicHaskeller.RunAnalytical( + -- | This module provides with analytical generate-and-test synthesis, i.e. synthesis by filtration of analytically generated (many) expressions. + -- Actions whose name ends with F use random testing filter (like 'MagicHaskeller.filterThenF') in order to reduce the number of expressions. + + -- ** Re-exported modules + module MagicHaskeller, module MagicHaskeller.ExecuteAPI610, module MagicHaskeller.Analytical, + -- ** Synthesizers which can be used with any types. + -- | 'filterGet1' and its friends can be used to synthesize one expression satisfying the given condition. For example, + -- + -- >>> session <- prepareAPI ["MagicHaskeller"] + -- >>> filterGet1_ session $(c [d| f [] = 0; f [a] = 1; f [a,b] = 2 |]) (\f -> f "foobar" == 6) + -- > \a -> let fa (b@([])) = 0 + -- > fa (b@(_ : d)) = succ (fa d) + -- > in fa a + filterGet1_, filterGet1, filterGet1BK, + -- | Unlike 'filterGet1' and its friends, the following three functions do not print anything but only return results silently. + getFilt, getFiltF, getAll, + -- ** Synthesizers which are easier to use that can be used only with types appearing 'MagicHaskeller.CoreLang.defaultPrimitives' + -- *** All in one actions + quickStart, quickStartF, + -- *** counterparts to 'filterGet1_', 'filterGet1', and 'filterGet1BK' + filterGetOne_, filterGetOne, filterGetOneBK, + -- *** counterparts to 'getFilt', 'getFiltF', and 'getAll' + synthFilt, synthFiltF, synthAll, + -- *** counterpart to 'noBK' + noBKQ + ) where +import MagicHaskeller +import MagicHaskeller.ExecuteAPI610 -- use ExecuteAPI for GHC 6.8.* and below +import MagicHaskeller.Analytical +import Language.Haskell.TH +import HscTypes(HscEnv) +import MagicHaskeller.Classification(Filtrable) +import System.IO.Unsafe +import MagicHaskeller.GetTime +import System.IO + +filterGet1_ :: (Typeable a) => + HscEnv -- ^ session in which synthesized expressions are run + -> SplicedPrims -- ^ target I/O pairs + -> (a -> Bool) -- ^ test function + -> IO () +filterGet1_ s t p = filterGet1 s t p >> return () +filterGet1 :: (Typeable a) => + HscEnv -- ^ session in which synthesized expressions are run + -> SplicedPrims -- ^ target I/O pairs + -> (a -> Bool) -- ^ test function + -> IO (Every a) +filterGet1 session tgt = filterGet1BK session tgt noBK +filterGet1BK :: (Typeable a) => + HscEnv -- ^ session in which synthesized expressions are run + -> SplicedPrims -- ^ target I/O pairs + -> SplicedPrims -- ^ I/O pairs for background knowledge functions + -> (a -> Bool) -- ^ test function + -> IO (Every a) +filterGet1BK session tgt bk predicate = do tss <- getFilt session tgt bk predicate + putStrLn $ pprint $ fst $ head $ concat tss + return tss + +getFilt :: (Typeable a) => + HscEnv -- ^ session in which synthesized expressions are run + -> SplicedPrims -- ^ target I/O pairs + -> SplicedPrims -- ^ I/O pairs for background knowledge functions + -> (a -> Bool) -- ^ test function + -> IO (Every a) +getFilt session tgt bk pred = filterThen pred =<< getAll session tgt bk +getFiltF :: (Filtrable a, Typeable a) => + HscEnv -- ^ session in which synthesized expressions are run + -> SplicedPrims -- ^ target I/O pairs + -> SplicedPrims -- ^ I/O pairs for background knowledge functions + -> (a -> Bool) -- ^ test function + -> IO (Every a) +getFiltF session tgt bk pred = filterThenF pred =<< getAll session tgt bk +getAll :: (Typeable a) => + HscEnv -- ^ session in which synthesized expressions are run + -> SplicedPrims -- ^ target I/O pairs + -> SplicedPrims -- ^ I/O pairs for background knowledge functions + -> IO (Every a) +getAll session tgt bk = thExpssToEvery session (getManyTyped tgt bk) + + +-- Functions appearing from here are easier to use, but they work only for limited types, included in 'defaultPrimitives'. + +noBKQ :: Q [Dec] +noBKQ = return [] + +-- main = quickStart (return [rev]) noBKQ (\f -> f "abcdef" == "fedcba") +{- +main = quickStart [d| f :: Int->Int; f 0 = 0; f 1 = 3; f 2 = 6 |] noBKQ (\f -> f (10::Int) == (30::Int)) +-} +{- +main = quickStart [d| f::[a] -> Int; f [] = 0; f [a] = 3; f [a,b] = 6 |] noBKQ (\f -> f "hogehoge" == (24::Int)) +-} +{- +main = quickStart [d| f::[a] -> a; f [a] = a; f [a,b] = b; f [a,b,c] = c |] noBKQ (\f -> f "hogehoge" == 'e') +-} +-- | Example of 'quickStart' +-- +-- >>> quickStart [d| f [] = 0; f [a] = 1 |] noBKQ (\f -> f "12345" == 5) +-- > \a -> let fa (b@([])) = 0 +-- > fa (b@(c : d)) = succ (fa d) +-- > in fa a :: forall t2 . [t2] -> Int +-- > ^CInterrupted. +quickStart :: (Typeable a) => + Q [Dec] -- ^ target I/O pairs + -> Q [Dec] -- ^ I/O pairs for background knowledge functions + -> (a -> Bool) -- ^ test function + -> IO () +quickStart iops bk pred = do session <- prepareAPI ["MagicHaskeller"] + tss <- synthFilt session iops bk pred + pprs tss +quickStartF :: (Filtrable a, Typeable a) => + Q [Dec] -- ^ target I/O pairs + -> Q [Dec] -- ^ I/O pairs for background knowledge functions + -> (a -> Bool) -- ^ test function + -> IO () +quickStartF iops bk pred = do session <- prepareAPI ["MagicHaskeller"] + tss <- synthFiltF session iops bk pred + pprs tss + +batchExample = do session <- prepareAPI ["MagicHaskeller"] + let f = filterGetOne_ session + batchWrite "example.dat" [ f [d| reverse [] = []; reverse [a] = [a]; reverse [a,b] = [b,a]; reverse [a,b,c] = [c,b,a] |] (\r -> r "abcd" == "dcba") + , f [d| switch [] = []; switch [a] = [a]; switch [a,b] = [b,a]; switch [a,b,c] = [c,b,a]; switch [a,b,c,d] = [d,b,c,a]; |] (\s -> s "abcde" == "ebcda") + ] +filterGetOne_ s t p = filterGetOne s t p >> return () +filterGetOne :: (Typeable a) => + HscEnv -- ^ session in which synthesized expressions are run + -> Q [Dec] -- ^ target I/O pairs + -> (a -> Bool) -- ^ test function + -> IO (Every a) +filterGetOne session tgt = filterGetOneBK session tgt [d| {} |] +filterGetOneBK :: (Typeable a) => + HscEnv -- ^ session in which synthesized expressions are run + -> Q [Dec] -- ^ target I/O pairs + -> Q [Dec] -- ^ I/O pairs for background knowledge functions + -> (a -> Bool) -- ^ test function + -> IO (Every a) +filterGetOneBK session tgt bk predicate = do tss <- synthFilt session tgt bk predicate + putStrLn $ pprint $ fst $ head $ concat tss + return tss + +synthFilt :: (Typeable a) => + HscEnv -- ^ session in which synthesized expressions are run + -> Q [Dec] -- ^ target I/O pairs + -> Q [Dec] -- ^ I/O pairs for background knowledge functions + -> (a -> Bool) -- ^ test function + -> IO (Every a) +synthFilt session tgt bk pred = filterThen pred =<< synthAll session tgt bk +synthFiltF :: (Filtrable a, Typeable a) => + HscEnv -- ^ session in which synthesized expressions are run + -> Q [Dec] -- ^ target I/O pairs + -> Q [Dec] -- ^ I/O pairs for background knowledge functions + -> (a -> Bool) -- ^ test function + -> IO (Every a) +synthFiltF session tgt bk pred = filterThenF pred =<< synthAll session tgt bk +synthAll :: (Typeable a) => + HscEnv -- ^ session in which synthesized expressions are run + -> Q [Dec] -- ^ target I/O pairs + -> Q [Dec] -- ^ I/O pairs for background knowledge functions + -> IO (Every a) +synthAll session tgt bk = do tgtdecs <- runQ tgt + bkdecs <- runQ bk + thExpssToEvery session (synthTyped tgtdecs bkdecs) +thExpssToEvery :: HscEnv -> [[Exp]] -> IO (Every a) +thExpssToEvery session ess = return $ map (map (\e -> (e, unsafePerformIO $ executeTHExp session e))) ess +-- thExpssToEvery session ess = mapM (mapM (\e -> fmap ((,) e) $ executeTHExp session e)) ess -- ¤³¤ì¤À¤È¥À¥á. unsafeInterleaveIO¤ò¤¦¤Þ¤¯»È¤¦¼ê¤â¤¢¤ë¤Î¤«¤â¡¥ diff --git a/MagicHaskeller/ShortString.hs b/MagicHaskeller/ShortString.hs new file mode 100644 --- /dev/null +++ b/MagicHaskeller/ShortString.hs @@ -0,0 +1,75 @@ +-- +-- (c) Susumu Katayama +-- +module MagicHaskeller.ShortString where +import Data.ByteString.Char8 as C -- This seems quicker, except that C.cons requires O(n). +import Data.ByteString.Lazy.Char8 as LC +import Data.Char +import MagicHaskeller.CoreLang +import MagicHaskeller.Types + +-- LC.cons' ¤À¤È¿ʬ¥À¥á + +class ShortString a where + showsBriefly :: a -> LC.ByteString -> LC.ByteString + readsBriefly :: C.ByteString -> Maybe (a,C.ByteString) -- ReadS a -- Maybe ¤ÎÊý¤¬Â®¤¤? ¤Æ¤æ¡¼¤«¡¤parse error¤Î³ä¹ç¤Ï¤¹¤´¤¯¾¯¤Ê¤¤¤Ï¤º¤Ê¤Î¤Çerror¤È¤·¤Æcatch¤·¤¿Êý¤¬Â®¤¤¤Ï¤º¡¥¤È»×¤Ã¤¿¤±¤É¡¤lazy¤Ê¥Ç¡¼¥¿¤Ê¤Î¤ÇÀµ¤·¤¯catch¤Ç¤­¤Ê¤¤¤«¡¥ + +instance ShortString a => ShortString [a] where + showsBriefly [] = LC.cons ']' + showsBriefly (x:xs) = showsBriefly x . showsBriefly xs + readsBriefly cs = case C.uncons cs of Nothing -> fail "parse error" + Just (']',ds) -> return ([],ds) + _ -> do (x, ds) <- readsBriefly cs + (xs,es) <- readsBriefly ds + return (x:xs, es) +instance ShortString CoreExpr where + showsBriefly (Lambda ce) = (LC.cons '\\') . showsBriefly ce + showsBriefly (X i) = (LC.cons 'X') . showsBriefly i + showsBriefly (Primitive i) = (LC.cons 'P') . showsBriefly i + showsBriefly (c :$ e) = (LC.cons '$') . showsBriefly c . showsBriefly e + readsBriefly cs = case C.uncons cs of -- Int(Nat)¤È1ʸ»ú¤á°ì½ï¤Ë1¥Ð¥¤¥È¤Ë¤Ç¤­¤Ê¤¤¤«?¤¢¤È¡¤lambda¤Ï³¤¯¤Î¤Ç¤Þ¤È¤á¤é¤ì¤½¤¦¡¥ + Just ('\\',xs) -> do (ce,ys) <- readsBriefly xs + return (Lambda ce, ys) + Just ('X', xs) -> do (i, ys) <- readsBriefly xs + return (X i, ys) + Just ('P', xs) -> do (i, ys) <- readsBriefly xs + return (Primitive i, ys) + Just ('$', xs) -> do (c, ys) <- readsBriefly xs + (e, zs) <- readsBriefly ys + return (c :$ e, zs) + _ -> fail "parse error" +-- Only small ints are used, if I remember correctly. +instance ShortString Int where + showsBriefly i = LC.cons (chr (i + 128)) -- other safer options are Numeric.showHex and Numeric.showIntAtBase + readsBriefly xs = case C.uncons xs of Nothing -> fail "parse error" + Just (c,cs) -> return (ord c - 128, cs) +instance (ShortString a, ShortString b, ShortString c) => ShortString (a,b,c) where + showsBriefly (a,b,c) = showsBriefly a . showsBriefly b . showsBriefly c + readsBriefly cs = do (a,ds) <- readsBriefly cs + (b,es) <- readsBriefly ds + (c,fs) <- readsBriefly es + return ((a,b,c),fs) +instance (ShortString a, ShortString b) => ShortString (a,b) where + showsBriefly (a,b) = showsBriefly a . showsBriefly b + readsBriefly cs = do (a,ds) <- readsBriefly cs + (b,es) <- readsBriefly ds + return ((a,b),es) +instance ShortString () where + showsBriefly () = id + readsBriefly cs = return ((),cs) +instance ShortString Type where + showsBriefly (TV i) = LC.cons 'V' . showsBriefly i + showsBriefly (TC i) = LC.cons 'C' . showsBriefly i + showsBriefly (TA f x) = LC.cons 'A' . showsBriefly f . showsBriefly x + showsBriefly (a :-> r) = LC.cons '>' . showsBriefly a . showsBriefly r + readsBriefly cs = case C.uncons cs of Just ('V',ds) -> do (i, es) <- readsBriefly ds + return (TV i, es) + Just ('C',ds) -> do (i, es) <- readsBriefly ds + return (TC i, es) + Just ('A',ds) -> do (f, es) <- readsBriefly ds + (x, fs) <- readsBriefly es + return (TA f x, fs) + Just ('>',ds) -> do (a, es) <- readsBriefly ds + (r, fs) <- readsBriefly es + return (a:->r, fs) + _ -> fail "parse error" diff --git a/MagicHaskeller/T10.hs b/MagicHaskeller/T10.hs --- a/MagicHaskeller/T10.hs +++ b/MagicHaskeller/T10.hs @@ -1,14 +1,14 @@ -- --- (c) Susumu Katayama 2009 +-- (c) Susumu Katayama -- module MagicHaskeller.T10 where import Control.Monad -import MagicHaskeller.CoreLang +-- import MagicHaskeller.CoreLang -- import PriorSubsts import Data.List(partition, sortBy) import Data.Monoid -import MagicHaskeller.Types +-- import MagicHaskeller.Types liftList :: MonadPlus m => [a] -> m a liftList = msum . map return @@ -84,9 +84,6 @@ 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 @@ -94,6 +91,8 @@ (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 +-} diff --git a/MagicHaskeller/TimeOut.hs b/MagicHaskeller/TimeOut.hs --- a/MagicHaskeller/TimeOut.hs +++ b/MagicHaskeller/TimeOut.hs @@ -1,11 +1,11 @@ -- --- (c) Susumu Katayama 2009 +-- (c) Susumu Katayama -- module MagicHaskeller.TimeOut where import Control.Concurrent(forkIO, killThread, myThreadId, ThreadId, threadDelay, yield) import Control.Concurrent.SampleVar -import Control.Exception(catch, Exception(..)) +import Control.Exception -- (catch, Exception(..)) -- import System.Posix.Unistd(getSysVar, SysVar(..)) -- import System.Posix.Process(getProcessTimes, ProcessTimes(..)) -- import System.Posix.Types(ClockTick) @@ -17,14 +17,47 @@ import Debug.Trace -- This IS necessary to monitor errors in the subprocs. --- import Timeout +-- import System.Timeout +import MagicHaskeller.Options(Opt(..)) +#ifdef FORCIBLETO +import qualified MagicHaskeller.ForcibleTO as ForcibleTO + +unsafeWithPTOOpt :: ForcibleTO.Byte a => Opt b -> a -> Maybe a +unsafeWithPTOOpt opt = let pto = timeout opt + in if forcibleTimeout opt then ForcibleTO.unsafeWithPTO pto else unsafeWithPTO pto +maybeWithTOOpt opt = let pto = timeout opt + in if forcibleTimeout opt then ForcibleTO.maybeWithTO pto else maybeWithTO seq pto +#else +unsafeWithPTOOpt opt = let pto = timeout opt + in unsafeWithPTO pto +maybeWithTOOpt opt = let pto = timeout opt + in maybeWithTO seq pto +#endif + +unsafeWithPTO :: Maybe Int -> a -> Maybe a +#ifdef CHTO +unsafeWithPTO pto a = unsafePerformIO $ wrapExecution ( + maybeWithTO seq pto (return a) + ) +newPTO t = return t +#else +unsafeWithPTO _ = Just +maybeWithTO :: c -> b -> IO a -> IO (Maybe a) +maybeWithTO _ _ action = do a <- action + return (Just a) +newPTO = error "not implemented on this platform." +#endif + +unsafeOpWithPTO :: Maybe Int -> (a->b->c) -> a -> b -> Maybe c +unsafeOpWithPTO mto op l r = unsafeWithPTO mto (op l r) + -- ¥½¡¼¥¹¤ò¤ß¤¿´¶¤¸¡¤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. +unsafeEvaluate t e = unsafePerformIO (withTO t (return e)) -- Should I use Control.OldException.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'. @@ -73,7 +106,7 @@ 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) +handler sv err = Control.Exception.catch (realHandler sv (err::SomeException)) (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 @@ -82,7 +115,7 @@ 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) +childHandler tid sv err = Control.Exception.catch (realChildHandler tid sv (err::SomeException)) (childHandler tid sv) realChildHandler tid sv err = do writeSampleVar sv Nothing killThread tid error "This thread must have been killed...." diff --git a/MagicHaskeller/TyConLib.hs b/MagicHaskeller/TyConLib.hs --- a/MagicHaskeller/TyConLib.hs +++ b/MagicHaskeller/TyConLib.hs @@ -1,5 +1,5 @@ -- --- (c) Susumu Katayama 2009 +-- (c) Susumu Katayama -- module MagicHaskeller.TyConLib where import qualified Data.Map as Map @@ -41,7 +41,30 @@ tupleMax = 0 -} +{- +defaultTyCons :: [(TypeName, Kind)] +defaultTyCons = [("()",Star), ("[]",Star::->Star)] ++ [ (tuplename i, intToRank1Kind i) | i<-[2..7] ] ++ [("Char",Star), ("Integer",Star), ("Int",Star), ("Double",Star), ("Float",Star), ("IO",Star::->Star), ("Bool",Star)] -- $B$3$3$K=P$F$/$kE[$,(BVirtual.hs$B$G$b=P$F$/$k$H%(%i!<$K$J$k$N$GCm0U!%(B +-- defaultTyCons = [("*","()"), ("* -> *","[]"), +-} + tuplename i = '(':replicate (i-1) ',' ++")" +{- +intToRank1Kind :: Int -> Kind +intToRank1Kind 0 = Star +intToRank1Kind i = Star ::-> intToRank1Kind (i-1) +-- $B$J$k$Y$/$3$$$D$i$r;H$&!%>J%9%Z!<%9$N$?$a!%(Btuples$B$C$F(Blist$B$r:n$k$Y$-(B? +-- first-order kind $B$N$[$&$,$?$@$7$+$C$?$h$&$J!#(B +unit = Con 0 "()" Star +list = Con 1 "[]" (Star::->Star) +tuple n = Con (fromIntegral n) (tuplename n) (intToRank1Kind n) +-- arrow = Con 2 "(->)" 2 +-- tuple n = Con (n+1) (tuplename n) n +-} +{- +unit = Con 0 0 +list = Con 1 0 +tuple n = Con n 0 +-} unit tcl = nameToTyCon tcl "()" list tcl = nameToTyCon tcl "[]" @@ -64,5 +87,5 @@ 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 (TH.TupleT i) | k == i = [(i, tuplename i)] thTypeToTyCons k tht = error ("thTypeToTyCons :: Kind error. k = "++show k++" and tht = "++TH.pprint tht) diff --git a/MagicHaskeller/Types.lhs b/MagicHaskeller/Types.lhs --- a/MagicHaskeller/Types.lhs +++ b/MagicHaskeller/Types.lhs @@ -1,7 +1,10 @@ -- --- (c) Susumu Katayama 2009 +-- (c) Susumu Katayama -- +Types.lhs: renamed to avoid name clash with package ghc +Oct. 1, 2003; bruteForce/Type.lhs + \begin{code} @@ -172,7 +175,7 @@ eqType t0 t1 = normalize t0 == normalize t1 --- quantify freezes tyvars into tycons whose IDs are negative. +-- quantify freezes tyvars into tycons whose tcID's are -tvID, like Tina Yu's approach to synthesis of polymorphic functions. quantify, quantify', unquantify :: Type -> Type quantify ty = quantify' (normalize ty) quantify' (TV iD) = TC (-iD-1) @@ -182,7 +185,7 @@ 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 (TC tc) | tc < 0 = TV (-1-tc) unquantify (TA t u) = TA (unquantify t) (unquantify u) unquantify (u :-> t) = unquantify u :-> unquantify t unquantify (u :> t) = unquantify u :> unquantify t @@ -216,6 +219,7 @@ +-- moved from MemoStingy.lhs and MemoDeb.lhs pushArgsCPS :: (Int -> [Type] -> Type -> a) -> [Type] -> Type -> a pushArgsCPS f = pa 0 where @@ -279,6 +283,7 @@ -- 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 +-- $B4pK\E*$K!$(BTHIH.match$B$O(Bmerge$B$r;H$C$F$k$N$G?.MQ$7$F$J$$!%(B match (l :-> r) (l' :-> r') = match2Ap l r l' r' {- match (l :-> r) (l' :> r') = match2Ap l r l' r' @@ -315,8 +320,10 @@ 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) + | u `elem` (tyvars t) = mzero -- infinite type +-- | u `elementOf` (tyvars t) = mzero -- infinite type -- The above list implementation seems faster. +-- | not (t `satisfies` classes u) = mzero -- applyCl is necessary for multi-param classes, but how can I do it? + | otherwise = return (unitSubst u t) -- $B$[$s$H$&$O(Bvar$B$I$&$7(Bbind$B$9$k$H$-$O(Bcontext$B$b$4$&$;$$$;$M$P$J$i$L!#(B substOK :: Subst -> Bool substOK = all (\ (i,ty) -> not (i `elem` (tyvars ty)))