diff --git a/MagicHaskeller.cabal b/MagicHaskeller.cabal --- a/MagicHaskeller.cabal +++ b/MagicHaskeller.cabal @@ -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 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 diff --git a/MagicHaskeller.lhs b/MagicHaskeller.lhs --- a/MagicHaskeller.lhs +++ b/MagicHaskeller.lhs @@ -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 ] diff --git a/MagicHaskeller/Analytical.hs b/MagicHaskeller/Analytical.hs --- a/MagicHaskeller/Analytical.hs +++ b/MagicHaskeller/Analytical.hs @@ -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 diff --git a/MagicHaskeller/Analytical/Parser.hs b/MagicHaskeller/Analytical/Parser.hs --- a/MagicHaskeller/Analytical/Parser.hs +++ b/MagicHaskeller/Analytical/Parser.hs @@ -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] diff --git a/MagicHaskeller/ExecuteAPI610.hs b/MagicHaskeller/ExecuteAPI610.hs --- a/MagicHaskeller/ExecuteAPI610.hs +++ b/MagicHaskeller/ExecuteAPI610.hs @@ -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 diff --git a/MagicHaskeller/ExpToHtml.hs b/MagicHaskeller/ExpToHtml.hs --- a/MagicHaskeller/ExpToHtml.hs +++ b/MagicHaskeller/ExpToHtml.hs @@ -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 diff --git a/MagicHaskeller/Instantiate.hs b/MagicHaskeller/Instantiate.hs --- a/MagicHaskeller/Instantiate.hs +++ b/MagicHaskeller/Instantiate.hs @@ -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 diff --git a/MagicHaskeller/LibExcel.hs b/MagicHaskeller/LibExcel.hs --- a/MagicHaskeller/LibExcel.hs +++ b/MagicHaskeller/LibExcel.hs @@ -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) diff --git a/MagicHaskeller/LibTH.hs b/MagicHaskeller/LibTH.hs --- a/MagicHaskeller/LibTH.hs +++ b/MagicHaskeller/LibTH.hs @@ -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 diff --git a/MagicHaskeller/MHTH.lhs b/MagicHaskeller/MHTH.lhs --- a/MagicHaskeller/MHTH.lhs +++ b/MagicHaskeller/MHTH.lhs @@ -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)) |] diff --git a/MagicHaskeller/ProgramGenerator.lhs b/MagicHaskeller/ProgramGenerator.lhs --- a/MagicHaskeller/ProgramGenerator.lhs +++ b/MagicHaskeller/ProgramGenerator.lhs @@ -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} diff --git a/MagicHaskeller/ReadHsType.hs b/MagicHaskeller/ReadHsType.hs --- a/MagicHaskeller/ReadHsType.hs +++ b/MagicHaskeller/ReadHsType.hs @@ -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 ] diff --git a/MagicHaskeller/SimpleServer.hs b/MagicHaskeller/SimpleServer.hs --- a/MagicHaskeller/SimpleServer.hs +++ b/MagicHaskeller/SimpleServer.hs @@ -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