MagicHaskeller 0.9.6.4.1 → 0.9.6.4.2
raw patch · 16 files changed
+202/−62 lines, 16 files
Files
- Control/Monad/Search/Best.hs +8/−1
- Control/Monad/Search/Combinatorial.lhs +44/−12
- MagicHaskeller.cabal +6/−2
- MagicHaskeller.lhs +45/−2
- MagicHaskeller/Analytical/Parser.hs +4/−4
- MagicHaskeller/CoreLang.lhs +2/−1
- MagicHaskeller/ExecuteAPI610.hs +9/−1
- MagicHaskeller/ExpToHtml.hs +1/−0
- MagicHaskeller/LibTH.hs +1/−1
- MagicHaskeller/MHTH.lhs +3/−2
- MagicHaskeller/MyCheck.hs +6/−3
- MagicHaskeller/PriorSubsts.lhs +19/−10
- MagicHaskeller/ProgGenSF.lhs +7/−3
- MagicHaskeller/ProgramGenerator.lhs +10/−6
- MagicHaskeller/ReadTHType.lhs +1/−0
- MagicHaskeller/SimpleServer.hs +36/−14
Control/Monad/Search/Best.hs view
@@ -7,6 +7,7 @@ module Control.Monad.Search.Best where import Control.Monad import Control.Monad.Search.Combinatorial+import Control.Applicative -- necessary for backward compatibility -- | Unlike 'Matrix', 'Recomp', etc., the 'Best' monad only keeps the best set of results. -- This makes the analytical synthesis like IgorII, and the exhaustive synthesis like Djinn,@@ -23,10 +24,16 @@ instance Functor Best where fmap f (Result xs) = Result $ map f xs fmap f (Delay b) = Delay $ fmap f b+instance Applicative Best where+ pure x = Result [x]+ (<*>) = ap instance Monad Best where- return x = Result [x]+ return = pure Result xs >>= f = msum $ map f xs Delay b >>= f = Delay $ b >>= f+instance Alternative Best where+ empty = mzero+ (<|>) = mplus instance MonadPlus Best where mzero = zero Result xs `mplus` Result ys = Result $ xs++ys
Control/Monad/Search/Combinatorial.lhs view
@@ -12,6 +12,7 @@ Bag, Stream, cat, toList, getDepth, scanl1BF, zipDepthMx, zipDepthRc, zipDepth3Mx, zipDepth3Rc, scanlRc, DBound(..), DBoundT(..), zipDepthDB, DBMemo(..), Memoable(..), shrink, DB, dbtToRcT) where import Control.Monad -- hiding (join) -- ... but still collided when using Hat.+import Control.Applicative -- necessary for backward compatibility #ifdef HOOD import Observe #endif@@ -35,7 +36,7 @@ instance Monoid (Recomp a) where mempty = mzero mappend = mplus-instance Monad m => Monoid (RecompT m a) where+instance (Functor m, Monad m) => Monoid (RecompT m a) where mempty = mzero mappend = mplus @@ -61,9 +62,15 @@ instance Observable a => Observable (Matrix a) where observer (Mx a) = send "Mx" (return Mx << a) #endif+instance Applicative Matrix where+ pure x = Mx (return x : nils)+ (<*>) = ap instance Monad Matrix where- return x = Mx (return x : nils)+ return = pure Mx x >>= f = Mx (jOIN (map (fmap (unMx.f)) x))+instance Alternative Matrix where+ empty = mzero+ (<|>) = mplus instance MonadPlus Matrix where mzero = Mx nils Mx xm `mplus` Mx ym = Mx (zipWith mappend xm ym)@@ -115,15 +122,22 @@ type DepthFst = [] -- ghc6.8 does not like "type DepthFst = Stream" newtype Recomp a = Rc {unRc::Int->Bag a} newtype RecompT m a = RcT {unRcT::Int -> m (Bag a)}+instance Applicative Recomp where+ pure x = Rc f where f 0 = return x+ f _ = mempty+ (<*>) = ap instance Monad Recomp where- return x = Rc f where f 0 = return x- f _ = mempty+ return = pure Rc f >>= g = Rc ( \n -> mconcat $ map (\i -> cat $ fmap (\a -> unRc (g a) (n-i)) (f i)) [0..n] ) -- Rc f >>= g = Rc (\n -> [ y | i <- [0..n], x <- f i, y <- unRc (g x) (n-i) ]) -- Bag a = [a]$B$N>l9g!%(B -- Rc f >>= g = Rc (\n -> concat $ map (\i -> concat $ map (\a -> unRc (g a) (n-i)) (f i)) [0..n]) -- STRecomp$B$KAjEv$9$k=q$-J}!%$H$/$KCY$/$O$J$i$J$$(B....-instance Monad m => Monad (RecompT m) where- return x = RcT f where f 0 = return [x]- f _ = return []++instance (Functor m, Monad m) => Applicative (RecompT m) where+ pure x = RcT f where f 0 = return [x]+ f _ = return []+ (<*>) = ap+instance (Functor m, Monad m) => Monad (RecompT m) where+ return = pure RcT f >>= g = RcT ( \n -> let hoge i = do xs <- f i xss <- mapM (\x -> unRcT (g x) (n-i)) xs@@ -131,10 +145,16 @@ in do xss <- mapM hoge [0..n] return $ concat xss) +instance Alternative Recomp where+ empty = mzero+ (<|>) = mplus instance MonadPlus Recomp where mzero = Rc (const mempty) Rc f `mplus` Rc g = Rc (\i -> f i `mappend` g i)-instance Monad m => MonadPlus (RecompT m) where+instance (Functor m, Monad m) => Alternative (RecompT m) where+ empty = mzero+ (<|>) = mplus+instance (Functor m, Monad m) => MonadPlus (RecompT m) where mzero = RcT (const $ return []) RcT f `mplus` RcT g = RcT (\i -> do xs <- f i -- f i $B$H(B g i$B$NN>J}$r<B9T$9$k$3$H$K$J$k$1$I!$(BIO$B$G;H$&>e$G4V0c$C$F$O$$$J$$!%(B ys <- g i@@ -363,18 +383,30 @@ newtype DBound a = DB {unDB :: Int -> Bag (a, Int)} newtype DBoundT m a = DBT {unDBT :: Int -> m (Bag (a, Int))}+instance Applicative DBound where+ pure x = DB $ \n -> [(x,n)]+ (<*>) = ap instance Monad DBound where- return x = DB $ \n -> [(x,n)]+ return = pure DB p >>= f = DB $ \n -> [ (y,s) | (x,r) <- p n, (y,s) <- unDB (f x) r ]-instance Monad m => Monad (DBoundT m) where- return x = DBT $ \n -> return [(x,n)]+instance (Functor m, Monad m) => Applicative (DBoundT m) where+ pure x = DBT $ \n -> return [(x,n)]+ (<*>) = ap+instance (Functor m, Monad m) => Monad (DBoundT m) where+ return = pure DBT p >>= f = DBT $ \n -> do ts <- p n tss <- mapM (\(x,r) -> unDBT (f x) r) ts return $ concat tss+instance Alternative DBound where+ empty = mzero+ (<|>) = mplus instance MonadPlus DBound where mzero = DB $ \_ -> [] DB p1 `mplus` DB p2 = DB $ \n -> p1 n ++ p2 n-instance Monad m => MonadPlus (DBoundT m) where+instance (Functor m, Monad m) => Alternative (DBoundT m) where+ empty = mzero+ (<|>) = mplus+instance (Functor m, Monad m) => MonadPlus (DBoundT m) where mzero = DBT $ \_ -> return [] DBT p1 `mplus` DBT p2 = DBT $ \n -> liftM2 (++) (p1 n) (p2 n) instance Delay DBound where
MagicHaskeller.cabal view
@@ -1,5 +1,5 @@ Name: MagicHaskeller-Version: 0.9.6.4.1+Version: 0.9.6.4.2 Cabal-Version: >= 1.8 License: BSD3 License-file: LICENSE @@ -9,6 +9,10 @@ Homepage: http://nautilus.cs.miyazaki-u.ac.jp/~skata/MagicHaskeller.html bug-reports: mailto:skata@cs.miyazaki-u.ac.jp Synopsis: Automatic inductive functional programmer by systematic search+Description: MagicHaskeller is an inductive functional programming system for Haskell.+ This package contains the MagicHaskeller library, which can be used within GHCi or as an API for inductive program synthesis.+ It also contains the MagicHaskeller executable that is a standalone synthesis program which can be used interactively or as a backend server,+ and the MagicHaskeller.cgi executable that is a CGI frontend for providing the Web interface. Build-Type: Simple Category: Language data-files: ExperimIOP.hs MagicHaskeller/predicates MagicHaskeller/predicatesAug2014 MagicHaskeller.conf MagicHaskeller/predicatesServed@@ -37,7 +41,7 @@ Default: False Flag NETWORKURI- Description: Find Network.URI in network-uri rather than network < 2.6 (This is a workaround for the changes made in those packages.)+ Description: Find Network.URI in network-uri rather than in network < 2.6 (This is a workaround for the changes made in those packages.) Default: True -- Flag ForcibleTO
MagicHaskeller.lhs view
@@ -126,9 +126,10 @@ #endif -- other stuff which will not be documented by Haddock unsafeCoerce#, {- unifyablePos, -} exprToTHExp, trToTHType, printAny, p1, Filtrable, zipAppend, mapIO, fpIO, fIO, fpartial, fpartialIO, etup, mkCurriedDecls+ , useArrowT, uAT ) where -import Data.Generics(everywhere, mkT, Data)+import Data.Generics(everywhere, mkT, Data, gmapT) import Data.Array.IArray import MagicHaskeller.CoreLang@@ -258,7 +259,7 @@ 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! p1 :: TH.Exp -> TH.ExpQ-p1 se@(SigE e ty) = p1' se e ty+p1 (SigE e ty) = p1' (SigE e $ useArrowT ty) e ty p1 e@(ConE name) = do DataConI _ ty _ _ <- reify name p1' e e ty p1 e@(VarE name) = do VarI _ ty _ _ <- reify name@@ -266,6 +267,48 @@ p1 e = [| (HV (unsafeCoerce# $(return e)), $(expToExpExp e), trToTHType (typeOf $(return e))) |] p1' se e ty = [| (HV (unsafeCoerce# $(return se)), $(expToExpExp e), $(typeToExpType ty)) |]++useArrowT :: TH.Type -> TH.Type+useArrowT = everywhere (mkT uAT)+uAT (ConT name) | nameBase name == "(->)" = ArrowT+uAT t = t+{- + Strangely enough, GHC-7.10 (at least, GHCi, version 7.10.2.20150906) rejects (ConT GHC.Prim.(->)), while reading "(->)" to (ConT GHC.Prim.(->))++Prelude> :m +Language.Haskell.TH+Prelude Language.Haskell.TH> runQ [t| (->) Int Bool |] >>= print+AppT (AppT (ConT GHC.Prim.(->)) (ConT GHC.Types.Int)) (ConT GHC.Types.Bool)+Prelude Language.Haskell.TH> ((/=0) :: $([t| (->) Int Bool |])) 3++<interactive>:5:13:+ Illegal type constructor or class name: ¡Æ(->)¡Ç+ When splicing a TH type: GHC.Prim.(->) GHC.Types.Int GHC.Types.Bool+ In the splice: $([t| (->) Int Bool |])+Prelude Language.Haskell.TH> ((/=0) :: $([t| (->) Int|]) Bool) 3++<interactive>:7:13:+ Illegal type constructor or class name: ¡Æ(->)¡Ç+ When splicing a TH type: GHC.Prim.(->) GHC.Types.Int+ In the splice: $([t| (->) Int |])+Prelude Language.Haskell.TH> ((/=0) :: $([t| Int -> Bool |])) 3+True++ This is as opposed to the description in + https://downloads.haskell.org/~ghc/latest/docs/html/libraries/template-haskell-2.10.0.0/src/Language-Haskell-TH-Syntax.html#line-1414+ saying+ But if the original HsSyn used prefix application, we won't use+ these special TH constructors. For example+ [] t ConT "[]" `AppT` t+ (->) t ConT "->" `AppT` t+ In this way we can faithfully represent in TH whether the original+ HsType used concrete syntax or not.+ So this may be a bug, introduced when making TH more pedantic.++ Reading "(->)" to (ConT GHC.Prim.(->)) is a good news for MagicHaskeller which abuses (->) to indicate constructor consumption.+ In the case that the distinction between prefixed (->) and the infixed -> is obsoleted, we can still use + type (:-->) = (->) + but then, we need to change more code.+-} -- nameToExpName :: TH.Name -> TH.Exp -- nameToExpName = strToExpName . showName
MagicHaskeller/Analytical/Parser.hs view
@@ -40,7 +40,7 @@ extractName _ = [] parseTypedIOPairss :: (Functor m, MonadPlus m) => TyConLib -> XVarLib -> [Dec] -> PriorSubsts m [(Name, T.Typed [IOPair T.Type])] parseTypedIOPairss tcl xvl ds = inferTypedIOPairss =<< parseTypedIOPairss' tcl xvl ds-inferTypedIOPairss :: MonadPlus m => [(Name,(Maybe T.Type, Maybe (T.Typed [IOPair T.Type])))] -> PriorSubsts m [(Name, T.Typed [IOPair T.Type])]+inferTypedIOPairss :: (Functor m, MonadPlus m) => [(Name,(Maybe T.Type, Maybe (T.Typed [IOPair T.Type])))] -> PriorSubsts m [(Name, T.Typed [IOPair T.Type])] inferTypedIOPairss ((name, (Just ty, Just (iops T.::: infty))):ts) = do apinfty <- applyPS infty mguPS apinfty $ T.quantify ty@@ -100,7 +100,7 @@ -- In future where-clauses might be supported. -matchType :: MonadPlus m => [T.Type] -> T.Type -> T.Type -> PriorSubsts m ()+matchType :: (Functor m, MonadPlus m) => [T.Type] -> T.Type -> T.Type -> PriorSubsts m () matchType argtys retty ty = mguType argtys retty (T.quantify ty) >> updateSubstPS (return . unquantifySubst) unquantifySubst = map (\(v,t) -> (v, T.unquantify t)) mguType (t:ts) r (u T.:->v) = do mguPS t u@@ -110,7 +110,7 @@ mguType (_:_) _ _ = error "Not enough arguments supplied." -inferType, inferT :: MonadPlus m => Expr a -> StateT (IntMap.IntMap T.Type) (PriorSubsts m) (Expr T.Type)+inferType, inferT :: (Functor m, MonadPlus m) => Expr a -> StateT (IntMap.IntMap T.Type) (PriorSubsts m) (Expr T.Type) inferType e = do e' <- inferT e s <- lift getSubst return $ tapplyExpr s e'@@ -131,7 +131,7 @@ rty <- foldM funApM apty $ map ann es' rapty <- applyPS rty return $ C rapty sz (i T.:::apty) es'-funApM :: MonadPlus m => T.Type -> T.Type -> PriorSubsts m T.Type+funApM :: (Functor m, MonadPlus m) => T.Type -> T.Type -> PriorSubsts m T.Type funApM (a T.:-> r) t = fAM a r t funApM (a T.:> r) t = fAM a r t funApM (T.TV i) t = do tvid <- newTVar
MagicHaskeller/CoreLang.lhs view
@@ -103,7 +103,7 @@ -- Integer¤Ç¤Ê¤¯Int¤ò»È¤¦¾ì¹ç¡¤»»½Ñ±¦¥·¥Õ¥ÈshiftR¤Ç¤Ê¤¯ÏÀÍý±¦¥·¥Õ¥È¤ò»È¤¦É¬Íפ¬¤¢¤ë...¤Î¤Ï¤¤¤¤¤±¤É¡¤¤Ê¤¼¥é¥¤¥Ö¥é¥ê¤ËÏÀÍý±¦¥·¥Õ¥È¤¬¤Ê¤¤? logShiftR1 n = (n `clearBit` 0) `rotateR` 1 -}-+#if __GLASGOW_HASKELL__ < 710 instance Ord Exp where compare (VarE n0) (VarE n1) = n0 `compare` n1 compare (VarE n0) _ = LT@@ -117,6 +117,7 @@ compare (AppE _ _) _ = LT compare a b = show a `compare` show b -- ĶÃÙ¤½¤¦....+#endif instance Read Exp where readsPrec _ str = [(error "ReadS Exp is not implemented yet", str)]
MagicHaskeller/ExecuteAPI610.hs view
@@ -130,7 +130,7 @@ 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", ExposePackage "old-time", ExposePackage "ghc-paths" ] -- , ExposePackage "MagicHaskeller" ]+ packageFlags = [ packageNameToFlag "ghc", packageNameToFlag "old-time", packageNameToFlag "ghc-paths" ] -- , packageNameToFlag "MagicHaskeller" ] {- flags = Opt_TemplateHaskell : Opt_Cpp : -- Opt_FlexibleInstances : Opt_ExistentialQuantification : Opt_PolymorphicComponents : Opt_RelaxedPolyRec : Opt_MagicHash :@@ -168,6 +168,14 @@ #endif getSession++packageNameToFlag :: String -> PackageFlag+#if __GLASGOW_HASKELL__ < 710+packageNameToFlag = ExposePackage+#else+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.+#endif+ {- -- | @addNonPackageTarget@ adds a target only if the target is not a package module. -- This function assumes there is no package module in the target set of the session.
MagicHaskeller/ExpToHtml.hs view
@@ -83,6 +83,7 @@ -- Unfortunately, w3m does not understand <button>. -- mkButton sig expr body = "<button type='submit' name='predicate' value='(" ++ concatMap escapeHTML (filter (/='\n') (pprint expr)) ++ ") :: "++ sig ++ "'>Exemplify</button>"++body ++ "<br>"+mkButton :: Language -> [Char] -> [Char] -> Exp -> [Char] mkButton lang predStr sig expr | usesBlackListed expr = body ++ "<br>" | otherwise = "<FORM"++ (if isAbsent expr then " class='absent'" else "") ++">" -- ++body++" <input type='submit' value='Exemplify'>"
MagicHaskeller/LibTH.hs view
@@ -724,7 +724,7 @@ fromDataList = [$(p [| (sortBy, nubBy, deleteBy, dropWhileEnd, transpose -- , stripPrefix :: [Char]->[Char]->Maybe [Char], )|]), $(p [| (- find, flip findIndex :: (->) [a] ((a -> Bool) -> Maybe Int), flip findIndices :: (->) [a] ((a -> Bool) -> [Int]), deleteFirstsBy, unionBy :: (a -> a -> Bool) -> (->) [a] ([a] -> [a]), intersectBy :: (a -> a -> Bool) -> (->) [a] ([a] -> [a]), groupBy, insertBy -- , maximumBy, minimumBy+ find :: (a -> Bool) -> [a] -> Maybe a, flip findIndex :: (->) [a] ((a -> Bool) -> Maybe Int), flip findIndices :: (->) [a] ((a -> Bool) -> [Int]), deleteFirstsBy, unionBy :: (a -> a -> Bool) -> (->) [a] ([a] -> [a]), intersectBy :: (a -> a -> Bool) -> (->) [a] ([a] -> [a]), groupBy, insertBy -- , maximumBy, minimumBy ) |]), $(p [| (intersperse, subsequences, permutations, inits, tails,
MagicHaskeller/MHTH.lhs view
@@ -85,8 +85,8 @@ decToExpDec d = error (show d ++ " : unsupported") clauseToExpClause (Clause pats (NormalB e) decs) = [| Clause $(liftM ListE $ mapM patToExpPat pats) (NormalB $(expToExpExp e)) $(liftM ListE $ mapM decToExpDec decs) |]-#endif +#if __GLASGOW_HASKELL__ < 710 instance Ord Type where compare (ForallT _ [] t0) (ForallT _ [] t1) = compare t0 t1 compare (ForallT _ [] _) _ = GT@@ -108,5 +108,6 @@ compare _ ListT = LT compare (AppT f0 x0) (AppT f1 x1) = case compare f0 f1 of EQ -> compare x0 x1 o -> o-+#endif+#endif \end{code}
MagicHaskeller/MyCheck.hs view
@@ -23,7 +23,8 @@ #else import System.Random #endif-import Control.Monad(liftM, liftM2, liftM3)+import Control.Monad(liftM, liftM2, liftM3, ap)+import Control.Applicative -- necessary for backward compatibility import Data.Char(ord,chr) -- import Data.Ratio import MagicHaskeller.FastRatio@@ -46,9 +47,11 @@ instance Functor Gen where fmap = liftM-+instance Applicative Gen where+ pure a = Gen $ \_ _ -> a+ (<*>) = ap instance Monad Gen where- return a = Gen $ \_ _ -> a+ return = pure Gen m >>= k = Gen $ \n g -> case split g of (g1,g2) -> unGen (k (m n g1)) n g2 arbitraryR :: Random a => (a, a) -> Gen a
MagicHaskeller/PriorSubsts.lhs view
@@ -10,6 +10,7 @@ module MagicHaskeller.PriorSubsts where import Control.Monad+import Control.Applicative -- necessary for backward compatibility import Control.Monad.Search.Combinatorial -- import Control.Monad.Search.BalancedMerge import MagicHaskeller.Types@@ -25,11 +26,11 @@ -- sumPS :: [PriorSubsts Matrix a] -> PriorSubsts Matrix a -- sumPS pss = PS $ \s i -> sumMx [ f s i | PS f <- pss] -substOKPS :: Monad m => String -> PriorSubsts m ()+substOKPS :: (Functor m, Monad m) => String -> PriorSubsts m () substOKPS str = do subst <- getSubst if substOK subst then return () else error (str ++ "subst not OK. subst = "++show subst) -monsubst :: Monad m => PriorSubsts m ()+monsubst :: (Functor m, Monad m) => PriorSubsts m () monsubst = do s <- getSubst trace ("subst = "++show s) $ return () @@ -52,9 +53,13 @@ convertPS f (PS g) = PS h where h s i = f (g s i) newtype PriorSubsts m a = PS {unPS :: Subst -> TyVar -> m (a, Subst, TyVar)}-instance Monad m => Monad (PriorSubsts m) where+instance (Functor m, Monad m) => Applicative (PriorSubsts m) where+ {-# SPECIALIZE instance Applicative (PriorSubsts []) #-}+ pure x = PS (\s m -> return (x, s, m))+ (<*>) = ap+instance (Functor m, Monad m) => Monad (PriorSubsts m) where {-# SPECIALIZE instance Monad (PriorSubsts []) #-}- return x = PS (\s m -> return (x, s, m))+ return = pure PS x >>= f = PS (\s i -> do (a,t,j) <- x s i unPS (f a) t j) -- {-# INLINE (>>=) #-} °ÕÌ£¤Ê¤«¤Ã¤¿¡¥@@ -70,7 +75,11 @@ -- distPS is also used to implement ifDepthPS distPS op (PS f) (PS g) = PS (\s i -> f s i `op` g s i) -instance MonadPlus m => MonadPlus (PriorSubsts m) where+instance (Functor m, MonadPlus m) => Alternative (PriorSubsts m) where+ {-# SPECIALIZE instance Alternative (PriorSubsts []) #-}+ empty = mzero+ (<|>) = mplus+instance (Functor m, MonadPlus m) => MonadPlus (PriorSubsts m) where {-# SPECIALIZE instance MonadPlus (PriorSubsts []) #-} mzero = PS (\_ _->mzero) mplus = distPS mplus@@ -104,15 +113,15 @@ setSubst subst = updateSubstPS (\_ -> return subst) {-# SPECIALIZE mguPS :: Type -> Type -> PriorSubsts [] () #-}-mguPS, matchPS :: MonadPlus m => Type -> Type -> PriorSubsts m ()+mguPS, matchPS :: (Functor m, MonadPlus m) => Type -> Type -> PriorSubsts m () mguPS t0 t1 = do subst <- mgu t0 t1 updatePS subst -- ¤Æ¤æ¡¼¤«mgtPS¤òmguPS¤ÎÄêµÁ¤Ë¤·¤Æ¤â¤¤¤¤¤¯¤é¤¤¡¥-mgtPS :: MonadPlus m => Type -> Type -> PriorSubsts m Type+mgtPS :: (Functor m, MonadPlus m) => Type -> Type -> PriorSubsts m Type mgtPS t1 t2 = do mguPS t1 t2 applyPS t1 {-# SPECIALIZE varBindPS :: TyVar -> Type -> PriorSubsts [] () #-}-varBindPS :: MonadPlus m => TyVar -> Type -> PriorSubsts m ()+varBindPS :: (Functor m, MonadPlus m) => TyVar -> Type -> PriorSubsts m () varBindPS v t = do subst <- varBind v t updatePS subst matchPS t0 t1 = do subst <- match t0 t1@@ -124,7 +133,7 @@ setSubst s1 -} -lookupSubstPS :: MonadPlus m => TyVar -> PriorSubsts m Type+lookupSubstPS :: (Functor m, MonadPlus m) => TyVar -> PriorSubsts m Type lookupSubstPS tvid = do subst <- getSubst case lookupSubst subst tvid of Nothing -> mzero Just ty -> return ty@@ -140,7 +149,7 @@ updateMx :: Monad m => (TyVar->TyVar) -> PriorSubsts m () updateMx f = PS (\s i -> return ((), s, f i)) {-# SPECIALIZE unify :: Type -> Type -> PriorSubsts [] () #-}-unify :: MonadPlus m => Type -> Type -> PriorSubsts m ()+unify :: (Functor m, MonadPlus m) => Type -> Type -> PriorSubsts m () unify t1 t2 = do s <- getSubst u <- mgu (apply s t1) (apply s t2) updatePS u
MagicHaskeller/ProgGenSF.lhs view
@@ -40,6 +40,10 @@ import Data.Bits -- used for absence analysis import Data.Word +#if __GLASGOW_HASKELL__ >= 710+import Prelude hiding ((<$>))+#endif+ import Debug.Trace -- trace str = id @@ -306,7 +310,7 @@ funApSub_forcingNil_cont_spec clbehalf behalf = funApSub_forcingNil_cont clbehalf behalf behalf -mguAssumptionsBits :: (MonadPlus m) => Type -> [Type] -> PriorSubsts m BitSet+mguAssumptionsBits :: (Functor m, MonadPlus m) => Type -> [Type] -> PriorSubsts m BitSet mguAssumptionsBits patty assumptions = applyDo mguAssumptionsBits' assumptions patty mguAssumptionsBits' assumptions patty = msum $ zipWith (\n t -> mguPS patty t >> return (1 `shiftL` n)) [0..] assumptions @@ -405,7 +409,7 @@ -} -lookupNormalized :: MonadPlus m => (Type -> m (e, Subst, TyVar)) -> [Type] -> Type -> PriorSubsts m e+lookupNormalized :: (Functor m, MonadPlus m) => (Type -> m (e, Subst, TyVar)) -> [Type] -> Type -> PriorSubsts m e lookupNormalized fun avail t = do mx <- getMx let typ = popArgs avail t@@ -615,7 +619,7 @@ -matchAssumptionsBits :: (MonadPlus m, Expression e) => Common -> Int -> Type -> [Type] -> PriorSubsts m ([e],BitSet)+matchAssumptionsBits :: (Functor m, MonadPlus m, Expression e) => Common -> Int -> Type -> [Type] -> PriorSubsts m ([e],BitSet) matchAssumptionsBits cmn lenavails reqty assumptions = do s <- getSubst let newty = apply s reqty
MagicHaskeller/ProgramGenerator.lhs view
@@ -34,6 +34,10 @@ import Data.Array +#if __GLASGOW_HASKELL__ >= 710+import Prelude hiding ((<$>))+#endif+ -- replacement of LISTENER. Now replaced further with |guess| -- listen = False @@ -111,7 +115,7 @@ -- $B$@$+$i$3$=!$(BrunAnotherPS$BE*$K(BemptySubst$B$KBP$7$F<B9T$7$?J}$,8zN(E*$J$O$:!)(B $B$G$b!$(BSubstitution$B$C$F$=$s$J$K$G$+$/$J$i$J$+$C$?$N$G$O!)(BFiniteMap$B$G$b(Bassoc list$B$G$bJQ$o$i$J$+$C$?5$$,!%(B -applyDo :: Monad m => ([Type] -> Type -> PriorSubsts m a) -> [Type] -> Type -> PriorSubsts m a+applyDo :: (Functor m, Monad m) => ([Type] -> Type -> PriorSubsts m a) -> [Type] -> Type -> PriorSubsts m a applyDo fun avail ty = do subst <- getSubst fun (map (apply subst) avail) (apply subst ty) @@ -138,12 +142,12 @@ -- ConstrL$B$G$O(Bmatch$B$G$O%@%a!%M}M3$O(BDec. 2, 2007$B$N(Bnotes$B$r;2>H!%(B-mguAssumptions :: (MonadPlus m) => Type -> [Type] -> PriorSubsts m [CoreExpr]+mguAssumptions :: (Functor m, MonadPlus m) => Type -> [Type] -> PriorSubsts m [CoreExpr] mguAssumptions patty assumptions = applyDo mguAssumptions' assumptions patty mguAssumptions' assumptions patty = msum $ zipWith (\n t -> mguPS patty t >> return [X n]) [0..] assumptions -{-# SPECIALIZE matchAssumptions :: (MonadPlus m) => Common -> Int -> Type -> [Type] -> PriorSubsts m [CoreExpr] #-}-matchAssumptions :: (MonadPlus m, Expression e) => Common -> Int -> Type -> [Type] -> PriorSubsts m [e]+{-# SPECIALIZE matchAssumptions :: (Functor m, MonadPlus m) => Common -> Int -> Type -> [Type] -> PriorSubsts m [CoreExpr] #-}+matchAssumptions :: (Functor m, MonadPlus m, Expression e) => Common -> Int -> Type -> [Type] -> PriorSubsts m [e] matchAssumptions cmn lenavails reqty assumptions = do s <- getSubst let newty = apply s reqty@@ -151,7 +155,7 @@ -- match $B$N>l9g!$DL>o$O(Breqty$B$NJ}$@$1(Bapply subst$B$9$l$P$h$$!%(B -- not sure if this is more efficient than doing mguAssumptions and returning ().-mguAssumptions_ :: (MonadPlus m) => Type -> [Type] -> PriorSubsts m ()+mguAssumptions_ :: (Functor m, MonadPlus m) => Type -> [Type] -> PriorSubsts m () mguAssumptions_ patty assumptions = applyDo mguAssumptions_' assumptions patty mguAssumptions_' assumptions patty = msum $ map (mguPS patty) assumptions @@ -452,7 +456,7 @@ hit ty tys = sum (map size (ty:tys)) < 10 -areMono = all (null.tyvars)+-- areMono = all (null.tyvars) combs 0 xs = [[]] combs n xs = [] : [ y:zs | y:ys <- tails xs, zs <- combs (n-1) ys ]
MagicHaskeller/ReadTHType.lhs view
@@ -78,6 +78,7 @@ #else plainTV = PlainTV unPlainTV (PlainTV v) = v+unPlainTV (KindedTV v _) = v -- Uh, are there be problems? #endif tvToName n = TH.mkName ('t':show n)
MagicHaskeller/SimpleServer.hs view
@@ -58,6 +58,10 @@ import System.Posix hiding (Default) #endif +#ifdef CABAL+import Paths_MagicHaskeller(getDataFileName)+#endif+ -- file:///usr/share/doc/libghc6-network-doc/html/Network.html#t%3APortID --portID = UnixSocket "mhserver" portID = PortNumber 55443@@ -250,14 +254,25 @@ interactive qh so pgf hscEnv = sequence_ $ repeat $ hPutStrLn stderr "\\f -> ?" >> answerHIO qh so pgf hscEnv stdin stdout -trainSeq qh d pgf hscEnv fp = do+tryOpening fp onException onSuccess = do r <- try $ openFile fp ReadMode- case r :: Either IOException Handle of - Left e -> hPutStrLn stderr ("An exception occurred while opening `"++fp++"'. The learner has not been trained sequentially beforehand.")- Right h -> do time $ do- processTrainers qh (preferPlain d) pgf hscEnv h- hPutStrLn stderr "In total,"- return ()+ case r :: Either IOException Handle of+ Left e -> do+#ifdef CABAL+ fn <- getDataFileName ("MagicHaskeller/"++fp)+ s <- try $ openFile fn ReadMode+ either onException onSuccess (s :: Either IOException Handle)+#else+ onException e+#endif+ Right h -> onSuccess h++trainSeq qh d pgf hscEnv fp = do+ tryOpening fp (\e -> hPutStrLn stderr ("An exception occurred while opening `"++fp++"'. The learner has not been trained sequentially beforehand."))+ (\h -> do time $ do+ processTrainers qh (preferPlain d) pgf hscEnv h+ hPutStrLn stderr "In total,"+ return ()) hPutStrLn stderr "performing GC..." performGC hPutStrLn stderr "done.\a"@@ -273,15 +288,15 @@ Right () -> fmap (+t) $ processTrainers qh so pgf hscEnv h trainPara so pgf hscEnv fp = do- r <- try $ readFile fp- case r :: Either IOException String of - Left e -> hPutStrLn stderr ("An exception occurred while opening `"++fp++"'. The learner has not been trained in parallel beforehand.")- Right cs -> do beginCT <- getClockTime+ tryOpening fp (\e -> hPutStrLn stderr ("An exception occurred while opening `"++fp++"'. The learner has not been trained in parallel beforehand."))+ (\h -> do + cs <- hGetContents h+ beginCT <- getClockTime runParIO $ trainParaPar (preferPlain so) pgf hscEnv $ lines cs -- trainParaIO (preferPlain so) pgf hscEnv $ lines cs endParaCT <- getClockTime hPutStrLn stderr "All the training processes have finished."- hPutStrLn stderr $ showZero (timeDiffToString $ diffClockTimes endParaCT beginCT) ++ " have passed since the training started."+ hPutStrLn stderr $ showZero (timeDiffToString $ diffClockTimes endParaCT beginCT) ++ " have passed since the training started.") trainParaIO so pgf hscEnv css = do numUnfinished <- newMVar (length css) mapM_ (processTrainerPara (preferPlain so) pgf hscEnv numUnfinished) css@@ -391,9 +406,9 @@ prepareGHCAPI allfss = runGhc (Just libdir) $ do dfs <- getSessionDynFlags #if __GLASGOW_HASKELL__ >= 700- let newf = xopt_set dfs{packageFlags = [ ExposePackage "MagicHaskeller" ]} Opt_ExtendedDefaultRules+ let newf = xopt_set dfs{packageFlags = [ packageNameToFlag "MagicHaskeller" ]} Opt_ExtendedDefaultRules #else- let newf = dfs{packageFlags = [ ExposePackage "MagicHaskeller" ]}+ let newf = dfs{packageFlags = [ packageNameToFlag "MagicHaskeller" ]} #endif setSessionDynFlags newf -- result abandoned @@ -408,3 +423,10 @@ setContext [] modules #endif getSession++packageNameToFlag :: String -> PackageFlag+#if __GLASGOW_HASKELL__ < 710+packageNameToFlag = ExposePackage+#else+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.+#endif