diff --git a/ExperimIOP.hs b/ExperimIOP.hs --- a/ExperimIOP.hs +++ b/ExperimIOP.hs @@ -23,14 +23,14 @@ -- Eg. :cmd prepare prepare :: IO String -prepare = run [":set +s",":m +Language.Haskell.TH","session <- prepareAPI [\"MagicHaskeller\"]"] +prepare = run [":set +s",":m +Language.Haskell.TH","session <- prepareAPI []"] run :: [String] -> IO String run = return . unlines . echoOn -- set of lightweight experiments batchWriteFile filename = do - session <- prepareAPI ["MagicHaskeller"] + session <- prepareAPI [] let f :: forall a. (Filtrable a, Typeable a) => Q [Dec] -> (a -> Bool) -> IO () f = filterGetOne_ session batchWrite filename [ f addN longAddNPred @@ -838,9 +838,14 @@ suM [2,0] = 2 suM [2,1] = 3 suM [2,2] = 4 - suM [2,1, 2] = 5 + suM [2,1, 2] = 5 -- without this line this is easily synthesizable. |] + +sumL = [d| sum [] = 0; sum [x] = x; sum [x,y] = x+y; sum [x,y,z] = x+y+z; sum [x,y,z,w] = x+y+z+w |] +sumR = [d| sum [] = 0; sum [x] = x; sum [x,y] = x+y; sum [x,y,z] = x+(y+z); sum [x,y,z,w] = x+(y+(z+w)) |] + tunedSum n = fmap (takeFunD n) suM + sumPred sum = sum [7,3,8,5] == 23 -- :cmd run $ filtGetOne "swap" "swapPred" diff --git a/MagicHaskeller.cabal b/MagicHaskeller.cabal --- a/MagicHaskeller.cabal +++ b/MagicHaskeller.cabal @@ -1,5 +1,5 @@ Name: MagicHaskeller -Version: 0.8.6 +Version: 0.8.6.1 Cabal-Version: >= 1.2 License: BSD3 Author: Susumu Katayama @@ -16,6 +16,14 @@ Description: Enable execution using the GHC API rather than the combinatory interpreter Default: True +Flag GHC7 + Description: GHC API version 7.* + Default: True + +Flag READFILE + Description: Enable to read a component library file + Default: True + -- Flag ForcibleTO -- Flag Debug -- Flag Benchmark @@ -40,3 +48,12 @@ if flag(GHCAPI) Build-depends: ghc >= 6.10, old-time, ghc-paths Exposed-modules: MagicHaskeller.RunAnalytical, MagicHaskeller.ExecuteAPI610 + + if flag(READFILE) + Build-depends: haskell-src + cpp-options: -DHASKELLSRC + Other-modules: MagicHaskeller.ReadHsType + + if flag(GHC7) + Build-depends: ghc >= 7 + cpp-options: -DGHC7 diff --git a/MagicHaskeller.lhs b/MagicHaskeller.lhs --- a/MagicHaskeller.lhs +++ b/MagicHaskeller.lhs @@ -116,7 +116,7 @@ Primitive, HValue(HV), -- other stuff which will not be documented by Haddock - unsafeCoerce#, {- unifyablePos, -} exprToTHExp, trToTHType, printAny, p1 + unsafeCoerce#, {- unifyablePos, -} exprToTHExp, trToTHType, printAny, p1, Filtrable ) where import Data.Generics(everywhere, mkT, Data) @@ -212,7 +212,7 @@ -- mkMD 15 $(p [| ( 0::Int, succ::Int->Int, nat_para, [] :: [a]) |] ) -- | 'p' is used to convert your primitive component set into the internal form. -p :: TH.ExpQ -- ^ Quasi-quote a tuple of primitive components here. +p :: TH.ExpQ -- ^ Quote a tuple of primitive components here. -> TH.ExpQ -- ^ This becomes @[Primitive]@ when spliced. p eq = eq >>= \e -> case e of TupE es -> (return . ListE) =<< (mapM p1 es) _ -> (return . ListE . return) =<< p1 e -- This default pattern should also be defined, because it takes two (or more) to tuple! diff --git a/MagicHaskeller/Analytical.hs b/MagicHaskeller/Analytical.hs --- a/MagicHaskeller/Analytical.hs +++ b/MagicHaskeller/Analytical.hs @@ -77,7 +77,7 @@ c :: Q [Dec] -> ExpQ -- ^ Also, @ $(c [d| ... |]) :: SplicedPrims @ --- 'c' is a helper function for extracting some info from the quasi-quoted declarations. +-- 'c' is a helper function for extracting some info from the quoted declarations. c decq = do decs <- decq expdecs <- decsToExpDecs decs expPrims <- fmap ListE $ mapM p1 $ cons decs diff --git a/MagicHaskeller/Analytical/Synthesize.hs b/MagicHaskeller/Analytical/Synthesize.hs --- a/MagicHaskeller/Analytical/Synthesize.hs +++ b/MagicHaskeller/Analytical/Synthesize.hs @@ -50,7 +50,7 @@ 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) + ,foldr (Types.:->) ty bktypes) _ -> error "TypedIOPairs.analyticSynth*: More than one I/O pairs are defined as the target." where xvl = mkXVarLib vl diff --git a/MagicHaskeller/ExecuteAPI610.hs b/MagicHaskeller/ExecuteAPI610.hs --- a/MagicHaskeller/ExecuteAPI610.hs +++ b/MagicHaskeller/ExecuteAPI610.hs @@ -1,14 +1,14 @@ -- -- (c) Susumu Katayama -- -{-# OPTIONS -fth -fglasgow-exts #-} +{-# OPTIONS -fth -fglasgow-exts -cpp #-} -- 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 DynFlags -- (DynFlag, defaultDynFlags, PackageFlag(ExposePackage)) -- , glasgowExtsFlags) ¤Ïexport¤µ¤ì¤Æ¤¤¤Ê¤¤¤é¤·¤¤. import SrcLoc (SrcSpan(..), noSrcSpan, noSrcLoc, interactiveSrcLoc, Located(L), noLoc) -- import MyCorePrep ( corePrepExpr ) @@ -60,8 +60,10 @@ import Data.List(isSuffixOf) +#ifdef GHC6 -- prelude/TysPrim. import TysPrim(anyPrimTy) +#endif import Bag import RdrName @@ -103,35 +105,43 @@ -> IO Session prepareAPI fss allfss -} -prepareAPI :: [String] -- ^ visible modules (including package modules) +prepareAPI :: [String] -- ^ visible modules (including package modules). + -- Supplying @[]@ here works without any problems within GHCi, and currently @prepareAPI@ does not work without --interactive, + -- so this argument is actually of no use:( -> IO HscEnv prepareAPI fss = defaultErrorHandler defaultDynFlags $ runGhc (Just pathToGHC) $ do - liftIO $ hPutStrLn stderr "setting up flags" + -- 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 : + packageFlags = [ ExposePackage "ghc", ExposePackage "old-time", ExposePackage "ghc-paths" ] + {- + flags = Opt_TemplateHaskell : Opt_Cpp : -- Opt_FlexibleInstances : Opt_ExistentialQuantification : Opt_PolymorphicComponents : Opt_RelaxedPolyRec : Opt_MagicHash : Opt_RankNTypes : - filter (/=Opt_MonomorphismRestriction) (flags dfs)} -- Was: Opt_TH -- ¤Æ¤æ¡¼¤«¡¤LibTH¤ò¤³¤³¤ÇÆɤà¤Ë¤Ï¤¤¤í¤ó¤Ê¥Õ¥é¥°¤¬.... + 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. + -- 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) + -- liftIO $ hPutStrLn stderr "setting up modules********************************************************" +#ifdef GHC7 + modules <- mapM (\fs -> fmap (\x -> (x,Nothing)) $ findModule (mkModuleName fs) Nothing) ("Prelude":fss) +#else + modules <- mapM (\fs -> findModule (mkModuleName fs) Nothing) ("Prelude":fss) +#endif setContext [] modules #ifdef PRELINK @@ -232,6 +242,8 @@ stmtToCore hscEnv pst = do let dfs = hsc_dflags hscEnv icxt = hsc_IC hscEnv + -- hPutStrLn stderr "*************************************" + -- hPutStrLn stderr $ showSDoc $ ppr pst (tcmsgs, mbtc) <- tcRnStmt hscEnv icxt pst case mbtc of Nothing -> perror dfs tcmsgs Just (ids, tc_expr) -> do -- desugar @@ -271,7 +283,7 @@ hoge (b, e) = shows b . (" = "++) . shows e . (" ; "++) - +{- unused. also, anyPrimTy does not appear in ghc-7.* any longer -- 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) @@ -283,6 +295,7 @@ 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 @@ -292,7 +305,8 @@ bcos <- coreExprToBCOs dflags prep linkExpr hscEnv noSrcSpan bcos - +#ifdef GHC6 +{- directLoadObj :: [String] -- ^ visible modules (including package modules). You may omit the Prelude. -> [(a, TH.Exp, TH.Type)] -> IO (CoreLang.CoreExpr -> Dynamic) @@ -309,13 +323,12 @@ 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 @@ -343,7 +356,6 @@ 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 @@ -488,6 +500,8 @@ 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) +#endif +-- ifdef GHC6 -- ¤³¤Ã¤«¤é¥×¥í¥Õ¥¡¥¤¥ëÍÑ diff --git a/MagicHaskeller/LibTH.hs b/MagicHaskeller/LibTH.hs --- a/MagicHaskeller/LibTH.hs +++ b/MagicHaskeller/LibTH.hs @@ -115,7 +115,8 @@ postprocess -} - +exploit :: (Typeable a, Filtrable a) => (a -> Bool) -> IO () +exploit pred = filterThenF pred (everything (reallyall::ProgGenSF)) >>= pprs boolean = $(p [| ((&&) :: Bool -> Bool -> Bool, (||) :: Bool -> Bool -> Bool, diff --git a/MagicHaskeller/ReadHsType.hs b/MagicHaskeller/ReadHsType.hs new file mode 100644 --- /dev/null +++ b/MagicHaskeller/ReadHsType.hs @@ -0,0 +1,53 @@ +module MagicHaskeller.ReadHsType(readHsTypeSigs) where +import Language.Haskell.TH as TH +import Language.Haskell.Syntax +import Language.Haskell.Parser +import Data.List + +import MagicHaskeller.ReadTHType(plainTV) + +-- | @readHsTypeSigs@ reads a module string and returns an Exp that can be supplied to MagicHaskeller.p +readHsTypeSigs :: String -> TH.Exp +readHsTypeSigs str = TupE [ mkSigE hsname hsqty + | HsTypeSig _loc hsnames hsqty <- readHsDecls str + , hsname <- hsnames ] + +mkSigE :: HsName -> HsQualType -> TH.Exp +mkSigE hsname hsqty = SigE (VarE $ hsNameToTHName hsname) (hsQTypeToTHType hsqty) + +hsQTypeToTHType :: HsQualType -> TH.Type +-- hsQTypeToTHType (HsQualType cxt hsty) = ForallT (map (plainTV . hsNameToTHName) $ map head $ group $ sort $ varnames [] hsty) (map hsAsstToTHType cxt) (hsTypeToTHType hsty) -- This is incorrect since template-haskell-2.4*, so just forget the contexts. +hsQTypeToTHType (HsQualType [] hsty) = ForallT (map (plainTV . hsNameToTHName) $ map head $ group $ sort $ varnames [] hsty) [] (hsTypeToTHType hsty) +hsQTypeToTHType (HsQualType _cxt _hsty) = error "Contexts are not supported yet." +hsTypeToTHType (HsTyTuple hts) = foldl AppT (TupleT (length hts)) (map hsTypeToTHType hts) +hsTypeToTHType (HsTyFun ht0 ht1) = ArrowT `AppT` (hsTypeToTHType ht0) `AppT` (hsTypeToTHType ht1) +hsTypeToTHType (HsTyApp ht0 ht1) = (hsTypeToTHType ht0) `AppT` (hsTypeToTHType ht1) +hsTypeToTHType (HsTyCon hsqname) = hsQNameToTHType hsqname +hsTypeToTHType (HsTyVar hsname) = VarT $ hsNameToTHName hsname +-- The above definition should be exhaustive +varnames vs (HsTyTuple hts) = foldl varnames vs hts +varnames vs (HsTyFun ht0 ht1) = varnames (varnames vs ht0) ht1 +varnames vs (HsTyApp ht0 ht1) = varnames (varnames vs ht0) ht1 +varnames vs (HsTyCon _) = vs +varnames vs (HsTyVar hsname) = hsname:vs + +hsNameToTHName = mkName . hsNameToString + +hsNameToString (HsIdent str) = str +hsNameToString (HsSymbol str) = str -- Was: '(':str++")" + +hsAsstToTHType :: HsAsst -> TH.Type +hsAsstToTHType (hsqname, hstypes) = foldl AppT (hsQNameToTHType hsqname) (map hsTypeToTHType hstypes) + +hsQNameToTHType (UnQual hsname) = ConT $ hsNameToTHName hsname +hsQNameToTHType (Qual _ hsname) = ConT $ hsNameToTHName hsname -- qualifications over type names are ignored for now. +hsQNameToTHType (Special HsFunCon) = ArrowT +hsQNameToTHType (Special HsUnitCon) = ConT $ mkName "()" +hsQNameToTHType (Special HsListCon) = ListT +hsQNameToTHType (Special (HsTupleCon n)) = TupleT n + + +readHsDecls :: String -> [HsDecl] +readHsDecls src = case parseModule src of ParseOk (HsModule _loc _nam _ex _imports decls) -> decls + ParseFailed (SrcLoc _fn line column) str + -> error (str ++ " in " ++ shows line ":" ++ shows column " of\n" ++ src) diff --git a/MagicHaskeller/RunAnalytical.hs b/MagicHaskeller/RunAnalytical.hs --- a/MagicHaskeller/RunAnalytical.hs +++ b/MagicHaskeller/RunAnalytical.hs @@ -5,13 +5,14 @@ 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"] + -- *** All in one actions + quickStartC, quickStartCF, + -- >>> session <- prepareAPI [] -- >>> 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) @@ -25,6 +26,7 @@ -- *** counterparts to 'filterGet1_', 'filterGet1', and 'filterGet1BK' filterGetOne_, filterGetOne, filterGetOneBK, -- *** counterparts to 'getFilt', 'getFiltF', and 'getAll' + synthFilt, synthFiltF, synthAll, -- *** counterpart to 'noBK' noBKQ @@ -39,6 +41,23 @@ import MagicHaskeller.GetTime import System.IO + +quickStartC :: (Typeable a) => + SplicedPrims -- ^ target I/O pairs + -> SplicedPrims -- ^ I/O pairs for background knowledge functions + -> (a -> Bool) -- ^ test function + -> IO () +quickStartC tgt bk pred = do session <- prepareAPI [] + tss <- getFilt session tgt bk pred + pprs tss +quickStartCF :: (Filtrable a, Typeable a) => + SplicedPrims -- ^ target I/O pairs + -> SplicedPrims -- ^ I/O pairs for background knowledge functions + -> (a -> Bool) -- ^ test function + -> IO () +quickStartCF tgt bk pred = do session <- prepareAPI [] + tss <- getFiltF session tgt bk pred + pprs tss filterGet1_ :: (Typeable a) => HscEnv -- ^ session in which synthesized expressions are run -> SplicedPrims -- ^ target I/O pairs @@ -110,7 +129,7 @@ -> Q [Dec] -- ^ I/O pairs for background knowledge functions -> (a -> Bool) -- ^ test function -> IO () -quickStart iops bk pred = do session <- prepareAPI ["MagicHaskeller"] +quickStart iops bk pred = do session <- prepareAPI [] tss <- synthFilt session iops bk pred pprs tss quickStartF :: (Filtrable a, Typeable a) => @@ -118,11 +137,11 @@ -> Q [Dec] -- ^ I/O pairs for background knowledge functions -> (a -> Bool) -- ^ test function -> IO () -quickStartF iops bk pred = do session <- prepareAPI ["MagicHaskeller"] +quickStartF iops bk pred = do session <- prepareAPI [] tss <- synthFiltF session iops bk pred pprs tss -batchExample = do session <- prepareAPI ["MagicHaskeller"] +batchExample = do session <- prepareAPI [] 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")