MagicHaskeller 0.9.6.10 → 0.9.7.0
raw patch · 13 files changed
+163/−74 lines, 13 filesdep +ghc-api-compatdep +splitmixdep ~ghcdep ~networkdep ~network-uri
Dependencies added: ghc-api-compat, splitmix
Dependency ranges changed: ghc, network, network-uri, random
Files
- MagicHaskeller.cabal +28/−19
- MagicHaskeller.lhs +21/−9
- MagicHaskeller/Analytical.hs +2/−2
- MagicHaskeller/Analytical/Parser.hs +8/−1
- MagicHaskeller/ExecuteAPI610.hs +48/−13
- MagicHaskeller/ExpToHtml.hs +4/−0
- MagicHaskeller/Instantiate.hs +17/−8
- MagicHaskeller/LibExcel.hs +8/−8
- MagicHaskeller/LibTH.hs +5/−5
- MagicHaskeller/MHTH.lhs +7/−1
- MagicHaskeller/ProgramGenerator.lhs +5/−3
- MagicHaskeller/ReadHsType.hs +5/−1
- MagicHaskeller/SimpleServer.hs +5/−4
MagicHaskeller.cabal view
@@ -1,9 +1,9 @@ Name: MagicHaskeller-Version: 0.9.6.10+Version: 0.9.7.0 Cabal-Version: >= 1.10 License: BSD3-License-file: LICENSE -Author: Susumu Katayama+License-file: LICENSE +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@@ -21,12 +21,16 @@ Flag TFRANDOM Description: Use the tf-random package instead of the random package- Default: True+ Default: False Flag GHCAPI Description: Enable execution using the GHC API rather than the combinatory interpreter Default: True +Flag GHCAPICompat+ Description: Use GHC-API's compatibility helper.+ Default: False+ Flag READFILE Description: Enable to read a component library file Default: True@@ -55,17 +59,20 @@ Library Build-depends: time, template-haskell, base >= 4 && < 5, syb, containers, array, random, directory, bytestring, mtl, html, pretty, hashable, transformers Exposed-modules: MagicHaskeller, Control.Monad.Search.Combinatorial, Control.Monad.Search.Best, MagicHaskeller.ProgramGenerator, MagicHaskeller.ProgGen, MagicHaskeller.ProgGenSF,- MagicHaskeller.ProgGenSFIORef, MagicHaskeller.Expression, MagicHaskeller.LibTH, MagicHaskeller.Analytical, MagicHaskeller.Options, MagicHaskeller.Classification, MagicHaskeller.GetTime, MagicHaskeller.Minimal, MagicHaskeller.IOGenerator, MagicHaskeller.FastRatio, MagicHaskeller.LibExcel, MagicHaskeller.CoreLang, MagicHaskeller.Individual, MagicHaskeller.PolyDynamic, MagicHaskeller.Instantiate, MagicHaskeller.TICE+ MagicHaskeller.ProgGenSFIORef, MagicHaskeller.Expression, MagicHaskeller.LibTH, MagicHaskeller.Analytical, MagicHaskeller.Options, MagicHaskeller.Classification, MagicHaskeller.GetTime, MagicHaskeller.Minimal,+-- MagicHaskeller.IOGenerator,+ MagicHaskeller.FastRatio, MagicHaskeller.LibExcel, MagicHaskeller.CoreLang, MagicHaskeller.Individual, MagicHaskeller.PolyDynamic, MagicHaskeller.Instantiate, MagicHaskeller.TICE, MagicHaskeller.MyCheck Other-modules: MagicHaskeller.MemoToFiles, MagicHaskeller.ShortString, MagicHaskeller.Types, MagicHaskeller.PriorSubsts, Data.Memo, MagicHaskeller.ClassifyTr, MagicHaskeller.DebMT, MagicHaskeller.TyConLib, MagicHaskeller.FakeDynamic, MagicHaskeller.ReadTypeRep, MagicHaskeller.ReadTHType, MagicHaskeller.TimeOut, MagicHaskeller.Execute, MagicHaskeller.T10,- MagicHaskeller.Classify, MagicHaskeller.MHTH, MagicHaskeller.MyCheck,+ MagicHaskeller.Classify, MagicHaskeller.MHTH, MagicHaskeller.ExprStaged, MagicHaskeller.Combinators, MagicHaskeller.ReadDynamic, MagicHaskeller.MyDynamic, MagicHaskeller.ClassifyDM, MagicHaskeller.Analytical.FMExpr, MagicHaskeller.Analytical.Parser, MagicHaskeller.Analytical.Syntax, MagicHaskeller.Analytical.UniT, MagicHaskeller.Analytical.Synthesize,- MagicHaskeller.ExpToHtml, MagicHaskeller.FMType, MagicHaskeller.NearEq, MagicHaskeller.ClassLib, MagicHaskeller.LibExcelStaged,+-- MagicHaskeller.ExpToHtml,+ MagicHaskeller.FMType, MagicHaskeller.NearEq, MagicHaskeller.ClassLib, MagicHaskeller.LibExcelStaged, Paths_MagicHaskeller, MagicHaskeller.VersionInfo default-extensions: CPP, TemplateHaskell cpp-options: -DCHTO -DCABAL@@ -74,10 +81,17 @@ if flag(TFRANDOM) Build-depends: tf-random <= 0.3 || >= 0.5 cpp-options: -DTFRANDOM+ else+ Build-depends: random >= 1.2.0, splitmix - if flag(GHCAPI) && !os(windows)- Build-depends: ghc >= 6.10, ghc-paths+ if flag(GHCAPI) && !os(windows) && !impl(ghcjs)+ Build-depends: ghc-paths Exposed-modules: MagicHaskeller.RunAnalytical, MagicHaskeller.ExecuteAPI610+ if flag(GHCAPICompat)+ Build-depends: ghc >= 8.10, ghc-api-compat+ cpp-options: -DGHCAPICOMPAT+ else+ Build-depends: ghc >= 6.10 && < 8.10 if flag(READFILE) Build-depends: haskell-src@@ -92,11 +106,6 @@ if flag(DEBUG) cpp-options: -DREALDYNAMIC - if flag(NETWORKURI)- Build-depends: network >= 2.6 && < 3.0, network-uri >= 2.6- else- Build-depends: network < 2.6, network-uri < 2.6- if flag(SEMIGROUP) Build-depends: base >= 4.11 cpp-options: -DSEMIGROUP@@ -106,7 +115,7 @@ Executable MagicHaskeller Main-is: Backend.hs Build-depends: MagicHaskeller, time, template-haskell, base >= 4 && < 5, syb, containers, array, random, directory, bytestring, mtl, html, pretty, hashable, process, monad-par, transformers, abstract-par, ghc-paths, ghc- Other-modules: MagicHaskeller.SimpleServer+ Other-modules: MagicHaskeller.SimpleServer, MagicHaskeller.ExpToHtml GHC-options: -threaded -feager-blackholing -rtsopts default-extensions: CPP, TemplateHaskell cpp-options: -DCHTO -DCABAL@@ -132,7 +141,7 @@ cpp-options: -DREALDYNAMIC if flag(NETWORKURI)- Build-depends: network >= 2.6 && < 3.0, network-uri >= 2.6+ Build-depends: network >= 2.6 && < 3.2, network-uri >= 2.6 else Build-depends: network < 2.6, network-uri < 2.6 @@ -148,8 +157,8 @@ Main-is: CGI.lhs Build-depends: time, template-haskell, base >= 4 && < 5, syb, containers, array, random, directory, bytestring, mtl, html, pretty, hashable, MagicHaskeller, cgi, hint, extensible-exceptions, haskell-src- Other-modules: MagicHaskeller.CGI-+ Other-modules: MagicHaskeller.CGI, MagicHaskeller.ExpToHtml, MagicHaskeller.IOGenerator+ default-extensions: CPP cpp-options: -DCHTO -DCABAL default-language: Haskell2010 @@ -165,7 +174,7 @@ cpp-options: -DREALDYNAMIC if flag(NETWORKURI)- Build-depends: network >= 2.6 && < 3.0, network-uri >= 2.6+ Build-depends: network >= 2.6 && < 3.2, network-uri >= 2.6 else Build-depends: network < 2.6, network-uri < 2.6
MagicHaskeller.lhs view
@@ -54,8 +54,8 @@ -- second element the second greatest priority, and so on. mkPGX, mkPGXOpt, - mkPGXOpts, updatePGXOpts, updatePGXOptsFilt,- Options, Opt(..), options, MemoType(..),+ mkPGXOpts, mkPGXOptsExt, updatePGXOpts, updatePGXOptsFilt,+ Options, Opt(..), options, MemoType(..), dynamic, -- | These are versions for 'ProgramGeneratorIO'. mkPGIO, mkPGXOptIO,@@ -124,7 +124,7 @@ fpartialParIO, mapParIO, #endif -- other stuff which will not be documented by Haddock- unsafeCoerce#, {- unifyablePos, -} exprToTHExp, trToTHType, printAny, p1, Filtrable, zipAppend, mapIO, fpIO, fIO, fpartial, fpartialIO, ftotalIO, etup, mkCurriedDecls+ unsafeCoerce#, {- unifyablePos, -} exprToTHExp, trToTHType, printAny, p1, Filtrable, zipAppend, mapIO, fpIO, fIO, fpartial, fpartialIO, ftotalIO, etup, mkCurriedDecls, unJust, tup ) where import Data.Generics(everywhere, mkT, Data)@@ -159,7 +159,7 @@ import System.IO.Unsafe(unsafePerformIO) import Data.IORef import GHC.Exts(unsafeCoerce#)--- import Maybe(fromJust)+import Data.Maybe(fromJust) import System.IO #ifdef TFRANDOM import System.Random.TF(seedTFGen,TFGen)@@ -177,7 +177,7 @@ import MagicHaskeller.Classify import MagicHaskeller.ClassifyDM(filterDM) import MagicHaskeller.Classification(unsafeRandomTestFilter, Filtrable)-import MagicHaskeller.Instantiate(mkRandTrie)+-- import MagicHaskeller.Instantiate(mkRandTrie) import MagicHaskeller.MemoToFiles(MemoType(..)) import Data.List(genericLength, transpose)@@ -196,10 +196,18 @@ \end{code} \begin{code}+#if __GLASGOW_HASKELL__ >= 810+tup = TupE . map Just+unJust = fromJust+#else+tup = TupE+unJust = id+#endif+ mkCurriedDecls :: String -> ExpQ -> ExpQ -> DecsQ mkCurriedDecls tag funq eq = do e <- eq fun <- funq- case e of TupE es -> fmap concat $ mapM (mcd fun) es+ case e of TupE es -> fmap concat $ mapM (mcd fun. unJust) es _ -> mcd fun e where mcd :: Exp -> Exp -> DecsQ mcd fun v@(VarE name) = let nb = nameBase name@@ -259,7 +267,7 @@ -- | 'p' is used to convert your primitive component set into the internal form. 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)+p eq = eq >>= \e -> case e of TupE es -> (return . ListE) =<< mapM (p1.unJust) 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 (SigE e ty) = p1' (SigE e $ useArrowT ty) e ty@@ -454,8 +462,12 @@ mkPGXOpts :: (Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]] -> a) -> Options -> [Primitive] -> [(Primitive,Primitive)] -> [[Primitive]] -> [[(Primitive,Primitive)]] -> a-mkPGXOpts mkt opt classes partclasses prims partprims- = let cmn = initCommon opt (classes ++ concat prims ++ map fst (partclasses ++ concat partprims))+mkPGXOpts = mkPGXOptsExt (\_ -> repeat []) (\_ -> repeat []) (\_ -> repeat [])+mkPGXOptsExt :: (TyConLib -> [[(String,Dynamic)]]) -> (TyConLib -> [[(String,Dynamic)]]) -> (TyConLib -> [[(String,Dynamic)]])+ -> (Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]] -> a)+ -> Options -> [Primitive] -> [(Primitive,Primitive)] -> [[Primitive]] -> [[(Primitive,Primitive)]] -> a+mkPGXOptsExt cmpExt arbExt coarbExt mkt opt classes partclasses prims partprims+ = let cmn = initCommonExt cmpExt arbExt coarbExt opt (classes ++ concat prims ++ map fst (partclasses ++ concat partprims)) ptd = primitiveToDynamic (tcl cmn) in updatePGXOpts mkt (primopt opt) [ ptd cl | cl <- classes ]
MagicHaskeller/Analytical.hs view
@@ -30,7 +30,7 @@ import MagicHaskeller.ReadTHType(typeToTHType) import MagicHaskeller.MHTH(decsToExpDecs) -import MagicHaskeller(p1)+import MagicHaskeller(p1, tup) import MagicHaskeller.Analytical.Synthesize #ifdef DEBUG@@ -88,7 +88,7 @@ c decq = do decs <- decq expdecs <- decsToExpDecs decs expPrims <- fmap ListE $ mapM p1 $ cons decs- return $ TupE [expdecs, expPrims]+ return $ tup [expdecs, expPrims] cons, conEs, conPs :: (Data a, Typeable a) => a -> [Exp] cons a = conEs a ++ conPs a
MagicHaskeller/Analytical/Parser.hs view
@@ -11,6 +11,7 @@ import qualified Data.Map as Map import qualified Data.IntMap as IntMap import Language.Haskell.TH hiding (match)+import Data.Maybe(fromJust) import MagicHaskeller.CoreLang(VarLib, Var) import qualified MagicHaskeller.Types as T@@ -23,6 +24,12 @@ import Data.Word +#if __GLASGOW_HASKELL__ >= 810+unJust = fromJust+#else+unJust = id+#endif+ data XVarLib = XVL {varLib :: VarLib, invVarLib :: Map.Map String Var, zeroID :: Var, succID :: Var, negateID :: Var} deriving Show -- We compare nameBase ignoring the module name, instead of using equivalence over Name's.@@ -203,7 +210,7 @@ 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 (TupE es) = cap () (getTypedConstr ivl (tupleDataName (length es))) (map (thExpToExpr ivl . unJust) 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]
MagicHaskeller/ExecuteAPI610.hs view
@@ -1,7 +1,7 @@ -- -- (c) Susumu Katayama ---{-# LANGUAGE TemplateHaskell, MagicHash, CPP, TypeFamilies #-}+{-# LANGUAGE TemplateHaskell, MagicHash, CPP, TypeFamilies, FlexibleContexts #-} -- TypeFamilies is only necessary with ghc>=8.6 -- compile with -package ghc module MagicHaskeller.ExecuteAPI610 {- (loadObj, prepareAPI, executeAPI, unsafeExecuteAPI) -} where@@ -42,7 +42,11 @@ import ErrUtils import StringBuffer (stringToStringBuffer) import Outputable (ppr, pprPanic, showSDocDebug, showSDoc)+#if __GLASGOW_HASKELL__ < 706 import Type (pprType, Type)+#else+import Type (Type)+#endif import CoreLint (lintUnfolding) -- import VarSet (varSetElems)@@ -73,7 +77,13 @@ import Bag import RdrName import OccName+#if __GLASGOW_HASKELL__ >= 810+import BasicTypes+import GHC.ThToHs+import GHC.Hs.Binds -- was HsBinds+#else import Convert+#endif import HsUtils import HsExpr @@ -160,14 +170,16 @@ Failed -> error "failed to load modules" -- liftIO $ hPutStrLn stderr "setting up modules"+-- Same lines (except visfss) appear in SimpleServer.hs. Consider defining a function. Note that this module would not be imported when Flag GHCAPI is False. #if __GLASGOW_HASKELL__ >= 700 modules <- mapM (\fs -> fmap (\x -> (x,Nothing)) $ findModule (mkModuleName fs) Nothing) ("Prelude":visfss)-#else- modules <- mapM (\fs -> findModule (mkModuleName fs) Nothing) ("Prelude":visfss)-#endif-#if __GLASGOW_HASKELL__ >= 700+# if __GLASGOW_HASKELL__ >= 802+ setContext [ IIDecl $ (simpleImportDecl . mkModuleName $ moduleName) | moduleName <- "Prelude":visfss ] -- idelcQualified of simpleImportDecl is False at least since 8.2, and becomes ImportDeclQualifiedStyle at ghc-api-compat+# else setContext [ IIDecl $ (simpleImportDecl . mkModuleName $ moduleName){GHC.ideclQualified = False} | moduleName <- "Prelude":visfss ] -- GHC 7.4+# endif #else+ modules <- mapM (\fs -> findModule (mkModuleName fs) Nothing) ("Prelude":visfss) setContext [] modules #endif @@ -287,6 +299,9 @@ fixIO (\hv -> linkBCO ie (extendClosureEnv ce [(nm,hv)]) ulbco) #endif +#if __GLASGOW_HASKELL__ >= 810+stmtToCore :: HscEnv -> GhciLStmt GhcPs -> IO (Maybe ([Id], CoreExpr))+#endif -- The type of LStmt has changed during move to GHC 7.8.1. -- stmtToCore :: HscEnv -> HsExpr.LStmt RdrName.RdrName -> IO (Maybe ([Id], CoreExpr)) stmtToCore hscEnv pst = do let dfs = hsc_dflags hscEnv@@ -324,29 +339,49 @@ # endif #endif +#if __GLASGOW_HASKELL__ >= 810+thExpToStmt :: HscEnv -> TH.Exp -> GhciLStmt GhcPs+#endif -- thExpToStmt :: HscEnv -> TH.Exp -> HsExpr.LStmt RdrName.RdrName thExpToStmt hscEnv = wrapLHsExpr . thExpToLHsExpr hscEnv+-- #if __GLASGOW_HASKELL__ >= 810+-- wrapLHsExpr :: HsExpr.LHsExpr GhcPs -> HsExpr.LStmt GhcPs _+-- #endif -- wrapLHsExpr :: HsExpr.LHsExpr RdrName.RdrName -> HsExpr.LStmt RdrName.RdrName wrapLHsExpr expr = noLoc $ LetStmt-#if __GLASGOW_HASKELL__ >= 806- noExt $ noLoc $ HsValBinds noExt (ValBinds noExt+#if __GLASGOW_HASKELL__ >= 806 && !defined GHCAPICOMPAT+ noExt $ noLoc $ HsValBinds noExt (ValBinds noExt (Bag.unitBag (HsUtils.mkHsVarBind noSrcSpan var expr)) []) #else # if __GLASGOW_HASKELL__ >= 800- $ noLoc+# if __GLASGOW_HASKELL__ >= 810+ noExtField $ L noSrcSpan (HsValBinds noExtField $ ValBinds noExtField (Bag.unitBag (L noSrcSpan $ VarBind noExtField var expr False)) [])+-- noExt $ noLoc $ HsValBinds (ValBinds noExtField (Bag.unitBag (HsUtils.mkHsVarBind noSrcSpan var expr)) [])+# else+ $ noLoc $ HsValBinds (ValBindsIn (Bag.unitBag (HsUtils.mkHsVarBind noSrcSpan var expr)) [])+# endif+# else+ $ HsValBinds (ValBindsIn (Bag.unitBag (HsUtils.mk_easy_FunBind noSrcSpan var [] expr)) []) # endif- $ HsValBinds (ValBindsIn #endif- (Bag.unitBag (HsUtils.mk_easy_FunBind noSrcSpan (Unqual $ mkOccName OccName.varName "__cmCompileExpr") [] expr)) [])+ where var = Unqual $ mkOccName OccName.varName "__cmCompileExpr"++#if __GLASGOW_HASKELL__ >= 810+thExpToLHsExpr :: HscEnv -> TH.Exp -> HsExpr.LHsExpr GhcPs+thExpToLHsExpr hscEnv e = case GHC.ThToHs.convertToHsExpr BasicTypes.Generated noSrcSpan e of+ Left msg -> error $ showSDoc (hsc_dflags hscEnv) msg+ Right expr -> expr+#else -- thExpToLHsExpr :: HscEnv -> TH.Exp -> HsExpr.LHsExpr RdrName.RdrName -- for old versions of GHC API -- thExpToLHsExpr :: HscEnv -> TH.Exp -> HsExpr.LHsExpr GhcPs -- for new versions of GHC API thExpToLHsExpr hscEnv e = case Convert.convertToHsExpr noSrcSpan e of-#if __GLASGOW_HASKELL__ >= 706+# if __GLASGOW_HASKELL__ >= 706 Left msg -> error $ showSDoc (hsc_dflags hscEnv) msg-#else+# else Left msg -> error $ showSDoc msg-#endif+# endif Right expr -> expr+#endif -- unused, but may be useful in future #if __GLASGOW_HASKELL__ < 706
MagicHaskeller/ExpToHtml.hs view
@@ -169,7 +169,11 @@ annotateFree names (AppE f e) = annotateFree names f `AppE` annotateFree names e annotateFree names (InfixE mbf op mbe) = InfixE (fmap (annotateFree names) mbf) (annotateFree names op) (fmap (annotateFree names) mbe) annotateFree names (LamE pats e) = LamE pats $ annotateFree (patsToNames pats names) e+#if __GLASGOW_HASKELL__ >= 810+annotateFree names (TupE es) = TupE $ map (fmap (annotateFree names)) es+#else annotateFree names (TupE es) = TupE $ map (annotateFree names) es+#endif annotateFree names (CondE b t f) = CondE (annotateFree names b) (annotateFree names t) (annotateFree names f) annotateFree names (ListE es) = ListE $ map (annotateFree names) es annotateFree names (SigE e t) = SigE (annotateFree names e) t
MagicHaskeller/Instantiate.hs view
@@ -2,7 +2,7 @@ -- (c) Susumu Katayama -- {-# LANGUAGE TemplateHaskell, RankNTypes, CPP, PatternGuards, ImpredicativeTypes #-}-module MagicHaskeller.Instantiate(mkRandTrie, RTrie, -- arbitraries,+module MagicHaskeller.Instantiate(mkRandTrie, mkRandTrieExt, RTrie, -- arbitraries, uncurryDyn, uncurryTy, mkUncurry, typeToOrd, typeToRandomsOrd, typeToRandomsOrdDM, mkCurry, curryDyn, argTypeToRandoms , typeToArb -- exported just for testing Classification.tex , PackedOrd, typeToCompare, compareRealFloat@@ -151,12 +151,15 @@ Tries, MapType (Dynamic,Dynamic)) mkRandTrie :: [Int] -> TyConLib -> Generator -> RTrie-mkRandTrie nrnds tcl gen- = let arbtup = mkArbMap tcl- coarbtup = mkCoarbMap tcl+mkRandTrie = mkRandTrieExt (repeat []) (repeat []) (repeat [])+-- | @mkRandTrieExt@ is an extensible version of 'mkRandTrie' that can be used with various types including user-defined ones.+mkRandTrieExt :: [[(String,Dynamic)]] -> [[(String,Dynamic)]] -> [[(String,Dynamic)]] -> [Int] -> TyConLib -> Generator -> RTrie+mkRandTrieExt cmpExt arbExt coarbExt nrnds tcl gen+ = let arbtup = mkArbMapExt arbExt tcl+ coarbtup = mkCoarbMapExt coarbExt tcl (g0,g1) = split gen maps = (arbtup, coarbtup, g0, g1)- cmap = mkCmpMap tcl+ cmap = mkCmpMapExt cmpExt tcl mmap = mkMemoMap tcl in (cmap, maps, mmap, (mkMT tcl (argTypeToRandoms tcl cmap maps), mkMT tcl (argTypeToRandomss nrnds tcl cmap maps)),@@ -183,7 +186,9 @@ mkMap :: TyConLib -> [[(String,a)]] -> MapTC a mkMap tcl@(mapNameTyCon,_) mcts = IntMap.fromAscList $ zip [0..] $ map (IntMap.fromList . map (\ (name, dyn) -> (fromIntegral (mapNameTyCon Map.! name), dyn))) mcts mkCmpMap :: TyConLib -> CmpMap-mkCmpMap tcl = (mkMap tcl [mct0, mct1, mct2],+mkCmpMap = mkCmpMapExt $ repeat []+mkCmpMapExt :: [[(String,Dynamic)]] -> TyConLib -> CmpMap+mkCmpMapExt ext tcl = (mkMap tcl $ zipWith (++) [mct0, mct1, mct2] ext, mkSpecialMap tcl [("Ratio", "Int", $(dynamic [|tcl|] [| compareRatio :: Ratio Int -> Ratio Int -> Ordering |])), ("Ratio", "Integer", $(dynamic [|tcl|] [| compareRatio :: Ratio Integer -> Ratio Integer -> Ordering |]))], cmpChar)@@ -254,7 +259,9 @@ type CoarbMap = (MapTC Dynamic, SpecialMap, Dynamic, Dynamic) mkArbMap :: TyConLib -> ArbMap-mkArbMap tcl@(mapNameTyCon,_) = (mkMap tcl [mct0, mct1, mct2, mct3],+mkArbMap = mkArbMapExt $ repeat []+mkArbMapExt :: [[(String,Dynamic)]] -> TyConLib -> ArbMap+mkArbMapExt ext tcl@(mapNameTyCon,_) = (mkMap tcl $ zipWith (++) [mct0, mct1, mct2, mct3] ext, mkSpecialMap tcl [("Ratio", "Int", $(dynamic [|tcl|] [| arbitraryRatio :: Gen (Ratio Int) |])), ("Ratio", "Integer", $(dynamic [|tcl|] [| arbitraryRatio :: Gen (Ratio Integer) |]))], arbChar, -- same as the Char case@@ -315,7 +322,9 @@ dynApp arb0 arb1) tta _ _ = Nothing mkCoarbMap :: TyConLib -> CoarbMap-mkCoarbMap tcl@(mapNameTyCon,_) = (mkMap tcl [mct0, mct1, mct2, mct3],+mkCoarbMap = mkCoarbMapExt $ repeat []+mkCoarbMapExt :: [[(String,Dynamic)]] -> TyConLib -> CoarbMap+mkCoarbMapExt ext tcl@(mapNameTyCon,_) = (mkMap tcl $ zipWith (++) [mct0, mct1, mct2, mct3] ext, mkSpecialMap tcl [("Ratio", "Int", $(dynamic [|tcl|] [| coarbitraryRatio :: Ratio Int -> Gen x -> Gen x |])), ("Ratio", "Integer", $(dynamic [|tcl|] [| coarbitraryRatio :: Ratio Integer -> Gen x -> Gen x |]))], coarbChar, -- same as the Char case
MagicHaskeller/LibExcel.hs view
@@ -42,13 +42,13 @@ where nb = nameBase name ppExcel (AppE (AppE (AppE (InfixE (Just e1) (VarE name) (Just e2)) e3) e4) e5) | nameBase name == "." = ppExcel $ ((e1 `AppE` (e2 `AppE` e3)) `AppE` e4) `AppE` e5 -- ad hoc pattern:S ppExcel (AppE (AppE (InfixE (Just e1) (VarE name) (Just e2)) e3) e4) | nameBase name == "." = ppExcel $ (e1 `AppE` (e2 `AppE` e3)) `AppE` e4-ppExcel (AppE (AppE (AppE (AppE (ConE name) e1) e2) e3) e4) | nameBase name == "(,,,)" = ppExcel $ TupE [e1, e2, e3, e4]+ppExcel (AppE (AppE (AppE (AppE (ConE name) e1) e2) e3) e4) | nameBase name == "(,,,)" = ppExcel $ tup [e1, e2, e3, e4] ppExcel (AppE (AppE (AppE (AppE (VarE name) e1) e2) e3) e4) | nb == "flip" = ppExcel $ ((e1 `AppE` e3) `AppE` e2) `AppE` e4 | nb == "sUBST4" = mkUncurried "sUBSTITUTE" (map ppExcel [e1, e2, e3, mkVarOp lit1 "+" (absE `AppE` e4)]) | Just stem <- stripPrefix "4'" $ reverse nb = mkUncurried (reverse stem) (map ppExcel [e1, e2, e3, e4]) where nb = nameBase name ppExcel (AppE (InfixE (Just e1) (VarE name) (Just e2)) e3) | nameBase name == "." = ppExcel $ e1 `AppE` (e2 `AppE` e3)-ppExcel (AppE (e@(AppE (AppE (ConE name) p) t)) f) | nameBase name == "(,,)" = ppExcel $ TupE [p,t,f]+ppExcel (AppE (e@(AppE (AppE (ConE name) p) t)) f) | nameBase name == "(,,)" = ppExcel $ tup [p,t,f] ppExcel (AppE (e@(AppE (AppE (VarE name) p) t)) f) = case reverse $ nameBase name of "xIdnif" -> mkVarOp (mkUncurried "finD" [char7, mkUncurried "sUBSTITUTE" [mkUncurried "concatenate" [ppp,ppt], ppp, char7, ppExcel $ mkVarOp lit1 "+" (absE `AppE` f) ]]) "-" lit1 -- The "findIx" case. findIx c xs n = finD(char(7), sUBSTITUTE(concatenate(c,xs), c, char(7), 1+abs(n)))-1@@ -59,7 +59,7 @@ where ppp = ppExcel p ppt = ppExcel t ppf = ppExcel f-ppExcel (AppE f@(AppE (ConE name) lj) e) | nameBase name == "(,)" = ppExcel $ TupE [lj, e]+ppExcel (AppE f@(AppE (ConE name) lj) e) | nameBase name == "(,)" = ppExcel $ tup [lj, e] ppExcel (AppE (AppE (VarE name) e1) e2) | nb == "fLOOR0" = case ppe2 of LitE (IntegerL n) | n>0 -> floore1e2 | otherwise -> lit0 LitE (RationalL n) | n>0 -> floore1e2@@ -106,12 +106,12 @@ ListE es -> ListE $ take 1 $ map ppExcel es ArithSeqE (FromToR (LitE (IntegerL f)) (LitE (IntegerL t))) -> ListE [LitE $ IntegerL f] AppE (VarE name) e' | nameBase name == "left1" -> ppe- _ -> AppE leftE $ TupE [ppe, LitE $ IntegerL 1]+ _ -> AppE leftE $ tup [ppe, LitE $ IntegerL 1] "right1" -> case ppe of LitE (StringL xs) -> LitE $ StringL $ right(xs,1) ListE es -> ListE $ right(map ppExcel es, 1) AppE (VarE name) e' | nameBase name == "right1" -> ppe- _ -> AppE rightE $ TupE [ppe, LitE $ IntegerL 1]+ _ -> AppE rightE $ tup [ppe, LitE $ IntegerL 1] "reverse" -> case ppe of LitE (StringL xs) -> LitE $ StringL $ reverse xs ListE es -> ListE $ reverse $ map ppExcel es@@ -164,7 +164,7 @@ ppExcel (LamE pats e) = LamE pats (ppExcel e) -ppExcel (TupE es) = TupE (map ppExcel es)+ppExcel (TupE es) = tup (map (ppExcel.unJust) es) ppExcel (ListE es) = ListE (map ppExcel es) ppExcel (SigE e ty) = ppExcel e `SigE` ty ppExcel e = e@@ -202,8 +202,8 @@ lenE = VarE $ mkName "len" absE = VarE $ mkName "abs" -mkIF p t f = VarE (mkName "iF") `AppE` TupE [p, t, f]-mkUncurried str es = VarE (mkName str) `AppE` TupE es+mkIF p t f = VarE (mkName "iF") `AppE` tup [p, t, f]+mkUncurried str es = VarE (mkName str) `AppE` tup es mkSUBST4 = mkUncurried "sUBSTITUTE" mkVarOp e1 op e2 = InfixE (Just e1) (VarE $ mkName op) (Just e2)
MagicHaskeller/LibTH.hs view
@@ -137,10 +137,10 @@ -- | 'postprocess' replaces uncommon functions like catamorphisms with well-known functions. postprocess :: Exp -> Exp postprocess (AppE (AppE (AppE (InfixE (Just e1) (VarE name) (Just e2)) e3) e4) e5) | nameBase name == "." = postprocess $ ((e1 `AppE` (e2 `AppE` e3)) `AppE` e4) `AppE` e5 -- ad hoc pattern:S-postprocess (AppE (AppE (AppE (AppE (ConE name) e1) e2) e3) e4) | nameBase name == "(,,,)" = postprocess $ TupE [e1, e2, e3, e4]+postprocess (AppE (AppE (AppE (AppE (ConE name) e1) e2) e3) e4) | nameBase name == "(,,,)" = postprocess $ tup [e1, e2, e3, e4] postprocess (AppE (AppE (AppE (AppE (VarE name) e1) e2) e3) e4) | nameBase name == "flip" = postprocess $ ((e1 `AppE` e3) `AppE` e2) `AppE` e4 postprocess (AppE (InfixE (Just e1) (VarE name) (Just e2)) e3) | nameBase name == "." = postprocess $ e1 `AppE` (e2 `AppE` e3)-postprocess (AppE (e@(AppE (AppE (ConE name) p) t)) f) | nameBase name == "(,,)" = postprocess $ TupE [p,t,f]+postprocess (AppE (e@(AppE (AppE (ConE name) p) t)) f) | nameBase name == "(,,)" = postprocess $ tup [p,t,f] postprocess (AppE (e@(AppE (AppE (VarE name) p) t)) f) = case nameBase name of "iF" -> CondE ppp ppt ppf@@ -155,7 +155,7 @@ where ppp = postprocess p ppt = postprocess t ppf = postprocess f-postprocess (AppE f@(AppE (ConE name) lj) e) | nameBase name == "(,)" = postprocess $ TupE [lj, e]+postprocess (AppE f@(AppE (ConE name) lj) e) | nameBase name == "(,)" = postprocess $ tup [lj, e] postprocess (AppE f@(AppE (VarE name) lj) e) = case nameBase name of "drop" -> case pplj of LitE (IntegerL j) | j<=0 -> ppe | j> 0 -> ppdrop j e@@ -249,7 +249,7 @@ postprocess (LamE pats e) = ppLambda pats (postprocess e) -postprocess (TupE es) = TupE (map postprocess es)+postprocess (TupE es) = tup (map (postprocess.unJust) es) postprocess (ListE es) = ListE (map postprocess es) postprocess (SigE e ty) = postprocess e `SigE` ty postprocess e = e@@ -365,7 +365,7 @@ fmapM f (Just x) = fmap Just (f x) in liftM2 (\e1 e2 -> InfixE e1 op e2) (fmapM postprocessQ me1) (fmapM postprocessQ me2) postprocessQ (LamE pats e) = fmap (LamE pats) (postprocessQ e)-postprocessQ (TupE es) = fmap TupE (mapM postprocessQ es)+postprocessQ (TupE es) = fmap tup (mapM (postprocessQ.unJust) es) postprocessQ (ListE es) = fmap ListE (mapM postprocessQ es) postprocessQ (SigE e ty) = fmap (`SigE` ty) (postprocessQ e) postprocessQ e = return e
MagicHaskeller/MHTH.lhs view
@@ -12,7 +12,7 @@ import Data.IORef -- import Types import Control.Monad(liftM)-+import Data.Maybe(fromJust) import MagicHaskeller.ReadTHType(showTypeName, plainTV, unPlainTV) @@ -38,7 +38,13 @@ expToExpExp (InfixE (Just e0) e Nothing) = [| InfixE (Just $(expToExpExp e0)) $(expToExpExp e) Nothing |] expToExpExp (InfixE Nothing e (Just e1)) = [| InfixE Nothing $(expToExpExp e) (Just $(expToExpExp e1)) |] expToExpExp (InfixE (Just e0) e (Just e1)) = [| InfixE (Just $(expToExpExp e0)) $(expToExpExp e) (Just $(expToExpExp e1)) |]+#if __GLASGOW_HASKELL__ >= 810+expToExpExp (TupE es) = [| TupE $(do ees <- mapM (expToExpExp.fromJust) es -- Tuple section not considered, causing error.+ jees <- sequence [ [| Just $(return ee) |] | ee <- ees ]+ return $ ListE jees ) |]+#else expToExpExp (TupE es) = [| TupE $((return . ListE) =<< mapM expToExpExp es) |]+#endif expToExpExp (CondE e0 e1 e2) = [| CondE $(expToExpExp e0) $(expToExpExp e1) $(expToExpExp e2) |] expToExpExp (ListE es) = [| ListE $((return . ListE) =<< mapM expToExpExp es) |] expToExpExp e@(LitE (CharL c)) = [| LitE (CharL $(return e)) |]
MagicHaskeller/ProgramGenerator.lhs view
@@ -5,7 +5,7 @@ \begin{code} {-# OPTIONS -cpp #-} -module MagicHaskeller.ProgramGenerator where+module MagicHaskeller.ProgramGenerator(module MagicHaskeller.ProgramGenerator, dynamic) where import MagicHaskeller.Types import MagicHaskeller.TyConLib import Control.Monad@@ -84,10 +84,12 @@ = let cmn = initCommon opts totals in updateCommon (map (primitiveToDynamic $ tcl cmn) totals) (map (primitiveToDynamic $ tcl cmn) partials) priorities cmn initCommon :: Options -> [Primitive] -> Common-initCommon opts totals = let+initCommon = initCommonExt (\_ -> repeat []) (\_ -> repeat []) (\_ -> repeat [])+initCommonExt :: (TyConLib -> [[(String,Dynamic)]]) -> (TyConLib -> [[(String,Dynamic)]]) -> (TyConLib -> [[(String,Dynamic)]]) -> Options -> [Primitive] -> Common+initCommonExt cmpExt arbExt coarbExt opts totals = let tyconlib = primitivesToTCL totals optunit = forget opts- in Cmn {opt = optunit, tcl = tyconlib, rt = mkRandTrie (nrands opts) tyconlib (stdgen opts)}+ in Cmn {opt = optunit, tcl = tyconlib, rt = mkRandTrieExt (cmpExt tyconlib) (arbExt tyconlib) (coarbExt tyconlib) (nrands opts) tyconlib (stdgen opts)} -- | 'updateCommon' can be used for incremetal learning updateCommon :: [PD.Dynamic] -> [PD.Dynamic] -> [Int] -> Common -> Common updateCommon totals partials priorities cmn = cmn{vl = dynamicsToVL totals, pvl = dynamicsToVL partials, vpl = prioritiesToVPL priorities}
MagicHaskeller/ReadHsType.hs view
@@ -8,7 +8,11 @@ -- | @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+readHsTypeSigs str = TupE [+#if __GLASGOW_HASKELL__ >= 810+ Just $+#endif+ mkSigE hsname hsqty | HsTypeSig _loc hsnames hsqty <- readHsDecls str , hsname <- hsnames ]
MagicHaskeller/SimpleServer.hs view
@@ -479,12 +479,13 @@ #if __GLASGOW_HASKELL__ >= 700 modules <- mapM (\fs -> fmap (\x -> (x,Nothing)) $ findModule (mkModuleName fs) Nothing) ("Prelude":allfss)-#else- modules <- mapM (\fs -> findModule (mkModuleName fs) Nothing) ("Prelude":allfss)-#endif-#if __GLASGOW_HASKELL__ >= 700+# if __GLASGOW_HASKELL__ >= 802+ setContext [ IIDecl $ (simpleImportDecl . mkModuleName $ moduleName) | moduleName <- "Prelude":allfss ] -- idelcQualified of simpleImportDecl is False at least since 8.2, and becomes ImportDeclQualifiedStyle at ghc-api-compat+# else setContext [ IIDecl $ (simpleImportDecl . mkModuleName $ moduleName){GHC.ideclQualified = False} | moduleName <- "Prelude":allfss ] -- GHC 7.4+# endif #else+ modules <- mapM (\fs -> findModule (mkModuleName fs) Nothing) ("Prelude":allfss) setContext [] modules #endif