packages feed

MagicHaskeller 0.8.6 → 0.8.6.1

raw patch · 9 files changed

+139/−30 lines, 9 filesdep +haskell-srcdep ~ghc

Dependencies added: haskell-src

Dependency ranges changed: ghc

Files

ExperimIOP.hs view
@@ -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"
MagicHaskeller.cabal view
@@ -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
MagicHaskeller.lhs view
@@ -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!
MagicHaskeller/Analytical.hs view
@@ -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
MagicHaskeller/Analytical/Synthesize.hs view
@@ -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
MagicHaskeller/ExecuteAPI610.hs view
@@ -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  -- ¤³¤Ã¤«¤é¥×¥í¥Õ¥¡¥¤¥ëÍÑ
MagicHaskeller/LibTH.hs view
@@ -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,
+ MagicHaskeller/ReadHsType.hs view
@@ -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)
MagicHaskeller/RunAnalytical.hs view
@@ -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")