diff --git a/MagicHaskeller.cabal b/MagicHaskeller.cabal --- a/MagicHaskeller.cabal +++ b/MagicHaskeller.cabal @@ -1,5 +1,5 @@ Name: MagicHaskeller -Version: 0.9.6.6 +Version: 0.9.6.6.1 Cabal-Version: >= 1.8 License: BSD3 License-file: LICENSE @@ -17,7 +17,7 @@ Category: Language data-files: ExperimIOP.hs MagicHaskeller/predicates MagicHaskeller/predicatesAug2014 MagicHaskeller.conf MagicHaskeller/predicatesServed primitives.txt Extra-source-files: xlmap changelog.txt -Tested-with: GHC == 7.6.3, GHC == 7.10.3 +Tested-with: GHC == 7.6.3, GHC == 7.10.3, GHC == 8.0.2 Flag TFRANDOM Description: Use the tf-random package instead of the random package diff --git a/MagicHaskeller.lhs b/MagicHaskeller.lhs --- a/MagicHaskeller.lhs +++ b/MagicHaskeller.lhs @@ -259,9 +259,19 @@ _ -> (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 -p1 e@(ConE name) = do DataConI _ ty _ _ <- reify name +p1 e@(ConE name) = do +#if __GLASGOW_HASKELL__ < 800 + DataConI _ ty _ _ <- reify name +#else + DataConI _ ty _ <- reify name +#endif p1' e e ty -p1 e@(VarE name) = do VarI _ ty _ _ <- reify name +p1 e@(VarE name) = do +#if __GLASGOW_HASKELL__ < 800 + VarI _ ty _ _ <- reify name +#else + VarI _ ty _ <- reify name +#endif p1' e e ty p1 e = [| (HV (unsafeCoerce# $(return e)), $(expToExpExp e), trToTHType (typeOf $(return e))) |] diff --git a/MagicHaskeller/ExecuteAPI610.hs b/MagicHaskeller/ExecuteAPI610.hs --- a/MagicHaskeller/ExecuteAPI610.hs +++ b/MagicHaskeller/ExecuteAPI610.hs @@ -41,7 +41,7 @@ import ErrUtils import StringBuffer (stringToStringBuffer) import Outputable (ppr, pprPanic, showSDocDebug, showSDoc) -import TypeRep (pprType, Type) +import Type (pprType, Type) import CoreLint (lintUnfolding) import VarSet (varSetElems) @@ -88,7 +88,16 @@ import UniqSupply import ByteCodeLink(linkBCO,extendClosureEnv) +#ifdef PRELINK +# if __GLASGOW_HASKELL__ >= 800 +import ByteCodeTypes(UnlinkedBCO(unlinkedBCOName)) +# else import ByteCodeAsm(UnlinkedBCO(unlinkedBCOName)) +# endif +#endif +# if __GLASGOW_HASKELL__ >= 800 +import GHCi(wormhole) +#endif import Data.Array @@ -173,7 +182,11 @@ #if __GLASGOW_HASKELL__ < 710 packageNameToFlag = ExposePackage #else +# if __GLASGOW_HASKELL__ < 800 packageNameToFlag name = ExposePackage (PackageArg name) (ModRenaming False []) -- I am not sure this is the correct conversion, because I could not find any documentation on the change. +# else +packageNameToFlag name = ExposePackage ("-package "++name) (PackageArg name) (ModRenaming False []) -- I am not sure this is the correct conversion, because I could not find any documentation on the change. +# endif #endif {- @@ -221,10 +234,14 @@ -- unwrapCore' hscEnv ce = fmap head $ unsafeCoerce# =<< HscMain.compileExpr hscEnv (srcLocSpan interactiveSrcLoc) ce -#if __GLASGOW_HASKELL__ >= 700 -ce2b dfs pe = coreExprToBCOs dfs undefined pe +#if __GLASGOW_HASKELL__ >= 800 +ce2b hscEnv pe = coreExprToBCOs hscEnv undefined pe #else -ce2b dfs pe = coreExprToBCOs dfs pe +# if __GLASGOW_HASKELL__ >= 700 +ce2b hscEnv pe = coreExprToBCOs (hsc_dflags hscEnv) undefined pe +# else +ce2b hscEnv pe = coreExprToBCOs (hsc_dflags hscEnv) pe +# endif #endif runCoreExpr, runPrepedCoreExpr :: HscEnv -> CoreExpr -> IO a @@ -238,8 +255,7 @@ pe <- corePrepExpr dfs ce -- runPrepedCoreExprとの違いはこのcorePrepExprがあるかどうかだけ #endif bcos <- -- repeatIO 10 $ - ce2b dfs pe - + ce2b hscEnv pe #ifdef PRELINK hv <- linkTheExpr bcos #else @@ -250,9 +266,7 @@ runPrepedCoreExpr hscEnv ce = -- repeatIO 10 $ do - let dfs = hsc_dflags hscEnv - - bcos <- ce2b dfs ce + bcos <- ce2b hscEnv ce -- repeatIO 10 $ #ifdef PRELINK hv <- linkTheExpr bcos @@ -312,7 +326,12 @@ -- thExpToStmt :: HscEnv -> TH.Exp -> HsExpr.LStmt RdrName.RdrName thExpToStmt hscEnv = wrapLHsExpr . thExpToLHsExpr hscEnv -- wrapLHsExpr :: HsExpr.LHsExpr RdrName.RdrName -> HsExpr.LStmt RdrName.RdrName -wrapLHsExpr expr = noLoc $ LetStmt (HsValBinds (ValBindsIn (Bag.unitBag (HsUtils.mk_easy_FunBind noSrcSpan (Unqual $ mkOccName OccName.varName "__cmCompileExpr") [] expr)) [])) +wrapLHsExpr expr = + noLoc $ LetStmt $ +#if __GLASGOW_HASKELL__ >= 800 + noLoc $ +#endif + HsValBinds (ValBindsIn (Bag.unitBag (HsUtils.mk_easy_FunBind noSrcSpan (Unqual $ mkOccName OccName.varName "__cmCompileExpr") [] expr)) []) thExpToLHsExpr :: HscEnv -> TH.Exp -> HsExpr.LHsExpr RdrName.RdrName thExpToLHsExpr hscEnv e = case Convert.convertToHsExpr noSrcSpan e of #if __GLASGOW_HASKELL__ >= 706 @@ -355,7 +374,6 @@ rtis (NonRec b e) = NonRec b (removeTInfo e) rtis (Rec ts) = Rec [ (b, removeTInfo e) | (b,e) <- ts ] -} - compileExprHscMain :: HscEnv -> CoreExpr -> IO HValue compileExprHscMain hscEnv ce = do let dflags = hsc_dflags hscEnv @@ -365,8 +383,12 @@ #else prep <- corePrepExpr dflags smpl #endif - bcos <- ce2b dflags prep + bcos <- ce2b hscEnv prep linkExpr hscEnv noSrcSpan bcos +#if __GLASGOW_HASKELL__ >= 800 + >>= wormhole dflags +#endif + #ifdef GHC6 {- diff --git a/MagicHaskeller/Individual.hs b/MagicHaskeller/Individual.hs --- a/MagicHaskeller/Individual.hs +++ b/MagicHaskeller/Individual.hs @@ -59,7 +59,7 @@ availableNames :: [String] availableNames = map fst assocAvailables --- postprocess¤ò»È¤¤¤¿¤¯¤Ê¤ë¤±¤É¡¤·ë²ÌƱ¤¸É½¸½¤Ë¤Ê¤Ã¤Á¤ã¤¦¤È¤Þ¤º¤¤¡¥ +-- postprocessを使いたくなるけど，結果同じ表現になっちゃうとまずい． pprintPrim :: Primitive -> String pprintPrim (_, e@(VarE name), t) = case nameBase name of diff --git a/MagicHaskeller/LibTH.hs b/MagicHaskeller/LibTH.hs --- a/MagicHaskeller/LibTH.hs +++ b/MagicHaskeller/LibTH.hs @@ -271,8 +271,8 @@ by1 name = name -} --- ¤³¤ÎÊÕ¤ÏCoreLang¤Ç¤ä¤ë¤Ù¤­¤È¤¤¤¦µ¤¤â¡¥¾¯¤Ê¤¯¤È¤â¡¤¤½¤Ã¤Á¤Ç´Ø¿ô¤òÄêµÁ¤¹¤Ù¤­¡¥ --- \x -> iF foo bar x ¤Î¾ì¹ç¤âÀè¤Ë¦Ç´ÊÌ󤵤ì¤Æ¤·¤Þ¤¦¤È¥¤¥Þ¥¤¥Á¤Ç¤Ï¤¢¤ë¡¥¤Î¤Ç¡¤¦Ç´ÊÌó¤ÏiF, nat_cata, tail¤Ê¤É¤Î½èÍý¤Î¸å¤Ë¤ä¤ë¡¥ +-- この辺はCoreLangでやるべきという気も．少なくとも，そっちで関数を定義すべき． +-- \x -> iF foo bar x の場合も先にη簡約されてしまうとイマイチではある．ので，η簡約はiF, nat_cata, tailなどの処理の後にやる． -- For readability, we apply eta-reduction only when we can fully eta-reduce at the outermost lambda-abstraction. ppLambda [VarP n] (AppE e (VarE n')) | shown == show n' && not (shown `appearsIn` e) = e where shown = show n @@ -397,7 +397,7 @@ -} newtype Partial a = Part {undef :: a} undefs = map (\[a,b] -> (a,b)) $ - [-- Bool や Orderingのように、ありがちな値を返してしまうものは、採用すべきでない。$(p [| (Part False :: Partial Bool, undefined :: Partial Bool) |]), $(p [| (Part EQ :: Partial Ordering, undefined :: Partial Ordering) |]), + [-- Bool や Orderingのように、ありがちな値を返してしまうものは、採用すべきでない。$(p [| (Part False :: Partial Bool, undefined :: Partial Bool) |]), $(p [| (Part EQ :: Partial Ordering, undefined :: Partial Ordering) |]), $(p [| (Part 53 :: Partial Int, undefined :: Partial Int) |]), $(p [| (Part '\29' :: Partial Char, undefined :: Partial Char) |]), $(p [| (Part [43] :: Partial [Int], undefined :: Partial [Int]) |]), @@ -508,7 +508,7 @@ by2_cmpPair (Ord compare1) (Ord compare2) = Ord $ comparePairBy compare1 compare2 comparePairBy compare1 compare2 (x,y) (z,w) = case compare1 x z of EQ -> compare2 y w o -> o -ords = $(p [| (cmp :: Ordered Bool, cmp :: Ordered Ordering, -- なぜかcomment outされていたので復活させてみた。問題あるなら戻すが。 +ords = $(p [| (cmp :: Ordered Bool, cmp :: Ordered Ordering, -- なぜかcomment outされていたので復活させてみた。問題あるなら戻すが。 cmp :: Ordered Int, cmp :: Ordered Char, -- cmp :: Ordered (Ratio Int) is defined in ratioCls by1_cmpMaybe :: Ordered a -> Ordered (Maybe a), by1_cmpList :: Ordered a -> Ordered [a], by2_cmpEither :: Ordered a -> Ordered b -> Ordered (Either a b), by2_cmpPair :: Ordered a -> Ordered b -> Ordered (a,b)) |]) @@ -649,7 +649,7 @@ -- | Library used by the program server backend pgfull :: ProgGenSF --- pgfull = mkPG ($(MagicHaskeller.LibTH.load "libsrc/PreludeList.hs") ++ mb ++ bool ++ boolean ++ $(p [| ([], (:), (+) :: Int -> Int -> Int, replicate :: Int -> a -> [a]) |]) ++ $(p [| until :: (a -> Bool) -> (a -> a) -> a -> a |]) ++ nat ++ intinst) -- rich とあまり変わらない． +-- pgfull = mkPG ($(MagicHaskeller.LibTH.load "libsrc/PreludeList.hs") ++ mb ++ bool ++ boolean ++ $(p [| ([], (:), (+) :: Int -> Int -> Int, replicate :: Int -> a -> [a]) |]) ++ $(p [| until :: (a -> Bool) -> (a -> a) -> a -> a |]) ++ nat ++ intinst) -- rich とあまり変わらない． pgfull = mkPGXOpt options{tv1=True,nrands=repeat 20,timeout=Just 100000} (eqs++ords) clspartialss full tupartialssNormal -- A pgfull must be a CAF, so we must have pgfulls and access pgfullSized via pgfulls. Directly calling pgfullSized is heap-inefficient. pgfulls :: [ProgGenSF] @@ -713,7 +713,7 @@ flip (flip . either) :: (->) (Either a b) ((a -> c) -> (b -> c) -> c)) |]) ++ intinst2 ++ $(p [| (sum :: (->) [Int] Int, product :: (->) [Int] Int) |]), list2 ++ $(p [| (scanl :: (a -> b -> a) -> a -> [b] -> [a], scanr :: (a -> b -> b) -> b -> [a] -> [b], scanl1 :: (a -> a -> a) -> [a] -> [a], scanr1 :: (a -> a -> a) -> [a] -> [a], - -- until :: (a -> Bool) -> (a -> a) -> a -> a) を入れてたが，どうもuntilがあると急に遅くなる．その割に，全く使われない．何じゃらホイ + -- until :: (a -> Bool) -> (a -> a) -> a -> a) を入れてたが，どうもuntilがあると急に遅くなる．その割に，全く使われない．何じゃらホイ show :: Int -> [Char]) |])++ $(p [| ((,) :: a -> b -> (a,b), flip uncurry :: (->) (a,b) ((a->b->c) -> c)) |]), $(p [| ((,,) :: a -> b -> c -> (a,b,c), Left :: a -> Either a b, Right :: b -> Either a b, zip :: (->) [a] ((->) [b] [(a, b)]), diff --git a/MagicHaskeller/SimpleServer.hs b/MagicHaskeller/SimpleServer.hs --- a/MagicHaskeller/SimpleServer.hs +++ b/MagicHaskeller/SimpleServer.hs @@ -404,8 +404,11 @@ #endif return $ Left (funIO, sig) +-- Note that the following causes a type mismatch with ghc>=8.0 because mkForAllTys takes TyBinder (which includes visibility info). +#if __GLASGOW_HASKELL__ < 706 -- assumes rank-1 types extractArgTy ty = case splitForAllTys ty of (tvs, fty) -> case splitFunTys fty of (args, _bool) -> mkForAllTys tvs $ mkFunTys (Prelude.init args) $ last args +#endif crlfToSpace '\n' = ' ' crlfToSpace c = c @@ -429,7 +432,12 @@ -- x # if __GLASGOW_HASKELL__ >= 708 -- x let newf = xopt_set dfs{packageFlags = [ packageNameToFlag "MagicHaskeller" ], optLevel=2, parMakeCount=Nothing} Opt_ExtendedDefaultRules -- parMakeCount=Nothing corresponds to -j. See http://downloads.haskell.org/~ghc/7.10.2/docs/html/libraries/ghc-7.10.2/DynFlags.html -- but seemingly this does not make the code faster, so is commented out. -- x # else - let newf = xopt_set dfs{packageFlags = [ packageNameToFlag "MagicHaskeller" ], optLevel=2} Opt_ExtendedDefaultRules + let newf = xopt_set dfs{packageFlags = [ packageNameToFlag "MagicHaskeller" ], optLevel=2} +# if __GLASGOW_HASKELL__ >= 800 + ExtendedDefaultRules +# else + Opt_ExtendedDefaultRules +# endif -- x # endif #else let newf = dfs{packageFlags = [ packageNameToFlag "MagicHaskeller" ], optLevel=2} @@ -452,5 +460,9 @@ #if __GLASGOW_HASKELL__ < 710 packageNameToFlag = ExposePackage #else +# if __GLASGOW_HASKELL__ < 800 packageNameToFlag name = ExposePackage (PackageArg name) (ModRenaming False []) -- I am not sure this is the correct conversion, because I could not find any documentation on the change. +# else +packageNameToFlag name = ExposePackage ("-package "++name) (PackageArg name) (ModRenaming False []) -- I am not sure this is the correct conversion, because I could not find any documentation on the change. +# endif #endif diff --git a/changelog.txt b/changelog.txt --- a/changelog.txt +++ b/changelog.txt @@ -1,3 +1,6 @@ +0.9.6.6.1: + * support GHC 8.0 + 0.9.6.6: * enable selecting functions individually