MagicHaskeller 0.8.5 → 0.8.6
raw patch · 47 files changed
+4067/−688 lines, 47 filesdep +bytestringdep +directorydep +ghcdep ~base
Dependencies added: bytestring, directory, ghc, ghc-paths, mtl, old-time, syb
Dependency ranges changed: base
Files
- Control/Monad/Search/Combinatorial.lhs +22/−13
- Data/Memo.hs +1/−1
- ExperimIOP.hs +1074/−0
- LICENSE +0/−25
- MagicHaskeller.cabal +40/−24
- MagicHaskeller.lhs +123/−146
- MagicHaskeller/Analytical.hs +114/−0
- MagicHaskeller/Analytical/FMExpr.hs +119/−0
- MagicHaskeller/Analytical/Parser.hs +216/−0
- MagicHaskeller/Analytical/Syntax.hs +158/−0
- MagicHaskeller/Analytical/Synthesize.hs +408/−0
- MagicHaskeller/Analytical/UniT.hs +40/−0
- MagicHaskeller/Classification.hs +5/−1
- MagicHaskeller/Classify.hs +26/−25
- MagicHaskeller/ClassifyDM.hs +11/−11
- MagicHaskeller/ClassifyTr.hs +8/−6
- MagicHaskeller/Combinators.hs +1/−1
- MagicHaskeller/CoreLang.lhs +234/−33
- MagicHaskeller/DebMT.lhs +3/−28
- MagicHaskeller/Execute.hs +7/−3
- MagicHaskeller/ExecuteAPI610.hs +513/−0
- MagicHaskeller/ExprStaged.hs +1/−3
- MagicHaskeller/Expression.hs +5/−1
- MagicHaskeller/FakeDynamic.hs +36/−9
- MagicHaskeller/GetTime.hs +39/−0
- MagicHaskeller/Instantiate.hs +1/−1
- MagicHaskeller/LibTH.hs +48/−4
- MagicHaskeller/MHTH.lhs +12/−30
- MagicHaskeller/MemoToFiles.hs +86/−0
- MagicHaskeller/MyCheck.hs +1/−1
- MagicHaskeller/MyDynamic.hs +1/−30
- MagicHaskeller/Options.hs +136/−0
- MagicHaskeller/PolyDynamic.hs +107/−0
- MagicHaskeller/PriorSubsts.lhs +10/−1
- MagicHaskeller/ProgGen.lhs +28/−19
- MagicHaskeller/ProgGenSF.lhs +36/−60
- MagicHaskeller/ProgGenXF.lhs +35/−56
- MagicHaskeller/ProgramGenerator.lhs +18/−130
- MagicHaskeller/ReadDynamic.hs +1/−1
- MagicHaskeller/ReadTHType.lhs +15/−5
- MagicHaskeller/ReadTypeRep.hs +1/−1
- MagicHaskeller/RunAnalytical.hs +171/−0
- MagicHaskeller/ShortString.hs +75/−0
- MagicHaskeller/T10.hs +5/−6
- MagicHaskeller/TimeOut.hs +39/−6
- MagicHaskeller/TyConLib.hs +25/−2
- MagicHaskeller/Types.lhs +12/−5
Control/Monad/Search/Combinatorial.lhs view
@@ -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.-[<Main.main,Main.CAF><Main.main,Main.CAF><Search.jOIN,Search.CAF>Stack space overflow: current size 1048576 bytes.-$B$H$J$C$?!#(BStack overflow$B$OM}O@>eEvA3!J(BSpivey$B$b=q$$$F$k!K$@$,!"$J$s$G(BCAF$B$J$N!)(B $B$I$3$K(BCAF$B$,$"$k$s$8$c!)(B ...mzero$B$+!)!*!*(B-$B$^$"!"(BCAF$B$C$F$3$H$J$i(BGHC$B$H(BNHC$B$GF0:n$,0c$&$N$b$&$J$:$1$k$,!#!J(BNHC$B$@$H(BCAF$B$O4X?t07$$$@$C$?$H;W$&!#FCDj$N(BCAF$B$@$1$@$C$?$+$b!#!K(B--}+ diag :: Stream (Stream a) -> Stream (Bag a) diag ((x:xs):xss) = return x : zipWith cons xs (diag xss) @@ -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$&<BAu(B NB: This is confusing.+-- $B8+3]$1>e$N?<$5$r;H$&<BAu(B zipDepthDB :: (Int -> 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))
Data/Memo.hs view
@@ -1,5 +1,5 @@ -- --- (c) Susumu Katayama 2009+-- (c) Susumu Katayama -- {-# OPTIONS -fglasgow-exts -cpp #-} module Data.Memo where
+ ExperimIOP.hs view
@@ -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+ |]
− LICENSE
@@ -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.
MagicHaskeller.cabal view
@@ -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 <skata@cs.miyazaki-u.ac.jp>-Stability: experimental-Homepage: http://nautilus.cs.miyazaki-u.ac.jp/~skata/MagicHaskeller.html-Synopsis: Automatic inductive functional programmer by systematic search-Build-Type: Simple-Category: Language--- Tested-with: ghc=6.8.2-Build-depends: template-haskell, base >= 3 && < 4, containers, array, random-Exposed-modules: MagicHaskeller, Control.Monad.Search.Combinatorial, MagicHaskeller.ProgGen, MagicHaskeller.ProgGenSF, MagicHaskeller.ProgGenXF, MagicHaskeller.Expression, MagicHaskeller.LibTH-Other-modules: MagicHaskeller.Types, MagicHaskeller.PriorSubsts, Data.Memo, MagicHaskeller.ClassifyTr, MagicHaskeller.Classification, - MagicHaskeller.CoreLang, MagicHaskeller.DebMT, MagicHaskeller.TyConLib,- MagicHaskeller.FakeDynamic, MagicHaskeller.ReadTypeRep,- MagicHaskeller.ReadTHType, MagicHaskeller.TimeOut, MagicHaskeller.Execute, MagicHaskeller.T10,- MagicHaskeller.Instantiate, MagicHaskeller.Classify, MagicHaskeller.MHTH, MagicHaskeller.MyCheck,- MagicHaskeller.ExprStaged, MagicHaskeller.Combinators, MagicHaskeller.ReadDynamic,- MagicHaskeller.MyDynamic, MagicHaskeller.ClassifyDM, MagicHaskeller.ProgramGenerator-Extensions: CPP, TemplateHaskell-GHC-options: -O2 -fvia-C-cpp-options: -DCHTO+Author: Susumu Katayama+Maintainer: Susumu Katayama <skata@cs.miyazaki-u.ac.jp>+Stability: experimental+Homepage: http://nautilus.cs.miyazaki-u.ac.jp/~skata/MagicHaskeller.html+Synopsis: Automatic inductive functional programmer by systematic search+Build-Type: Simple+Category: Language+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
MagicHaskeller.lhs view
@@ -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
+ MagicHaskeller/Analytical.hs view
@@ -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
+ MagicHaskeller/Analytical/FMExpr.hs view
@@ -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' ]+
+ MagicHaskeller/Analytical/Parser.hs view
@@ -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)¤ò»ý¤Ä¤³¤È¤Ë¤Ê¤ë¡¥+-}
+ MagicHaskeller/Analytical/Syntax.hs view
@@ -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.
+ MagicHaskeller/Analytical/Synthesize.hs view
@@ -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 ]
+ MagicHaskeller/Analytical/UniT.hs view
@@ -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)
MagicHaskeller/Classification.hs view
@@ -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)
MagicHaskeller/Classify.hs view
@@ -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<j then y else x) (\(k,_) (l,_) -> liftCompareBot (fcnrnd n) cmp k l) (f n)-ofilterDB :: (k->k->Ordering) -> DBound (k,e) -> DBound (k,e)-ofilterDB cmp (DB f) = DB $ \n -> mergesortWithBy const (\((k,_),_) ((l,_),_) -> cmp k l) (f n)+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
MagicHaskeller/ClassifyDM.hs view
@@ -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<j then y else x)- (\(k,_) (l,_) -> 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
MagicHaskeller/ClassifyTr.hs view
@@ -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
MagicHaskeller/Combinators.hs view
@@ -1,5 +1,5 @@ -- --- (c) Susumu Katayama 2009+-- (c) Susumu Katayama -- module MagicHaskeller.Combinators where import MagicHaskeller.ExprStaged
MagicHaskeller/CoreLang.lhs view
@@ -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<i = FunX (pred i)+liftFun th (Lambda e) = Lambda (liftFun th e)+liftFun th (FunLambda e) = FunLambda (liftFun (succ th) e)+liftFun th (f :$ e) = liftFun th f :$ liftFun th e+liftFun th (Case x ts) = Case (liftFun th x) (map (\(c,a,ce) -> (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<i = X (i-n)+nlift th n (Lambda e) = Lambda (nlift (succ th) n e)+nlift th n (FunLambda e) = FunLambda (nlift th n e)+nlift th n (f :$ e) = nlift th n f :$ nlift th n e+nlift th n (Case x ts) = Case (nlift th n x) (map (\(c,a,ce) -> (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}
MagicHaskeller/DebMT.lhs view
@@ -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
MagicHaskeller/Execute.hs view
@@ -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
+ MagicHaskeller/ExecuteAPI610.hs view
@@ -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) . ("<Coercion>"++)+ 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+++
MagicHaskeller/ExprStaged.hs view
@@ -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)
MagicHaskeller/Expression.hs view
@@ -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)]
MagicHaskeller/FakeDynamic.hs view
@@ -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
+ MagicHaskeller/GetTime.hs view
@@ -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)
MagicHaskeller/Instantiate.hs view
@@ -1,5 +1,5 @@ -- --- (c) Susumu Katayama 2009+-- (c) Susumu Katayama -- {-# OPTIONS -fglasgow-exts -cpp #-} module MagicHaskeller.Instantiate(mkRandTrie, RTrie, -- arbitraries,
MagicHaskeller/LibTH.hs view
@@ -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,
MagicHaskeller/MHTH.lhs view
@@ -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
+ MagicHaskeller/MemoToFiles.hs view
@@ -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
MagicHaskeller/MyCheck.hs view
@@ -1,5 +1,5 @@ -- --- (c) Susumu Katayama 2009+-- (c) Susumu Katayama -- {- rewrite of QuickCheck.Arbitrary in the form specialized for each type
MagicHaskeller/MyDynamic.hs view
@@ -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
+ MagicHaskeller/Options.hs view
@@ -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+-}
+ MagicHaskeller/PolyDynamic.hs view
@@ -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) = ("<dynamic "++) . (pprint e++) . ("::"++) . showsPrec 0 t . ('>':)++-- (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
MagicHaskeller/PriorSubsts.lhs view
@@ -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
MagicHaskeller/ProgGen.lhs view
@@ -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
MagicHaskeller/ProgGenSF.lhs view
@@ -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
MagicHaskeller/ProgGenXF.lhs view
@@ -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
MagicHaskeller/ProgramGenerator.lhs view
@@ -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<B9T$7$?J}$,8zN(E*$J$O$:!)(B $B$G$b!$(BSubstitution$B$C$F$=$s$J$K$G$+$/$J$i$J$+$C$?$N$G$O!)(BFiniteMap$B$G$b(Bassoc list$B$G$bJQ$o$i$J$+$C$?5$$,!%(B + applyDo :: Monad m => ([Type] -> Type -> PriorSubsts m a) -> [Type] -> Type -> PriorSubsts m a applyDo fun avail ty = do subst <- getSubst fun (map (apply subst) avail) (apply subst ty)@@ -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$:$@$,!$>!<j$K$5$l$k!)(B -- -- unitSubst$B$r(Binline$B$K$7$J$$$HBLL\$+(B- a <- mkSubsts tvid reqret+ a <- mkSubsts (tvndelay $ opt $ extractCommon pg) tvid reqret exprs <- funApSub lltbehalf behalf (mapTV (tvid+) ty) (map (fromCE (reducer pg) lenavails (arity+a)) xs) gentvar <- applyPS (TV tvid) guard (orderedAndUsedArgs gentvar) -- $B$3$NJU$N(Bcheck$B$r(BTVn$B$KF~$kA0$NAa$$CJ3,$K$d$k$N$O(B1$B$D$N9M$(J}$@$,!$(BTVn$BCf$K(Breplace$B$5$l$?$j$O$7$J$$$N$+(B?@@ -282,7 +205,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$:$@$,!$>!<j$K$5$l$k!)(B -- -- unitSubst$B$r(Binline$B$K$7$J$$$HBLL\$+(B- a <- mkSubst tvid reqret+ a <- mkSubst (tvndelay $ opt $ extractCommon pg) tvid reqret exprs <- funApSub lltbehalf behalf (mapTV (tvid+) ty) (map (fromCE (reducer pg) lenavails (arity+a)) xs) gentvar <- applyPS (TV tvid) guard (usedArg (tvid+1) gentvar)@@ -339,43 +262,8 @@ rsv' rve (t:->u) (e:es) = (returnsId t e || retVal t e == rve) && rsv' rve u es rsv' _ _ _ = True -\end{code} -type$B$r$R$C$/$jJV$9>l9g(B -{---- :>$B$J(Bargument$B$r(Bdrop$B$9$k$N$rK:$l$F$?!%(B--- :>$B$r:F$S<BAu$9$k;~$O!$(BCoreExpr$B$NJ}$N(Bspine$B$N(Blist$B$r;}$D!%$G!$(B:>$B$N>l=j$r(Bskip$B$9$k!%(B--- $B$"$H!$JV$jCM$,4X?t$K(Bunify$B$9$k$3$H$b$"$k$N$G!$I,$:0z?t$G$O$J$/7?$NJ}$r?t$($k$3$H(B-... $B$F$f!<$+$=$l$@$C$?$i8e$m$+$i?t$($A$c%@%a$8$c$s!%(B-$B$3$l$O7k9=$d$d$3$7$$OC$@$,!$(B-$B!&(BreturnsId$B$K4X$7$F$O!$(Breplace$B$9$kA0$N7?$N(Barity$B$G?t$($F(Bid$B$rJV$9>l9g$7$+Ev$F$O$^$i$J$$!%(B-$B!&(BretVal$B$K4X$7$F$O!$$$$C$A$c$s:G8e$,Ey$7$1$l$P(BOK$B!%$H$O$$$(!$(B- - returnsId$B$,8r$8$C$F$$$l$P!$7k6I(Breplace$B$9$kA0$N7?$N(Barity$B$G?t$($k$3$H$K$J$k$@$m$&!$$^$?!$(B- - returnsId$B$,8r$8$C$F$$$J$$!$$D$^$j(Brecursion$B$,$J$$>l9g$O!$$=$b$=$b(Bcase expansion$B$G(Bfilter out$B$5$l$k!JM=Dj!K(B-$B$H$$$&$o$1$G!$<B:]$K$O$I$A$i$N%1!<%9$G$b(Breplace$B$9$kA0$N7?$N(Barity$B$G?t$($l$P$h$$!%$D$^$jA0$+$i?t$($m$C$F$3$H$d$M!%(B-$B$F$f!<$+!$A0$+$i?t$($k$H$+$$$&$N$O3F(Bargument$B$NOC!%(B--}-{- $B>e5-$NM}M3$+$i!$$3$l$O4V0c$$!%(B-retSameVal (hd:tl@(_:_)) (f:$e) = -- trace ("t = "++show t ++ ", and f:$e = " ++ show (f:$e)) $ - (returnsId hd e && returnsAtoA hd && retSameVal tl f) || retSameVal' rve tl f- where rve = retVal e-retSameVal _ _ = True-retSameVal' e (hd:tl@(_:_)) (f:$d) = ((returnsId hd d && returnsAtoA hd) || rvd==e) && retSameVal' e tl f--- retSameVal' e t (f:$d) = (d == X 0 && returnsAtoA (head t) && retSameVal' e tailt f) || (d==e) && retSameVal' e tailt f- where rvd = retVal d-retSameVal' _ _ _ = True--}--retSameVal (hd:tl@(_:_)) (f:$e) = -- trace ("t = "++show t ++ ", and f:$e = " ++ show (f:$e)) $ - (returnsId hd e && retSameVal tl f) || retSameVal' (retVal hd e) tl f-retSameVal _ _ = True-retSameVal' rve (hd:tl@(_:_)) (f:$d) = (returnsId hd d || retVal hd d == rve) && retSameVal' rve tl f-retSameVal' _ _ _ = True--\begin{code}-- -- returnsAtoA is True when the type returns a->a, where the tvID of a is 0. returnsAtoA (TV tv0 :-> TV tv1) = tv0 == 0 && tv1 == 0 returnsAtoA (t :-> u) = returnsAtoA u@@ -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
MagicHaskeller/ReadDynamic.hs view
@@ -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
MagicHaskeller/ReadTHType.lhs view
@@ -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.(->)")
MagicHaskeller/ReadTypeRep.hs view
@@ -1,5 +1,5 @@ -- --- (c) Susumu Katayama 2009+-- (c) Susumu Katayama -- module MagicHaskeller.ReadTypeRep where import Data.Typeable
+ MagicHaskeller/RunAnalytical.hs view
@@ -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¤ò¤¦¤Þ¤¯»È¤¦¼ê¤â¤¢¤ë¤Î¤«¤â¡¥
+ MagicHaskeller/ShortString.hs view
@@ -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"
MagicHaskeller/T10.hs view
@@ -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+-}
MagicHaskeller/TimeOut.hs view
@@ -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...."
MagicHaskeller/TyConLib.hs view
@@ -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)
MagicHaskeller/Types.lhs view
@@ -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)))