MagicHaskeller 0.9.6.4.2 → 0.9.6.4.3
raw patch · 34 files changed
+264/−264 lines, 34 files
Files
- Control/Monad/Search/Combinatorial.lhs +11/−11
- MagicHaskeller.cabal +8/−8
- MagicHaskeller.lhs +15/−15
- MagicHaskeller/ClassLib.lhs +1/−1
- MagicHaskeller/Classify.hs +4/−4
- MagicHaskeller/ClassifyTr.hs +7/−7
- MagicHaskeller/CoreLang.lhs +2/−2
- MagicHaskeller/DebMT.lhs +5/−5
- MagicHaskeller/Execute.hs +6/−6
- MagicHaskeller/ExecuteAPI610.hs +17/−17
- MagicHaskeller/ExpToHtml.hs +6/−6
- MagicHaskeller/ExprStaged.hs +6/−6
- MagicHaskeller/FMType.lhs +21/−21
- MagicHaskeller/FakeDynamic.hs +5/−5
- MagicHaskeller/GetTime.hs +10/−10
- MagicHaskeller/IOGenerator.hs +2/−2
- MagicHaskeller/LibExcel.hs +1/−1
- MagicHaskeller/MemoToFiles.hs +11/−11
- MagicHaskeller/NearEq.hs +6/−6
- MagicHaskeller/Options.hs +15/−15
- MagicHaskeller/PolyDynamic.hs +7/−7
- MagicHaskeller/PriorSubsts.lhs +7/−7
- MagicHaskeller/ProgGen.lhs +2/−2
- MagicHaskeller/ProgGenSF.lhs +10/−10
- MagicHaskeller/ProgGenSFIORef.lhs +2/−2
- MagicHaskeller/ProgramGenerator.lhs +9/−9
- MagicHaskeller/ReadHsType.hs +2/−2
- MagicHaskeller/ReadTHType.lhs +3/−3
- MagicHaskeller/ReadTypeRep.hs +2/−2
- MagicHaskeller/SimpleServer.hs +8/−8
- MagicHaskeller/T10.hs +9/−9
- MagicHaskeller/TimeOut.hs +3/−3
- MagicHaskeller/TyConLib.hs +7/−7
- MagicHaskeller/Types.lhs +34/−34
Control/Monad/Search/Combinatorial.lhs view
@@ -109,7 +109,7 @@ -- msumRc xs = Rc (const xs) $B4V0c$$(B msumRc = listToRc listToRc l = Rc f where f 0 = l- f _ = mempty+ f _ = mempty {- -- m is usually IO or ST s@@ -124,7 +124,7 @@ 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+ f _ = mempty (<*>) = ap instance Monad Recomp where return = pure@@ -217,8 +217,8 @@ -- join (liftM2 mtf mtx)$B$h$j$b(Bstrict zipWithBF :: Monad m => (a -> b -> m c) -> m a -> m b -> m c zipWithBF f xss yss = do x <- xss- y <- yss- (f $! x) $! y+ y <- yss+ (f $! x) $! y scanl1BF :: Search m => m x -> m x scanl1BF bf = bf `mplus` delay (scanl1BF bf)@@ -239,7 +239,7 @@ ndelay _ = id instance Delay Recomp where delay (Rc f) = Rc g where g 0 = mempty- g n = f (n-1)+ g n = f (n-1) ndelay i (Rc f) = Rc g where g n | n < i = mempty | otherwise = f (n-i) getDepth = Rc (\d -> [d])@@ -252,13 +252,13 @@ instance Monad m => Delay (RecompT m) where delay (RcT f) = RcT g where g 0 = return mempty- g n = f (n-1)+ g n = f (n-1) ndelay i (RcT f) = RcT g where g n | n < i = return mempty | otherwise = f (n-i) instance (Monad m, Delay m) => Delay (StateT s m) where- delay = mapStateT delay- ndelay n = mapStateT (ndelay n)+ delay = mapStateT delay+ ndelay n = mapStateT (ndelay n) class (Delay m, MonadPlus m, Functor m) => Search m where fromRc :: Recomp a -> m a@@ -488,9 +488,9 @@ \begin{code} test'' = mconcat (unMx test') test' = do x <- Mx [return x | x<-[1..]]- y <- Mx [return y | y<-[1..]]- guard (x*y==30)- return (x,y)+ y <- Mx [return y | y<-[1..]]+ guard (x*y==30)+ return (x,y) main = print test'' \end{code}
MagicHaskeller.cabal view
@@ -1,5 +1,5 @@ Name: MagicHaskeller-Version: 0.9.6.4.2+Version: 0.9.6.4.3 Cabal-Version: >= 1.8 License: BSD3 License-file: LICENSE @@ -97,9 +97,9 @@ Extensions: CPP, TemplateHaskell cpp-options: -DCHTO -DCABAL - if !os(windows)- Build-depends: unix- cpp-options: -DUNIX+ if !os(windows)+ Build-depends: unix+ cpp-options: -DUNIX if flag(TFRANDOM) Build-depends: tf-random@@ -114,10 +114,10 @@ Build-depends: ghc >= 7 GHC-options: -with-rtsopts=-N - if flag(NETWORKURI)- Build-depends: network >= 2.6, network-uri >= 2.6- else- Build-depends: network < 2.6, network-uri < 2.6+ if flag(NETWORKURI)+ Build-depends: network >= 2.6, network-uri >= 2.6+ else+ Build-depends: network < 2.6, network-uri < 2.6 -- It is strongly recommended to use a UNIX server for the CGI frontend. -- Non-UNIX servers cannot use mueval, which means the functionality of generating input/output examples is not available.
MagicHaskeller.lhs view
@@ -226,7 +226,7 @@ define mn name pq = pq >>= \prims -> return [ SigD (mkName ("memo"++name)) (ConT mn), ValD (VarP (mkName ("memo"++name))) (NormalB (AppE (VarE (mkName "mkPG")) prims -- (VarE (mkName "prims"))- )) [],+ )) [], SigD (mkName ("every"++name)) (ConT (mkName "Everything")), ValD (VarP (mkName ("every"++name))) (NormalB (VarE (mkName "everything") `AppE` VarE (mkName ("memo"++name)))) [], SigD (mkName ("filter"++name)) (ConT (mkName "Filter")),@@ -234,8 +234,8 @@ type Every a = [[(TH.Exp,a)]] type EveryIO a = Int -- query depth -> IO [(TH.Exp, a)]-type Everything = Typeable a => Every a-type Filter = Typeable a => (a->Bool) -> IO (Every a)+type Everything = forall a. Typeable a => Every a+type Filter = forall a. Typeable a => (a->Bool) -> IO (Every a) {- Because the left hand side is not TH.Exp, we cannot splice directly there. initialize name depth prims = [d| { $(return (VarE (mkName ("memo"++name)))) = mkPG $prims;@@ -441,7 +441,7 @@ load :: FilePath -> TH.ExpQ -- ^ This becomes @[Primitive]@ when spliced. load fp = do str <- runIO $ readFile fp- f str+ f str -- | f is supposed to be used by load, but not hidden. f :: String -> TH.ExpQ f = p . return . readHsTypeSigs@@ -475,11 +475,11 @@ trsToTCL trs = (Map.fromListWith (\new old -> old) [ tup | k <- [0..7], tup <- tcsByK ! k ], tcsByK) where tnsByK :: Array Types.Kind [TypeName]- tnsByK = accumArray (flip (:)) [] (0,7) ( trsToTCstrs trs ) -- ¤³¤³¤òÊѤ¨¤¿¡¥- tcsByK :: Array Types.Kind [(TypeName,Types.TyCon)]- tcsByK = listArray (0,7) [ tnsToTCs (tnsByK ! k) | k <- [0..7] ]- tnsToTCs :: [TypeName] -> [(TypeName,Types.TyCon)]- tnsToTCs tns = zipWith (\ i tn -> (tn, i)) [0..] tns+ tnsByK = accumArray (flip (:)) [] (0,7) ( trsToTCstrs trs ) -- ¤³¤³¤òÊѤ¨¤¿¡¥+ tcsByK :: Array Types.Kind [(TypeName,Types.TyCon)]+ tcsByK = listArray (0,7) [ tnsToTCs (tnsByK ! k) | k <- [0..7] ]+ tnsToTCs :: [TypeName] -> [(TypeName,Types.TyCon)]+ tnsToTCs tns = zipWith (\ i tn -> (tn, i)) [0..] tns -- x ¼ÂºÝ¤Ë¤Ï(->)¤ÏTyCon°·¤¤¤Ë¤Ï¤·¤Ê¤¤¤ó¤À¤±¤É¡¤¤Û¤ó¤Î¤Á¤ç¤Ã¤È¤À¤±ÌµÂ̤ˤʤë¤À¤±¤Ê¤Î¤Ç¤¤¤¤¤Ç¤·¤ç¡¥ trsToTCstrs :: [TypeRep] -> [(Int, String)] -- Int is the arity of the TyCon. There can be duplicates.@@ -685,18 +685,18 @@ filterThenF pred et filterThenF pred et = do fd <- filterThen pred et- memodeb <- readIORef refmemodeb+ memodeb <- readIORef refmemodeb let o = opt $ extractCommon memodeb- return $ everyF o fd+ return $ everyF o fd {- refmemodeb ¤Ë¤¢¤ë¤â¤Î¤¬¼ÂºÝ¤Ë»È¤ï¤ì¤Æ¤¤¤ë¤â¤Î¤È¤Ï¸Â¤é¤Ê¤¤¡¥refmemodeb¤ò»È¤ï¤Ê¤¤¤È¤¤¤¦ÁªÂò¤â¤¢¤ë¤Î¤Ç¡¥ filterFirstF pred = do et <- getEverything filterThenF pred et filterThenF pred ts = do fd <- filterThen pred ts- let x=undefined- _=pred x- memodeb <- readIORef refmemodeb- return $ unMx $ randomTestFilter memodeb (getType memodeb x) $ Mx et+ let x=undefined+ _=pred x+ memodeb <- readIORef refmemodeb+ return $ unMx $ randomTestFilter memodeb (getType memodeb x) $ Mx et getType :: Typeable a => a -> ProgGen -> Types.Type getType ty memodeb = trToType (extractTCL memodeb) (typeOf ty) -}
MagicHaskeller/ClassLib.lhs view
@@ -79,7 +79,7 @@ guard $ not $ length es `seq` null es return (es, filterSubst sub mxty, m) where filterSubst :: Subst -> TyVar -> [(TyVar, Type)]- filterSubst sub mx = [ t | t@(i,_) <- sub, inRange (0,mx) i ] -- note that the assoc list is NOT sorted.+ filterSubst sub mx = [ t | t@(i,_) <- sub, inRange (0,mx) i ] -- note that the assoc list is NOT sorted. type Generator m e = MemoDeb e -> Type -> PriorSubsts m [e]
MagicHaskeller/Classify.hs view
@@ -142,7 +142,7 @@ liftCmp _ _ [] [] = EQ liftCmp len cmp (x:xs) (y:ys) = trace "liftCmp" $ case cmp x y of- EQ -> trace "just eq" $+ EQ -> trace "just eq" $ liftCmp (len-1) cmp xs ys c -> trace "otherwise" c@@ -159,7 +159,7 @@ liftCmpBot' _ _ (_:_) [] = Nothing liftCmpBot' len cmp (x:xs) (y:ys) = trace "liftCmpBot" $ case unsafePerformIO $ maybeWithTO pto $ return $ cmp x y of- Just EQ -> trace "just eq" $+ Just EQ -> trace "just eq" $ liftCmpBot' (len-1) cmp xs ys c -> trace "otherwise" c@@ -225,7 +225,7 @@ scanl (\xs (n,ys) -> mergeBy (liftCompareBot n cb) (eqClsByNth cmp n xs) ys) ecb0 $ zip (tcnrnds cb) ecbs {- scanl¤Î1¹Ô¤ÎÂå¤ï¤ê¤Ë¤³¤Ã¤Á¤ò»È¤Ã¤Æ¤¿¡¥ let result = ecb0 : zipWith3 (\n xs ys -> mergeBy (liftCompareBot n cmp) (eqClsByNth n xs) ys) (tail cnrnds) result ecbs- in result+ in result -} where Mx (ecb0:ecbs) = eqClsByFstNs cb mx -- n-2ÈÖÌܤÎequivalence¤Ç¤Îquotient set¤ò¸µ¤Ë¡¤n-1ÈÖÌܤÎequivalence¤ÇºÙʬ¡¥¤à¤·¤í¡¤refine¤È¤¤¤¦´Ø¿ô¤òÄêµÁ¤·¤¿Êý¤¬¤è¤¤?@@ -260,7 +260,7 @@ mergeBy op len xs ys = foldl (insertBy (\x y -> op x y == EQ)) xs ys insertBy :: (k->k->Bool) -> [k] -> k -> [k] insertBy op xs y = case filter (op y) xs of [] -> y:xs -- ÀèƬ¤ËµÕ½ç¤Ë²Ã¤¨¤ÆOK¤À¤Ã¤¿¤È¤Ï»×¤¦¤Î¤À¤¬¡¤°ì±þµ¤¤òÉÕ¤±¤ë- _ -> xs+ _ -> xs -} sfilterDB :: CmpBot k -> DBound ([k],e) -> DBound ([k],e)
MagicHaskeller/ClassifyTr.hs view
@@ -47,10 +47,10 @@ mkTip :: -- Show expr => (key->key->Maybe Ordering) -> Matrix (Stream key, expr) -> (Stream (Forest (key, expr)), Stream (Forest (key, expr)), Matrix expr) mkTip cmp mx = let fs = mkForests cmp mx- cmpFst (x,_) (y,_) = cmp x y- acc = accumulateForests cmpFst fs- filtered = fmap snd $ difference cmpFst fs ([]:acc)- in (fs, acc, filtered)+ cmpFst (x,_) (y,_) = cmp x y+ acc = accumulateForests cmpFst fs+ filtered = fmap snd $ difference cmpFst fs ([]:acc)+ in (fs, acc, filtered) mkForests :: (k->k->Maybe Ordering) -> Matrix (Stream k, r) -> Stream (Forest (k,r))@@ -76,8 +76,8 @@ mergeForests cmp tls@((tl@(Tr kl fl)) : rls) trs@((tr@(Tr kr fr)) : rrs) = case cmp kl kr of Just LT -> tl : mergeForests cmp rls trs- Just GT -> tr : mergeForests cmp tls rrs- _ -> Tr kl (mergeForests cmp fl fr) : mergeForests cmp rls rrs+ Just GT -> tr : mergeForests cmp tls rrs+ _ -> Tr kl (mergeForests cmp fl fr) : mergeForests cmp rls rrs difference :: (k->k->Maybe Ordering) -> Stream (Forest k) -> Stream (Forest k) -> Matrix k -- difference :: Show x => ((k,x)->(k,x)->Ordering) -> Stream (Forest (k,x)) -> Stream (Forest (k,x)) -> Matrix (k,x)@@ -91,7 +91,7 @@ trs@( Tr kr fr : rrs) = case cmp kl kr of Just LT -> flattenTr tl `mplus` diff cmp rls trs Just EQ -> delay (removeFirstOfFirst (diff cmp fl fr)) `mplus` diff cmp rls rrs- _ -> diff cmp tls rrs+ _ -> diff cmp tls rrs flattenTr :: Tree k -> Matrix k flattenTr (Tr k f) = [k] `consMx` removeFirstOfFirst (msum $ map flattenTr f)
MagicHaskeller/CoreLang.lhs view
@@ -57,7 +57,7 @@ -- | Primitive {primId :: Var} -- (This should be Var instead of Int8 because the number space is being exhausted!) -- | PrimCon {primId :: Var} -- the primitive is a constructor expression | Context Dictionary- | CoreExpr :$ CoreExpr+ | CoreExpr :$ CoreExpr | Case CoreExpr [(Var,Int8,CoreExpr)] -- the case expression. [(primitive ID of the constructor, arity of the constructor, rhs of ->)] | Fix CoreExpr Int8 [Int8] -- Fix expr n is === foldl (:$) (Y :$ FunLambda (napply n Lambda expr)) (map X is) {-@@ -65,7 +65,7 @@ -- See notes on July 3, 2010 -} | VarName String -- This is only used for pretty printing IOPairs.Expr. Use de Bruijn variables for other purposes.- deriving (Eq, Show, Ord)+ deriving (Eq, Show, Ord) newtype Dictionary = Dict {undict :: PD.Dynamic} deriving (Show) instance Ord Dictionary where compare _ _ = EQ -- This should work for the current purposes, but can cause a bug.
MagicHaskeller/DebMT.lhs view
@@ -23,12 +23,12 @@ type Possibility e = (Bag e, Subst, TyVar) data MapType a = MT {- tvMT :: [a],- tcMT :: [a],+ tvMT :: [a],+ tcMT :: [a], genMT :: [a], -- "forall" stuff- taMT :: MapType (MapType a),- funMT :: MapType (MapType a)- }+ taMT :: MapType (MapType a),+ funMT :: MapType (MapType a)+ } lookupMT :: MapType a -> Type -> a -- lookupMT :: MonadPlus m => MapType (m a) -> Type -> (m a)
MagicHaskeller/Execute.hs view
@@ -32,15 +32,15 @@ lambda v e | v `isFreeIn` e = K :$ e lambda v (X n) = I lambda v (f :$ x :$ y)- | v `isFreeIn` f = if v `isFreeIn` x+ | v `isFreeIn` f = if v `isFreeIn` x then B' :$ f :$ x :$ (lambda v y)- else if v `isFreeIn` y+ else if v `isFreeIn` y then C' :$ f :$ (lambda v x) :$ y- else S' :$ f :$ (lambda v x) :$ (lambda v y)+ else S' :$ f :$ (lambda v x) :$ (lambda v y) lambda v (x :$ y)- | v `isFreeIn` x = B :$ x :$ lambda v y- | v `isFreeIn` y = C :$ lambda v x :$ y- | otherwise = S :$ lambda v x :$ lambda v y+ | v `isFreeIn` x = B :$ x :$ lambda v y+ | v `isFreeIn` y = C :$ lambda v x :$ y+ | otherwise = S :$ lambda v x :$ lambda v y v `isFreeIn` (f :$ x) = v `isFreeIn` f && v `isFreeIn` x v `isFreeIn` (X n) = v /= n v `isFreeIn` _ = True
MagicHaskeller/ExecuteAPI610.hs view
@@ -11,30 +11,30 @@ import DynFlags -- (DynFlag, defaultDynFlags, PackageFlag(ExposePackage)) -- , glasgowExtsFlags) ¤Ïexport¤µ¤ì¤Æ¤¤¤Ê¤¤¤é¤·¤¤. import SrcLoc (SrcSpan(..), noSrcSpan, noSrcLoc, interactiveSrcLoc, noLoc) --- import MyCorePrep ( corePrepExpr )+-- import MyCorePrep( corePrepExpr ) import CorePrep(corePrepExpr) -- ¥³¥ó¥Ñ¥¤¥ë¤¬Ä̤é¤Ê¤¤¤Î¤Ç¥ª¥ê¥¸¥Ê¥ë¤Ë¤·¤Æ¤ß¤ë import FastString-import ByteCodeGen ( coreExprToBCOs )+import ByteCodeGen ( coreExprToBCOs ) --- import MyLink -- ( HValue, linkExpr, initDynLinker )+-- import MyLink -- ( HValue, linkExpr, initDynLinker ) import Linker -- ¥³¥ó¥Ñ¥¤¥ë¤¬Ä̤é¤Ê¤¤¤Î¤Ç¥ª¥ê¥¸¥Ê¥ë¤Ë¤·¤Æ¤ß¤ë -- import Flattening import HscTypes -- ( HscEnv(..), Session(..), withSession, InteractiveContext(..), mkTypeEnv ) -- also import instance MonadIO Ghc import SimplCore -- import SimplOnce -- ¥³¥ó¥Ñ¥¤¥ë¤¬Ä̤é¤Ê¤¤¤Î¤Ç¥³¥á¥ó¥È¥¢¥¦¥È-import VarEnv ( emptyTidyEnv )-import CoreSyn ( CoreExpr, Expr(..), Bind(..) ) -- compiler/coreSyn/CoreSyn.lhs-import CoreTidy ( tidyExpr )+import VarEnv ( emptyTidyEnv )+import CoreSyn ( CoreExpr, Expr(..), Bind(..) ) -- compiler/coreSyn/CoreSyn.lhs+import CoreTidy ( tidyExpr ) import Parser (parseStmt) import Lexer-import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnType ) +import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnType ) import Desugar (deSugarExpr) #if __GLASGOW_HASKELL__ < 708-import PrelNames ( iNTERACTIVE )+import PrelNames ( iNTERACTIVE ) #else import PrelNames (mkInteractiveModule) #endif@@ -277,7 +277,7 @@ stmtToCore hscEnv pst = do let dfs = hsc_dflags hscEnv icxt = hsc_IC hscEnv #if __GLASGOW_HASKELL__ >= 708- (tcmsgs, mbtc) <- tcRnStmt hscEnv pst+ (tcmsgs, mbtc) <- tcRnStmt hscEnv pst #else (tcmsgs, mbtc) <- tcRnStmt hscEnv icxt pst #endif@@ -318,9 +318,9 @@ #if __GLASGOW_HASKELL__ >= 706 Left msg -> error $ showSDoc (hsc_dflags hscEnv) msg #else- Left msg -> error $ showSDoc msg + Left msg -> error $ showSDoc msg #endif- Right expr -> expr+ Right expr -> expr -- unused, but may be useful in future #if __GLASGOW_HASKELL__ < 706@@ -358,15 +358,15 @@ compileExprHscMain :: HscEnv -> CoreExpr -> IO HValue compileExprHscMain hscEnv ce- = do let dflags = hsc_dflags hscEnv- smpl <- simplifyExpr dflags ce+ = do let dflags = hsc_dflags hscEnv+ smpl <- simplifyExpr dflags ce #if __GLASGOW_HASKELL__ >= 706 prep <- corePrepExpr dflags hscEnv smpl #else- prep <- corePrepExpr dflags smpl+ prep <- corePrepExpr dflags smpl #endif- bcos <- ce2b dflags prep- linkExpr hscEnv noSrcSpan bcos+ bcos <- ce2b dflags prep+ linkExpr hscEnv noSrcSpan bcos #ifdef GHC6 {-@@ -403,7 +403,7 @@ -- Just (_,csce) <- strToCore session ("let __compileExpr = ("++TH.pprint the ++")::"++TH.pprint (unforall ty)) let unr = unwrap csce putStrLn ("csce = "++show unr)- case ty of TH.ForallT tvs [] _ -> do let dfs = hsc_dflags hscEnv+ case ty of TH.ForallT tvs [] _ -> do let dfs = hsc_dflags hscEnv simplifyExpr dfs $ foldl CoreSyn.App unr $ replicate (length tvs) $ CoreSyn.Type anyPrimTy -- CorePrep ¤Ï ÉÔÍפʤϤº¤Ç¤Ï¤¢¤ë¤¬¡¤¤É¤¦¤¹¤ë¤è¡© _ -> return unr
MagicHaskeller/ExpToHtml.hs view
@@ -117,15 +117,15 @@ #ifdef RESPECTQUALIFICATIONS annotateString lang xs = case lex xs of [] -> error $ "parse error during annotateString: " ++ xs ++ "\nThis should not happen, when connected to the right server."- [("","")] -> ""- [(cs@(c:_),'.':rs@(r:_))] | isUpper c && not (isSpace r) -> annStr lang (cs++".") rs -- Without this pattern, '.' in "Data.Maybe.maybe" would be annotated.- [(cs,rs)] -> (if isSpace $ head xs then (' ':) else id) (annotateWord lang cs ++ annotateString lang rs)+ [("","")] -> ""+ [(cs@(c:_),'.':rs@(r:_))] | isUpper c && not (isSpace r) -> annStr lang (cs++".") rs -- Without this pattern, '.' in "Data.Maybe.maybe" would be annotated.+ [(cs,rs)] -> (if isSpace $ head xs then (' ':) else id) (annotateWord lang cs ++ annotateString lang rs) annStr lang mod xs = case lex xs of [] -> error $ "parse error during annStr: " ++ xs ++"\nThis should not happen, when connected to the right server."- [("","")] -> error $ "parse error during annStr: " ++ xs ++"\nThis should not happen, when connected to the right server."- [(cs@(c:_),".":rs@(r:_))] | isUpper c && not (isSpace r) -> annStr lang (mod++cs++".") rs -- Without this pattern, '.' in "Data.Maybe.maybe" would be annotated.- [(cs,rs)] -> (if isSpace $ head xs then (' ':) else id) (annotateWord lang cs ++ annotateString lang rs)+ [("","")] -> error $ "parse error during annStr: " ++ xs ++"\nThis should not happen, when connected to the right server."+ [(cs@(c:_),".":rs@(r:_))] | isUpper c && not (isSpace r) -> annStr lang (mod++cs++".") rs -- Without this pattern, '.' in "Data.Maybe.maybe" would be annotated.+ [(cs,rs)] -> (if isSpace $ head xs then (' ':) else id) (annotateWord lang cs ++ annotateString lang rs) #else annotateString lang xs = case lex xs of [] -> error $ "parse error during annotateString: " ++ xs ++ "\nThis should not happen, when connected to the right server."
MagicHaskeller/ExprStaged.hs view
@@ -135,14 +135,14 @@ -- maxLenavails = 0 mkCE :: Int8 -- ^ length of avails- -> Int8 -- ^ arity of the head function- -> CoreExpr+ -> Int8 -- ^ arity of the head function+ -> CoreExpr mkCE 0 _ = Lambda (X 0) mkCE lenavail 0 = napply (lenavail+1) Lambda (X lenavail) mkCE lenavail arity = let vs = map X $ reverse [0..lenavail-1]- fs = map X $ reverse [lenavail..lenavail+arity-1]- ce = X (lenavail+arity)+ fs = map X $ reverse [lenavail..lenavail+arity-1]+ ce = X (lenavail+arity) in napply (arity+1+lenavail) Lambda (foldl (:$) ce $ fmap (\f -> foldl (:$) f vs) fs) {-@@ -157,8 +157,8 @@ -- mkCE$B$G(B\ce->$B$r$H$C$F(Bce$B$r(BX debindex$B$K$9$k$@$1!%(B mkCE_LambdaBoundHead debindex lenavails arity = let vs = map X $ reverse [0..lenavails-1]- fs = map X $ reverse [lenavails..lenavails+arity-1]- ce = X debindex+ fs = map X $ reverse [lenavails..lenavails+arity-1]+ ce = X debindex in napply (arity+lenavails) Lambda (foldl (:$) ce $ fmap (\f -> foldl (:$) f vs) fs) -- $B$F$f!<$+!$(Bce$B$r:G8e$K;}$C$F$/$k$h$&$K$9$l$PE}9g$G$-$kLu$M!%(B -- mkCE_LambdaBoundHead debindex lenavails arity = (mkCE lenavails (arity+1) :$ (Lambda $ X 0)) :$ (napply lenavails Lambda $ X debindex)
MagicHaskeller/FMType.lhs view
@@ -3,8 +3,8 @@ \begin{code} {-# OPTIONS -cpp #-} module MagicHaskeller.FMType(FMType(..), updateFMT, unionFMT, unitFMT, lookupFMT, fmtToList, eltsFMT,- {- listToFMT, -} mapFMT- ) where+ {- listToFMT, -} mapFMT+ ) where import MagicHaskeller.Types -- import Monad import Data.IntMap as IM@@ -14,14 +14,14 @@ import Data.Monoid data FMType a = EmptyFMT- | FMT {- tvFMT :: IntMap a,- tcFMT :: IntMap a,- taFMT :: (FMType (FMType a)),- fnFMT :: (FMType (FMType a)),- funFMT :: (FMType (FMType a))- }- deriving (Read, Show)+ | FMT {+ tvFMT :: IntMap a,+ tcFMT :: IntMap a,+ taFMT :: (FMType (FMType a)),+ fnFMT :: (FMType (FMType a)),+ funFMT :: (FMType (FMType a))+ }+ deriving (Read, Show) lookupFMT :: Type -> FMType a -> Maybe a lookupFMT _ EmptyFMT = Nothing@@ -49,7 +49,7 @@ addToFMT :: Typed a -> FMType a -> FMType a addToFMT (e:::ty) = updateFMT (et:) et nty where nty = normalize ty- et = e:nty+ et = e:nty listToFMT :: [Typed a] -> FMType a listToFMT = foldr addToFMT EmptyFMT -}@@ -77,14 +77,14 @@ updateFMT :: (a->a) -> a -> Type -> (FMType a) -> FMType a updateFMT f x t fmt = updFMT t fmt where updFMT t EmptyFMT = updFMT t (FMT empty empty EmptyFMT EmptyFMT EmptyFMT)- updFMT (TV gen) fmt = fmt{tvFMT = insertWith (\_new old -> f old) (fromIntegral gen) x (tvFMT fmt)}- updFMT (TC con) fmt = fmt{tcFMT = insertWith (\_new old -> f old) (fromIntegral con) x (tcFMT fmt)}- updFMT (TA t0 t1) fmt = fmt{taFMT = updateFMT updFMTt1 (updFMTt1 EmptyFMT) t0 (taFMT fmt)}- where updFMTt1 = updFMT t1- updFMT (t0 :> t1) fmt = fmt{fnFMT = updateFMT updFMTt0 (updFMTt0 EmptyFMT) t1 (fnFMT fmt)}- where updFMTt0 = updFMT t0- updFMT (t0 :-> t1) fmt = fmt{funFMT = updateFMT updFMTt0 (updFMTt0 EmptyFMT) t1 (funFMT fmt)}- where updFMTt0 = updFMT t0+ updFMT (TV gen) fmt = fmt{tvFMT = insertWith (\_new old -> f old) (fromIntegral gen) x (tvFMT fmt)}+ updFMT (TC con) fmt = fmt{tcFMT = insertWith (\_new old -> f old) (fromIntegral con) x (tcFMT fmt)}+ updFMT (TA t0 t1) fmt = fmt{taFMT = updateFMT updFMTt1 (updFMTt1 EmptyFMT) t0 (taFMT fmt)}+ where updFMTt1 = updFMT t1+ updFMT (t0 :> t1) fmt = fmt{fnFMT = updateFMT updFMTt0 (updFMTt0 EmptyFMT) t1 (fnFMT fmt)}+ where updFMTt0 = updFMT t0+ updFMT (t0 :-> t1) fmt = fmt{funFMT = updateFMT updFMTt0 (updFMTt0 EmptyFMT) t1 (funFMT fmt)}+ where updFMTt0 = updFMT t0 unitFMT x t = updateFMT undefined x t EmptyFMT -- used by FMSubst.lhs@@ -97,8 +97,8 @@ unionFMT :: (a->a->a) -> FMType a -> FMType a -> FMType a unionFMT f l r = uFMT l r where uFMT EmptyFMT fmt = fmt- uFMT fmt EmptyFMT = fmt- uFMT (FMT vl cl al nl ul) (FMT vr cr ar nr ur) = FMT (unionWith f vl vr) (unionWith f cl cr) (unionFMT uFMT al ar) (unionFMT uFMT nl nr) (unionFMT uFMT ul ur)+ uFMT fmt EmptyFMT = fmt+ uFMT (FMT vl cl al nl ul) (FMT vr cr ar nr ur) = FMT (unionWith f vl vr) (unionWith f cl cr) (unionFMT uFMT al ar) (unionFMT uFMT nl nr) (unionFMT uFMT ul ur) {- unionFMT :: (forall a. a->a->a) -> FMType b -> FMType b -> FMType b unionFMT f EmptyFMT fmt = fmt
MagicHaskeller/FakeDynamic.hs view
@@ -3,11 +3,11 @@ -- {-# LANGUAGE MagicHash, ExistentialQuantification, PolymorphicComponents, TemplateHaskell, ImpredicativeTypes #-} module MagicHaskeller.FakeDynamic(- Dynamic,- fromDyn,- fromDynamic,- dynApply,- dynApp,+ Dynamic,+ fromDyn,+ fromDynamic,+ dynApply,+ dynApp, dynAppErr, unsafeFromDyn, -- :: Dynamic -> a unsafeToDyn, -- :: Type -> a -> Dynamic
MagicHaskeller/GetTime.hs view
@@ -17,13 +17,13 @@ time :: IO a -> IO (a, Integer) time act = do beginCT <- getClockTime- begin <- getCPUTime+ begin <- getCPUTime result <- act end <- getCPUTime- endCT <- getClockTime- hPutStrLn stderr (showZero (timeDiffToString (diffClockTimes endCT beginCT)) ++ " in real,")--- hPutStrLn stderr (shows (end-begin) " plusminus " ++ shows cpuTimePrecision " picoseconds spent.")- hPutStrLn stderr (showCPUTime (end-begin) ++ " seconds in CPU time spent.")+ endCT <- getClockTime+ hPutStrLn stderr (showZero (timeDiffToString (diffClockTimes endCT beginCT)) ++ " in real,")+-- hPutStrLn stderr (shows (end-begin) " plusminus " ++ shows cpuTimePrecision " picoseconds spent.")+ hPutStrLn stderr (showCPUTime (end-begin) ++ " seconds in CPU time spent.") return (result, end-begin) showZero "" = "0 secs"@@ -31,9 +31,9 @@ showCPUTime :: Integer -> String showCPUTime t = let s = show t- l = length s- (p,f) = splitAt (l - 12) s- in case compare l 12 of GT -> p ++ '.' : take (13 - lenPrec) f- EQ -> "0." ++ take (13 - lenPrec) f- LT -> "0." ++ replicate (12-l) '0' ++ take (12 - lenPrec) s+ l = length s+ (p,f) = splitAt (l - 12) s+ in case compare l 12 of GT -> p ++ '.' : take (13 - lenPrec) f+ EQ -> "0." ++ take (13 - lenPrec) f+ LT -> "0." ++ replicate (12-l) '0' ++ take (12 - lenPrec) s lenPrec = length (show cpuTimePrecision)
MagicHaskeller/IOGenerator.hs view
@@ -169,7 +169,7 @@ sasFalse = sas (const False) sasIntegral :: (Show a, Arbitrary a, Integral a, Ord a) => [(AnnShowS, a)] sasIntegral = sas (<0) [0,1] ++ -- interleave [2..] [-1,-2..]- drop 2 sasNum+ drop 2 sasNum -- interleave xs ys = concat $ transpose [xs, ys] instance ShowArbitrary () where showArbitraries = repeat (const ("()"++),())@@ -213,7 +213,7 @@ chopBy _ [] = [] -- everythingF¤ò»È¤Ã¤Æ¤¢¤ëÅÀ¤ÇÀÚ¤ë¸Â¤ê¡¤Í¸Â¤Î²ÄǽÀ¤âɬ¤º»Ä¤ë¡¥¶õ¥ê¥¹¥È¤Ç¤¢¤ë¤³¤È¤â¤¢¤ê¤¨¤ë¤Î¤Ç¡¤cycle¤·¤Æ¤â¥À¥á¡¥ chopBy is xs = cb is $ cycle xs where cb (i:is) xs | i < 0 = cb is xs- | otherwise = case splitAt i xs of (tk,dr) -> tk : cb is dr+ | otherwise = case splitAt i xs of (tk,dr) -> tk : cb is dr cvt :: [(AnnShowS,a)] -> (AnnShowS, [a]) cvt ts = case unzip ts of (fs, xs) -> (showsList fs, xs)
MagicHaskeller/LibExcel.hs view
@@ -1,7 +1,7 @@ -- -- (c) Susumu Katayama ---{-# OPTIONS -XTemplateHaskell -XNoMonomorphismRestriction -cpp #-}+{-# LANGUAGE TemplateHaskell, NoMonomorphismRestriction, PatternGuards, CPP #-} module MagicHaskeller.LibExcel(module MagicHaskeller.LibExcel, module MagicHaskeller.LibExcelStaged) where import MagicHaskeller
MagicHaskeller/MemoToFiles.hs view
@@ -29,14 +29,14 @@ fps mxty (PS f) = do (exprs, sub, m) <- f emptySubst (mxty+1) return (exprs, filterSubst sub mxty, m) where filterSubst :: Subst -> TyVar -> [(TyVar, Type)]- filterSubst sub mx = [ t | t@(i,_) <- sub, inRange (0,mx) i ] -- note that the assoc list is NOT sorted.+ filterSubst sub mx = [ t | t@(i,_) <- sub, inRange (0,mx) i ] -- note that the assoc list is NOT sorted. -- ¤³¤ì¤Ã¤ÆProgGen¸ÂÄ꤫ memoPSRTIO :: ShortString b => MemoCond -> MapType (Matrix (Possibility b))- -> (Type -> PriorSubsts (RecompT IO) [b]) -- ^ This will be used instead if the entry is not found.- -> Type -> PriorSubsts (RecompT IO) [b]+ -> (Type -> PriorSubsts (RecompT IO) [b]) -- ^ This will be used instead if the entry is not found.+ -> Type -> PriorSubsts (RecompT IO) [b] memoPSRTIO policy mt f t = PS $ \subst mx -> let (tn, decoder) = encode t mx in (fmap (\ (exprs, sub, m) -> (exprs, retrieve decoder sub `plusSubst` subst, mx+m)) $ (memoRTIO policy (\ty depth -> return $ unMx (lookupMT mt ty) !! depth) (\u -> freezePS u (f u)) tn))@@ -45,14 +45,14 @@ memoRTIO :: ShortString b => MemoCond -> (Type -> Int -> IO [b]) -- ^ look up the memoization table in the RAM.- -> (Type -> RecompT IO b) -- ^ This will be used instead if the entry is not found.- -> Type -> RecompT IO b+ -> (Type -> RecompT IO b) -- ^ This will be used instead if the entry is not found.+ -> Type -> RecompT IO b memoRTIO policy lor f t = RcT $ memoer policy lor (\ty -> unRcT (f ty)) t memoer :: ShortString b => MemoCond -> (Type -> Int -> IO [b])- -> (Type -> Int -> IO [b])- -> Type -> Int -> IO [b]+ -> (Type -> Int -> IO [b])+ -> Type -> Int -> IO [b] memoer policy lor f ty depth = do memotype <- policy ty depth case memotype of Recompute -> compute@@ -84,11 +84,11 @@ memoToFile parser printer filepath compute = let write = do result <- compute LC.writeFile filepath (printer result)- return result+ return result in do there <- doesFileExist filepath if there then do cs <- C.readFile filepath -- Read strictly, and close (not semi-close) it. System.IO.readFile cannot achieve this behavior. - case parser cs of Just x -> return x- _ -> do -- If the file is broken, just fix it. ¤Ç¤â狼¤¬½ñ¤¹þ¤ßÃæ¤À¤Èº¤¤ë?+ case parser cs of Just x -> return x+ _ -> do -- If the file is broken, just fix it. ¤Ç¤â狼¤¬½ñ¤¹þ¤ßÃæ¤À¤Èº¤¤ë? System.IO.hPutStrLn stderr ("File " ++ filepath ++ " was broken.") write- else write+ else write
MagicHaskeller/NearEq.hs view
@@ -9,14 +9,14 @@ -- Without check with isInfinite, Infinity ~= something would always be True. Without check with signum, Infinity ~= -Infinity would always be True. instance NearEq Double where- a ~= b = na==nb && ia == isInfinite b && signum a == signum b && (na || ia || abs (a-b) <= (scaleFloat (-24) $ abs a))- where na = isNaN a- nb = isNaN b+ a ~= b = na==nb && ia == isInfinite b && signum a == signum b && (na || ia || abs (a-b) <= (scaleFloat (-24) $ abs a))+ where na = isNaN a+ nb = isNaN b ia = isInfinite a instance NearEq Float where- a ~= b = na==nb && ia == isInfinite b && signum a == signum b && (na || ia || abs (a-b) <= (scaleFloat (-12) $ abs a))- where na = isNaN a- nb = isNaN b+ a ~= b = na==nb && ia == isInfinite b && signum a == signum b && (na || ia || abs (a-b) <= (scaleFloat (-12) $ abs a))+ where na = isNaN a+ nb = isNaN b ia = isInfinite a instance NearEq () where x ~= y = x == y
MagicHaskeller/Options.hs view
@@ -13,8 +13,8 @@ -- | options that limit the hypothesis space. data Opt a = Opt{ primopt :: Maybe a -- ^ Use this option if you want to use a different component library for the stage of solving the inhabitation problem.- -- @Nothing@ means using the same one.- -- This option makes sense only when using *SF style generators, because otherwise the program generation is not staged.+ -- @Nothing@ means using the same one.+ -- This option makes sense only when using *SF style generators, because otherwise the program generation is not staged. -- Using a minimal set for solving the inhabitation and a redundant library for the real program generation can be a good bet. , memodepth :: Int -- ^ memoization depth. (Sub)expressions within this size are memoized, while greater expressions will be recomputed (to save the heap space). Only effective when using 'ProgGen' and unless using the 'everythingIO' family. , memoCondPure :: Type -> Int -> Bool -- ^ This represents when to memoize. It takes the query type and the query depth, and returns @True@ if the corresponding entry should be looked up from the lazy memo table. Currently this only works for ProgGenSF.@@ -24,13 +24,13 @@ , forcibleTimeout :: Bool -- ^ If this option is @True@, 'System.Posix.Process.forkProcess' instead of 'Control.Concurrent.forkIO' is used for timeout. -- The former is much heavier than the latter, but is more preemptive and thus is necessary for interrupting some infinite loops. -- This record is ignored if FORCIBLETO is not defined.- , guess :: Bool -- ^ If this option is @True@, the program guesses whether each function is a case/catamorphism/paramorphism or not.+ , guess :: Bool -- ^ If this option is @True@, the program guesses whether each function is a case/catamorphism/paramorphism or not. -- This information is used to filter out some duplicate expressions. -- (History: I once abandoned this guessing strategy around the time I moved to the library implementation, because -- I could not formally prove the exhaustiveness of the resulting algorithm. -- For this reason, the old standalone version of MagicHaskeller uses this strategy, but almost the same effect -- can be obtained by setting this option to True, or using 'MagicHaskeller.init075' instead of 'MagicHaskeller.initialize'. - , contain :: Bool -- ^ This option is now obsolete, and we always assume True now.+ , contain :: Bool -- ^ This option is now obsolete, and we always assume True now. -- If this option was @False@, data structures might not contain functions, and thus types like @[Int->Int]@, @(Int->Bool, Char)@, etc. were not permitted. -- (NB: recently I noticed that making this @False@ might not improve the efficiency of generating lambda terms at all, though when I generated combinatory expressions it WAS necessary. -- In fact, I mistakenly turned this limitation off, and my code always regarded this as True, but I did not notice that, so this option can be obsoleted.)@@ -91,13 +91,13 @@ -- The restriction can be amended if the tuple constructor and destructors are available. , tv0 :: Bool #ifdef TFRANDOM- , stdgen :: TFGen -- ^ The random seed.+ , stdgen :: TFGen -- ^ The random seed. #else- , stdgen :: StdGen -- ^ The random seed.+ , stdgen :: StdGen -- ^ The random seed. #endif- , nrands :: [Int] -- ^ number of random samples at each depth, for each type, for the filter applied during synthesis (used by ProgGenSF, &c.).- , fcnrand :: Int -> Int -- ^ number of random samples at each depth, for each type, for the filter applied after synthesis (used by filterThenF, &c.).- }+ , nrands :: [Int] -- ^ number of random samples at each depth, for each type, for the filter applied during synthesis (used by ProgGenSF, &c.).+ , fcnrand :: Int -> Int -- ^ number of random samples at each depth, for each type, for the filter applied after synthesis (used by filterThenF, &c.).+ } -- | default options --@@ -129,20 +129,20 @@ , execute = unsafeExecute , timeout = Just 20000 , forcibleTimeout = False - , guess = False- , contain = True+ , guess = False+ , contain = True , constrL = False , tvndelay = 1 , tv1 = False , tv0 = False #ifdef TFRANDOM- , stdgen = seedTFGen (3497676378205993723,16020016691208771845,6545968067796471226,2770936286170065919)+ , stdgen = seedTFGen (3497676378205993723,16020016691208771845,6545968067796471226,2770936286170065919) #else- , stdgen = mkStdGen 123456+ , stdgen = mkStdGen 123456 #endif- , nrands = nrnds+ , nrands = nrnds , fcnrand = (6+)- }+ } -- reducer (opt,_,_,_,_) = execute opt
MagicHaskeller/PolyDynamic.hs view
@@ -5,11 +5,11 @@ {-# LANGUAGE CPP, TemplateHaskell, MagicHash, RankNTypes #-} module MagicHaskeller.PolyDynamic (- Dynamic(..),- fromDyn, -- :: Type -> Dynamic -> a -> a- fromDynamic, -- :: Type -> Dynamic -> Maybe a- dynApply,- dynApp,+ Dynamic(..),+ fromDyn, -- :: Type -> Dynamic -> a -> a+ fromDynamic, -- :: Type -> Dynamic -> Maybe a+ dynApply,+ dynApp, dynAppErr, unsafeToDyn -- :: Type -> a -> Dynamic , aLittleSafeFromDyn -- :: Type -> Dynamic -> a@@ -53,12 +53,12 @@ aLittleSafeFromDyn tr (Dynamic t o _) = case mgu tr t of Just _ -> o- Nothing -> error ("aLittleSafeFromDyn: type mismatch between "++show tr++" and "++show t)+ Nothing -> error ("aLittleSafeFromDyn: type mismatch between "++show tr++" and "++show t) fromDyn :: Typeable a => TyConLib -> Dynamic -> a -> a fromDyn tcl (Dynamic t o _) dflt = case mgu (trToType tcl (typeOf dflt)) t of Just _ -> o- Nothing -> dflt+ Nothing -> dflt fromDynamic :: MonadPlus m => Type -> Dynamic -> m a fromDynamic tr (Dynamic t o _) = mgu tr t >> return o
MagicHaskeller/PriorSubsts.lhs view
@@ -40,7 +40,7 @@ runPS :: Monad m => PriorSubsts m a -> m a runPS (PS f) = do (x,_,_) <- f emptySubst 0- return x+ return x -- delayPS :: (Delay (m a)) => PriorSubsts m a -> PriorSubsts m a -- delayPS = convertPS delay@@ -115,7 +115,7 @@ {-# SPECIALIZE mguPS :: Type -> Type -> PriorSubsts [] () #-} mguPS, matchPS :: (Functor m, MonadPlus m) => Type -> Type -> PriorSubsts m () mguPS t0 t1 = do subst <- mgu t0 t1- updatePS subst+ updatePS subst -- ¤Æ¤æ¡¼¤«mgtPS¤òmguPS¤ÎÄêµÁ¤Ë¤·¤Æ¤â¤¤¤¤¤¯¤é¤¤¡¥ mgtPS :: (Functor m, MonadPlus m) => Type -> Type -> PriorSubsts m Type mgtPS t1 t2 = do mguPS t1 t2@@ -123,14 +123,14 @@ {-# SPECIALIZE varBindPS :: TyVar -> Type -> PriorSubsts [] () #-} varBindPS :: (Functor m, MonadPlus m) => TyVar -> Type -> PriorSubsts m () varBindPS v t = do subst <- varBind v t- updatePS subst+ updatePS subst matchPS t0 t1 = do subst <- match t0 t1 updatePS subst {- symPlusPS :: MonadPlus m => Subst -> PriorSubsts m () symPlusPS subst = do s0 <- getSubst- s1 <- symPlus subst s0- setSubst s1+ s1 <- symPlus subst s0+ setSubst s1 -} lookupSubstPS :: (Functor m, MonadPlus m) => TyVar -> PriorSubsts m Type@@ -151,8 +151,8 @@ {-# SPECIALIZE unify :: Type -> Type -> PriorSubsts [] () #-} 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+ u <- mgu (apply s t1) (apply s t2)+ updatePS u newTVar :: Monad m => PriorSubsts m TyVar newTVar = PS (\ s n -> return (n, s, n+1))
MagicHaskeller/ProgGen.lhs view
@@ -119,7 +119,7 @@ guard $ not $ length es `seq` null es return (es, filterSubst sub mxty, m) where filterSubst :: Subst -> TyVar -> [(TyVar, Type)]- filterSubst sub mx = [ t | t@(i,_) <- sub, inRange (0,mx) i ] -- note that the assoc list is NOT sorted.+ filterSubst sub mx = [ t | t@(i,_) <- sub, inRange (0,mx) i ] -- note that the assoc list is NOT sorted. type Generator m e = MemoDeb (ClassLib e) e -> [Type] -> Type -> PriorSubsts m [e]@@ -145,7 +145,7 @@ --mguProgs memodeb = wind (>>= (return . fmap Lambda)) (\avail reqret -> reorganize (\newavail -> lookupFunsPoly mguFuns memodeb newavail reqret) avail) {- ¤É¤Ã¤Á¤¬¤ï¤«¤ê¤ä¤¹¤¤¤«¤ÏÉÔÌÀ mguProgs memodeb avail (t0:->t1) = do result <- mguProgs memodeb (t0 : avail) t1- return (fmap Lambda result)+ return (fmap Lambda result) mguProgs memodeb avail reqret = reorganize (\newavail -> lookupFunsPoly mguFuns memodeb newavail reqret) avail -}
MagicHaskeller/ProgGenSF.lhs view
@@ -161,8 +161,8 @@ {- The following does not accurately give other chances to the expressions once dropped. ¥³¡¼¥É¤ò¤¤¤¸¤Ã¤Æ¤¤¤ë¤¦¤Á¤Ë¤¤¤Ä¤Î´Ö¤Ë¤«ºÇ½é¤ÎÀ߷פò˺¤ì¤Æ¤³¤ó¤Ê¤ó¤Ê¤Ã¤Æ¤¿¡¥ -- dbToCumulativeMx (DB f) = Mx $ map (map fst . f) [0..] dbToCumulativeMx (DB f) = let foo = map (sort . map fst . f) [0..]- in Mx $ zipWith (diffSortedBy compare) foo ([]:foo)--- in Mx $ zipWith (\\) foo ([]:foo)+ in Mx $ zipWith (diffSortedBy compare) foo ([]:foo)+-- in Mx $ zipWith (\\) foo ([]:foo) -} mkTrieOptSFIO :: Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]] -> IO (PGSF CoreExpr) mkTrieOptSFIO cmn classes txsopt txs@@ -221,7 +221,7 @@ fps mxty (PS f) = do (exprs, sub, m) <- f emptySubst (mxty+1) return (exprs, filterSubst sub mxty, m) where filterSubst :: Subst -> TyVar -> [(TyVar, Type)]- filterSubst sub mx = [ t | t@(i,_) <- sub, inRange (0,mx) i ] -- note that the assoc list is NOT sorted.+ filterSubst sub mx = [ t | t@(i,_) <- sub, inRange (0,mx) i ] -- note that the assoc list is NOT sorted. @@ -337,7 +337,7 @@ -- retMono :: BitSet -> Type -> PriorSubsts BFT () retMono ix ty = napply (getArity ty) delayPS $ do mguPS reqret (getRet ty)- fasf ty $ fullBits .&. complement ix+ fasf ty $ fullBits .&. complement ix -- retGen :: (Int, Type, Int, Typed [CoreExpr]) -> PriorSubsts BFT () retGen (arity, _r, numtvs, _s:::ty) = napply arity delayPS $ do tvid <- reserveTVars numtvs -- ¤³¤Î¡ÊºÇ½é¤Î¡ËID¤½¤Î¤â¤Î¡Ê¤Ä¤Þ¤êÊÖ¤êÃͤÎtvID¡Ë¤Ï¤¹¤°¤Ë»È¤ï¤ì¤Ê¤¯¤Ê¤ë@@ -528,8 +528,8 @@ faso _ tup = return tup fapBits behalf ts tups = foldM (\ (fs,bsf) t -> do (args, bse) <- behalf t return (liftM2 (<$>) fs args, bsf .|. bse))- tups- ts+ tups+ ts forceNil :: BitSet -> PriorSubsts Recomp e -> PriorSubsts Recomp e forceNil newRemaining = convertPS (zipDepthRc (\i es -> if i < countBits newRemaining - 1 then [] else es))@@ -570,7 +570,7 @@ -- -- unitSubst¤òinline¤Ë¤·¤Ê¤¤¤ÈÂÌÌܤ« a <- mkSubsts (tvndelay $ opt cmn) tvid reqret (exprs, bs1) <- funApSubBits_resetting clbehalf lltbehalf behalf (mapTV (tvid+) ty) (map (mkHead (reducer cmn) lenavails (getLongerArity ty+a)) xs, fullBits)- gentvar <- applyPS (TV tvid)+ gentvar <- applyPS (TV tvid) guard (orderedAndUsedArgs gentvar) -- ¤³¤ÎÊÕ¤Îcheck¤òTVn¤ËÆþ¤ëÁ°¤ÎÁᤤÃʳ¬¤Ë¤ä¤ë¤Î¤Ï1¤Ä¤Î¹Í¤¨Êý¤À¤¬¡¤TVnÃæ¤Ëreplace¤µ¤ì¤¿¤ê¤Ï¤·¤Ê¤¤¤Î¤«? (es, bs2) <- funApSub'' False gentvar (fe gentvar ty exprs, bs1) guard $ bs2 == 0@@ -584,12 +584,12 @@ else liftM2 (<$>) funs args, bs .&. complement ixs) -- ¤Æ¤æ¡¼¤«t¤Èu¤¬Æ±¤¸¤Ê¤é¤Ð¤â¤Ã¤È¤¤¤í¤ó¤Ê¤³¤È¤¬¤Ç¤¤½¤¦¡¥- funApSub'' filtexp (t:->ts) (funs, bs)+ funApSub'' filtexp (t:->ts) (funs, bs) = do (args, ixs) <- behalf t return (if filtexp then [ f <$> e | f <- funs, e <- args, let _:$d = toCE f, d <= toCE e] else liftM2 (<$>) funs args, bs .&. complement ixs)- funApSub'' _fe _t tups = return tups+ funApSub'' _fe _t tups = return tups retGenTV1Bits cmn lenavails fullBits fe clbehalf lltbehalf behalf reqret (arity, _retty, numtvs, xs:::ty) = convertPS (ndelay arity) $ do tvid <- reserveTVars numtvs -- ¤³¤Î¡ÊºÇ½é¤Î¡ËID¤½¤Î¤â¤Î¡Ê¤Ä¤Þ¤êÊÖ¤êÃͤÎtvID¡Ë¤Ï¤¹¤°¤Ë»È¤ï¤ì¤Ê¤¯¤Ê¤ë@@ -598,7 +598,7 @@ a <- mkSubst (tvndelay $ opt cmn) tvid reqret {- (exprs, bs1) <- funApSubBits_resetting clbehalf lltbehalf behalf (mapTV (tvid+) ty) (map (mkHead (reducer cmn) lenavails (getLongerArity ty+a)) xs, fullBits)- gentvar <- applyPS (TV tvid)+ gentvar <- applyPS (TV tvid) guard (usedArg (tvid+1) gentvar) funApSubBits_forcingNil clbehalf lltbehalf behalf gentvar (fe gentvar ty exprs, bs1) -}
MagicHaskeller/ProgGenSFIORef.lhs view
@@ -202,7 +202,7 @@ -- retMono :: Type -> PriorSubsts BFT () retMono ty = napply (getArity ty) delayPS $ do mguPS reqret (getRet ty)- fas ty+ fas ty -- retGen :: (Int, Type, Int, Typed [CoreExpr]) -> PriorSubsts BFT () retGen (arity, _r, numtvs, _s:::ty) = napply arity delayPS $ do tvid <- reserveTVars numtvs -- ¤³¤Î¡ÊºÇ½é¤Î¡ËID¤½¤Î¤â¤Î¡Ê¤Ä¤Þ¤êÊÖ¤êÃͤÎtvID¡Ë¤Ï¤¹¤°¤Ë»È¤ï¤ì¤Ê¤¯¤Ê¤ë@@ -211,7 +211,7 @@ mkSubsts (tvndelay $ opt cmn) tvid reqret fas (mapTV (tvid+) ty) - gentvar <- applyPS (TV tvid)+ gentvar <- applyPS (TV tvid) guard (orderedAndUsedArgs gentvar) fas gentvar
MagicHaskeller/ProgramGenerator.lhs view
@@ -136,7 +136,7 @@ = do let (n, (arity,args,retty)) = fromBlah tok retty convertPS (ndelay $ fromIntegral arity) $- fap behalf args (map (mkHead (reducer cmn) lenavails arity) [X n])+ fap behalf args (map (mkHead (reducer cmn) lenavails arity) [X n]) fromAvail :: [Type] -> [(Int8, (Int8,[Type],Type))] fromAvail = zipWith (\ n t -> (n, revSplitArgs t)) [0..] @@ -198,14 +198,14 @@ -} -- foldM$B$r;H$&!%$J$<$+$3$l$,0lHVB.$$(B fap behalf ts funs = foldM (\fs t -> do args <- behalf t- return $ liftM2 (<$>) fs args)- funs- ts+ return $ liftM2 (<$>) fs args)+ funs+ ts -- fap behalf ts funs = mapAndFoldM (liftM2 (<$>)) funs behalf ts mapAndFoldM op n f [] = return n mapAndFoldM op n f (x:xs) = do y <- f x- mapAndFoldM op (n `op` y) f xs+ mapAndFoldM op (n `op` y) f xs @@ -220,7 +220,7 @@ -- -- unitSubst$B$r(Binline$B$K$7$J$$$HBLL\$+(B a <- mkSubsts (tvndelay $ opt cmn) tvid reqret exprs <- funApSub clbehalf lltbehalf behalf (mapTV (tvid+) ty) (map (mkHead (reducer cmn) lenavails (getLongerArity ty+a)) xs)- gentvar <- applyPS (TV tvid)+ gentvar <- applyPS (TV tvid) guard (orderedAndUsedArgs gentvar) -- $B$3$NJU$N(Bcheck$B$r(BTVn$B$KF~$kA0$NAa$$CJ3,$K$d$k$N$O(B1$B$D$N9M$(J}$@$,!$(BTVn$BCf$K(Breplace$B$5$l$?$j$O$7$J$$$N$+(B? fas gentvar (fe gentvar ty exprs) -- retGenOrd can be used instead of retGen, when not reorganizing.@@ -233,11 +233,11 @@ funApSub'' (t==u) ts (if filtexp then [ f <$> e | f <- funs, e <- args, let _:$d = toCE f, d <= toCE e ] else liftM2 (<$>) funs args) -- $B$F$f!<$+(Bt$B$H(Bu$B$,F1$8$J$i$P$b$C$H$$$m$s$J$3$H$,$G$-$=$&!%(B- funApSub'' filtexp (t:->ts) funs+ funApSub'' filtexp (t:->ts) funs = do args <- behalf t return (if filtexp then [ f <$> e | f <- funs, e <- args, let _:$d = toCE f, d <= toCE e] else liftM2 (<$>) funs args)- funApSub'' _fe _t funs = return funs+ funApSub'' _fe _t funs = return funs orderedAndUsedArgs (TV _ :-> _) = False -- mkSubsts$B$GF3F~$5$l$?(Btyvars$B$,;H$o$l$F$$$J$$%1!<%9!%(Breplace$B$5$l$?7k2L(BTV$B$C$F%1!<%9$O$H$j$"$($:L5;k(B.... orderedAndUsedArgs (t:->ts@(u:->_)) | t > u = False@@ -254,7 +254,7 @@ -- -- unitSubst$B$r(Binline$B$K$7$J$$$HBLL\$+(B a <- mkSubst (tvndelay $ opt cmn) tvid reqret exprs <- funApSub clbehalf lltbehalf behalf (mapTV (tvid+) ty) (map (mkHead (reducer cmn) lenavails (getLongerArity ty+a)) xs)- gentvar <- applyPS (TV tvid)+ gentvar <- applyPS (TV tvid) guard (usedArg (tvid+1) gentvar) funApSub clbehalf lltbehalf behalf gentvar (fe gentvar ty exprs)
MagicHaskeller/ReadHsType.hs view
@@ -49,5 +49,5 @@ readHsDecls :: String -> [HsDecl] readHsDecls src = case parseModule src of ParseOk (HsModule _loc _nam _ex _imports decls) -> decls- ParseFailed (SrcLoc _fn line column) str- -> error (str ++ " in " ++ shows line ":" ++ shows column " of\n" ++ src)+ ParseFailed (SrcLoc _fn line column) str+ -> error (str ++ " in " ++ shows line ":" ++ shows column " of\n" ++ src)
MagicHaskeller/ReadTHType.lhs view
@@ -31,9 +31,9 @@ thTypeToType' tcl vs (AppT ht0 ht1) = TA (thTypeToType' tcl vs ht0) (thTypeToType' tcl vs ht1) thTypeToType' (fm,_) _ (ConT name) = let nstr = showTypeName name in case Data.Map.lookup nstr fm of- Nothing -> -- TC $ (-1 - bakaHash nstr)- error $ "thTypeToType' : "++nstr++" : unknown TyCon"- Just c -> TC c+ Nothing -> -- TC $ (-1 - bakaHash nstr)+ error $ "thTypeToType' : "++nstr++" : unknown TyCon"+ Just c -> TC c {- ±ÌÓÍPÈéRgAEgÅ¢¢ñ¾Á¯H thTypeToType' tcl (HsTyCon (Special HsUnitCon)) = TC (unit tcl) thTypeToType' tcl (HsTyCon (Special HsListCon)) = TC (list tcl)
MagicHaskeller/ReadTypeRep.hs view
@@ -43,7 +43,7 @@ trToType tcl tr = case splitTyConApp tr of (tc,trs) -> (if tc == funTyCon || show tc == show funTyCon -- dunno why, but sometimes |tc==funTyCon| is not enough. then trToType tcl (head trs) :-> trToType tcl (head (tail trs))- else foldl TA (TC $ fromJust $ Data.Map.lookup (tyConString' tc) (fst tcl)) (map (trToType tcl) trs))+ else foldl TA (TC $ fromJust $ Data.Map.lookup (tyConString' tc) (fst tcl)) (map (trToType tcl) trs)) where fromJust (Just x) = x fromJust Nothing = error (tyConString' tc ++ " does not appear in the component library. (This is a known bug.) For now, please use a type variable instead of "++show tc ++ " and use `matching :: Int -> Memo -> TH.Type -> [[TH.Exp]]'.\n(or maybe you forgot to set a component library?)")@@ -69,7 +69,7 @@ trToTHType tr = case splitTyConApp tr of (tc,trs) -> if tc == funTyCon || show tc == show funTyCon -- dunno why, but sometimes |tc==funTyCon| is not enough. then TH.AppT TH.ArrowT (trToTHType (head trs)) `TH.AppT` trToTHType (head (tail trs))- else foldl TH.AppT (TH.ConT (TH.mkName (tyConName tc))) (map trToTHType trs)+ else foldl TH.AppT (TH.ConT (TH.mkName (tyConName tc))) (map trToTHType trs) where tyConToName str = case tyConName str of "[]" -> TH.ListT str@(',':_) -> TH.TupleT (length str) -- tyConString mistakenly prints "," instead of "(,)". str -> TH.ConT $ TH.mkName str
MagicHaskeller/SimpleServer.hs view
@@ -119,9 +119,9 @@ msgq = "--query-limit (or -q) takes a non-negative integral value specifying the type size bound for memoization." readOpts :: IO ([Flag], [String]) readOpts = do argv <- getArgs- case (getOpt Permute cmdOpts argv) of- (o,n,[] ) -> return (o,n)- (_,_,errs) -> do hPutStrLn stderr (concat errs)+ case (getOpt Permute cmdOpts argv) of+ (o,n,[] ) -> return (o,n)+ (_,_,errs) -> do hPutStrLn stderr (concat errs) usage exitFailure usage :: IO ()@@ -335,8 +335,8 @@ ghcTypeToType tcl (AppTy t0 t1) = ghcTypeToType tcl t0 `TA` ghcTypeToType tcl t1 ghcTypeToType tcl (TyConApp tc ts) = let nstr = showSDoc (pprParenSymName tc) tc' = case Data.Map.lookup nstr (fst tcl) of - Nothing -> TC $ (-1 - bakaHash nstr) -- error "nameToTyCon: unknown TyCon"- Just c -> TC c+ Nothing -> TC $ (-1 - bakaHash nstr) -- error "nameToTyCon: unknown TyCon"+ Just c -> TC c in foldl TA tc' $ map (thcTypeToType tcl) ts ghcTypeToType tcl (FunTy t0 t1) = ghcTypeToType tcl t0 :-> ghcTypeToType tcl t1 ghcTypeToType tcl (ForAllTy v ty) = panic "Please make it monomorphic by giving a type signature."@@ -353,8 +353,8 @@ [] -> (so, inp) putStrLn ("the predicate is "++pred) hPutStrLn qhandle pred- (out,_) <- answerSIO so' pgf hscEnv pred- hPutStrLn ohandle out+ (out,_) <- answerSIO so' pgf hscEnv pred+ hPutStrLn ohandle out answerSIO :: ServerOptions -> ProgGenSF -> HscEnv -> String -> IO (String, Int) answerSIO so pgf hscEnv pred = do@@ -379,7 +379,7 @@ -- In this case, the type obtained by exprType is polymorphic, so there is no point in adding the type signature. let sig = "" #else- ty <- exprType $ "\\f->("++predStr++")`asTypeOf`True" -- `asTypeOf` True をいれないと、 predStr = "f True True" のときにserverがpanic!になる。+ ty <- exprType $ "\\f->("++predStr++")`asTypeOf`True" -- `asTypeOf` True をいれないと、 predStr = "f True True" のときにserverがpanic!になる。 let sig = " :: " ++ removeQuantification (map crlfToSpace $ showPpr $ extractArgTy ty) #endif return $ Left (funIO, sig)
MagicHaskeller/T10.hs view
@@ -62,7 +62,7 @@ Just GT -> y : mergeWithByBot op cmp (x:xs) ys Just EQ -> x `op` y : mergeWithByBot op cmp xs ys Just LT -> x : mergeWithByBot op cmp xs (y:ys)- Nothing -> mergeWithByBot op cmp xs ys+ Nothing -> mergeWithByBot op cmp xs ys -- Actually it is questionable if we may remove both of the expressions compared just because comparison between them fails, because only one of them might be responsible. -- cmp returns Nothing when the comparison causes time-out.@@ -75,7 +75,7 @@ Just GT -> (y :) <$> mergeWithByBotIO op cmp (x:xs) ys Just EQ -> (x `op` y :) <$> mergeWithByBotIO op cmp xs ys Just LT -> (x :) <$> mergeWithByBotIO op cmp xs (y:ys)- Nothing -> mergeWithByBotIO op cmp xs ys+ Nothing -> mergeWithByBotIO op cmp xs ys -- Actually it is questionable if we may remove both of the expressions compared just because comparison between them fails, because only one of them might be responsible. diffSortedBy _ [] _ = []@@ -86,24 +86,24 @@ diffSortedByBot _ [] _ = [] diffSortedByBot _ vs [] = vs diffSortedByBot op vs@(c:cs) ws@(d:ds) = case op c d of- Just EQ -> diffSortedByBot op cs ds+ Just EQ -> diffSortedByBot op cs ds Just LT -> c : diffSortedByBot op cs ws Just GT -> diffSortedByBot op vs ds--- Nothing -> c : diffSortedByBot op cs ds -- I just do not know what is the best solution here, but when timeout happens, I temporarily believe @c@, and skip d.- Nothing -> diffSortedByBot op cs ds -- The above turned out to be not a good solution, because when an error (or a timeout) happens, the expression repeatedly appears at each depth. See newnotes on Dec. 18, 2011+-- Nothing -> c : diffSortedByBot op cs ds -- I just do not know what is the best solution here, but when timeout happens, I temporarily believe @c@, and skip d.+ Nothing -> diffSortedByBot op cs ds -- The above turned out to be not a good solution, because when an error (or a timeout) happens, the expression repeatedly appears at each depth. See newnotes on Dec. 18, 2011 -- filters only emptySubst tokoro10nil :: Eq k => [([a],[k],i)] -> [([a],[k],i)] tokoro10nil xs = case partition (\ (_,k,_) -> k==[] ) xs of ([], diff) -> diff- (same@((_,_,i):_), diff) -> (concat (map (\ (a,_,_) -> a) same), [], i) : diff+ (same@((_,_,i):_), diff) -> (concat (map (\ (a,_,_) -> a) same), [], i) : diff {- -- $B$A$c$s$H7W;;$7$F$J$$$1$I!$(BO(n^2)$B$/$i$$!)(B $B$?$@!$MWAG?t(Bn$B$O>/$J$$$C$]$$$N$G$3$C$A$NJ}$,B.$$$+$b(B tokoro10 :: Eq k => [([a],k,i)] -> [([a],k,i)] tokoro10 [] = [] tokoro10 ((es,k,i):xs) = case partition (\ (_,k',_) -> k==k' ) xs of- (same, diff) -> (es ++ concat (map (\ (a,_,_) -> a) same), k, i) : tokoro10 diff+ (same, diff) -> (es ++ concat (map (\ (a,_,_) -> a) same), k, i) : tokoro10 diff -} {- quicksort$B$NJQ7A(B tokoro10 :: (Eq k, Ord k) => [([a],k,i)] -> [([a],k,i)]@@ -113,8 +113,8 @@ -- {-# INLINE partition3 #-} partition3 k ts = foldr (select3 k) ([],[],[]) ts select3 k t@(x,k',_) (ls,es,gs) = case k' `compare` k of LT -> (t:ls, es, gs)- EQ -> ( ls, x:es, gs)- GT -> ( ls, es, t:gs)+ EQ -> ( ls, x:es, gs)+ GT -> ( ls, es, t:gs) -} -- merge sort could be much faster.
MagicHaskeller/TimeOut.hs view
@@ -99,7 +99,7 @@ -- let ticks = fromInteger (clk_tck * toInteger timeInMicroSecs `div` 1000000) resMV <- newEmptyMVar do- (catchIt resMV (do+ (catchIt resMV (do tid <- myThreadId chtid <- forkIO (do threadDelay timeInMicroSecs -- wait deadline -- this line makes sure that timeInMicroSecs has really passed in the process time, but I guess this has no sense, because userTime is shared among Concurrent Haskell threads.@@ -107,10 +107,10 @@ putMVar resMV Nothing hPutStrLn stderr "killing the main" killThread tid)- -- res <- action (catchYield tid resMV)+ -- res <- action (catchYield tid resMV) res <- action (yield>>) hPutStrLn stderr "writing Just"- res `dsq` putMVar resMV (Just res)+ res `dsq` putMVar resMV (Just res) hPutStrLn stderr "killing the thread for timeout" killThread chtid)) hPutStrLn stderr "reading MV"
MagicHaskeller/TyConLib.hs view
@@ -18,11 +18,11 @@ tyConsToTCL tcs = (Map.fromListWith (\new old -> old) [ tup | k <- [0..7], tup <- tcsByK ! k ], tcsByK) where tnsByK :: Array Kind [TypeName]- tnsByK = accumArray (flip (:)) [] (0,7) (reverse (nub tcs))- tcsByK :: Array Kind [(TypeName,TyCon)]- tcsByK = listArray (0,7) [ tnsToTCs (tnsByK ! k) | k <- [0..7] ]- tnsToTCs :: [TypeName] -> [(TypeName,TyCon)]- tnsToTCs tns = zipWith (\ i tn -> (tn, i)) [0..] tns+ tnsByK = accumArray (flip (:)) [] (0,7) (reverse (nub tcs))+ tcsByK :: Array Kind [(TypeName,TyCon)]+ tcsByK = listArray (0,7) [ tnsToTCs (tnsByK ! k) | k <- [0..7] ]+ tnsToTCs :: [TypeName] -> [(TypeName,TyCon)]+ tnsToTCs tns = zipWith (\ i tn -> (tn, i)) [0..] tns -- other info is used when adding type constructors as functions@@ -50,8 +50,8 @@ nameToTyCon :: TyConLib -> String -> TyCon nameToTyCon (fm,_) name = case Map.lookup name fm of- Nothing -> error "nameToTyCon: unknown TyCon"- Just c -> c+ Nothing -> error "nameToTyCon: unknown TyCon"+ Just c -> c thTypesToTCL thts = tyConsToTCL (thTypesToTyCons thts ++ defaultTyCons) thTypesToTyCons :: [TH.Type] -> [(Kind,TypeName)]
MagicHaskeller/Types.lhs view
@@ -10,7 +10,7 @@ emptySubst, apply, mgu, varBind, match, maxVarID, normalizeVarIDs, normalize, Decoder(..), typer, typee, negateTVIDs, limitType, saferQuantify, quantify, quantify', unquantify, lookupSubst, unifyFunAp, alltyvars, mapTV, size, unitSubst, applyCheck, assertsubst, substOK, eqType, getRet, getArity, getLongerArity, splitArgs, getArgs, pushArgs, popArgs, mguFunAp, revSplitArgs, revGetArgs, splitArgsCPS, module Data.Int- ) where+ ) where import Data.List import Control.Monad import Data.Char(ord)@@ -63,8 +63,8 @@ arbType 0 = oneof [liftM TV arbitrary, liftM TC arbitrary] arbType n = frequency [ (8, arbType 0),- (2, liftM2 TA (arbType (n `div` 2)) (arbType (n `div` 2))),- (2, liftM2 (:->) (arbType (n `div` 2)) (arbType (n `div` 2))) ]+ (2, liftM2 TA (arbType (n `div` 2)) (arbType (n `div` 2))),+ (2, liftM2 (:->) (arbType (n `div` 2)) (arbType (n `div` 2))) ] #endif -- {-# INLINE mapTV #-}@@ -72,11 +72,11 @@ mapTV f t = -- if t/=t then undefined else mtv t where mtv (TA t0 t1) = TA (mtv t0) (mtv t1)- mtv (t1 :=> t0) = (mtv t1) :=> (mtv t0)- mtv (t1 :-> t0) = (mtv t1) :-> (mtv t0)- mtv (t1 :> t0) = (mtv t1) :> (mtv t0)- mtv (TV tv) = TV (f tv)- mtv tc@(TC _) = tc+ mtv (t1 :=> t0) = (mtv t1) :=> (mtv t0)+ mtv (t1 :-> t0) = (mtv t1) :-> (mtv t0)+ mtv (t1 :> t0) = (mtv t1) :> (mtv t0)+ mtv (TV tv) = TV (f tv)+ mtv tc@(TC _) = tc negateTVIDs :: Type -> Type negateTVIDs = mapTV (\tvid -> -1 - tvid)@@ -89,13 +89,13 @@ limitType n (TA t u) = lt n t u lt n t u = case limitType n t of m | m > 0 -> limitType m u- | otherwise -> -1+ | otherwise -> -1 alltyvars :: Type -> Subst -> [TyVar] alltyvars ty s = alltyvars' ty s [] alltyvars' :: Type -> Subst -> [TyVar] -> [TyVar] alltyvars' (TV tv) s = case lookupSubst s tv of Just t -> alltyvars' t s- Nothing -> (tv:)+ Nothing -> (tv:) alltyvars' (TC tc) s = id alltyvars' (TA t u) s = alltyvars' t s . alltyvars' u s alltyvars' (u :> t) s = alltyvars' t s . alltyvars' u s@@ -134,7 +134,7 @@ arbKind 0 = return Star arbKind n = frequency [ (4, return Star),- (1, liftM2 (::->) (arbKind (n `div` 2)) (arbKind (n `div` 2))) ]+ (1, liftM2 (::->) (arbKind (n `div` 2)) (arbKind (n `div` 2))) ] -} type Kind = Int @@ -159,10 +159,10 @@ normalizeVarIDs ty mx = let decoList = sieve $ tyvars ty tup = zip decoList [0..] encoType = mapTV (\tv -> case lookup tv tup of Just n -> n) ty- len = genericLength decoList- margin = -- trace ("normalizeVarIDs: mx == "++show mx++ " and len = " ++ show len) $+ len = genericLength decoList+ margin = -- trace ("normalizeVarIDs: mx == "++show mx++ " and len = " ++ show len) $ mx + 1 - len- in -- trace ("len = " ++ show len) $ $B$[$H$s$I$N%1!<%9$G(B0$B$+(B1$B!$$?$^!<$K(B2$B$+(B3+ in -- trace ("len = " ++ show len) $ $B$[$H$s$I$N%1!<%9$G(B0$B$+(B1$B!$$?$^!<$K(B2$B$+(B3 (encoType, Dec decoList margin) where sieve [] = [] sieve (x:xs) = x : sieve [ y | y <- xs, y /= x ]@@ -233,7 +233,7 @@ pa n args (t0:->t1) = pa (n+1) (t0:args) t1 pa n args (t0:>t1) = pa (n+1) (t0:args) t1 pa n args (t0:=>t1) = pa (n+1) (t0:args) t1- pa n args retty = f n args retty+ pa n args retty = f n args retty pushArgs :: [Type] -> Type -> ([Type],Type) pushArgs = pushArgsCPS (\i a r -> (a,r))@@ -314,8 +314,8 @@ match _ _ = mzero match2Ap l r l' r' = do s1 <- match l l'- s2 <- match (apply s1 r) r'- return (s2 `plusSubst` s1)+ s2 <- match (apply s1 r) r'+ return (s2 `plusSubst` s1) -- mgu t t' = mgu' (toChin t) (toChin t')@@ -333,8 +333,8 @@ mgu _ _ = mzero mgu2Ap l r l' r' = do s1 <- mgu l l'- s2 <- mgu (apply s1 r) (apply s1 r')- return (s2 `plusSubst` s1)+ s2 <- mgu (apply s1 r) (apply s1 r')+ return (s2 `plusSubst` s1) varBind :: MonadPlus m => TyVar -> Type -> m Subst varBind _ (_:=>_) = mzero@@ -351,23 +351,23 @@ instance Show Type where -- classes$B$rI=<($9$k$N$,$a$s$I$$!%:G=i$K$^$H$a$J$-$c%@%a(B? ReadType$B$N$H$3$m$G(BPrinter$B$G$d$C$H$-$c3Z$@$C$?$+$b!%(B showsPrec _ ty = toString' 0 ty -- The kind info can be incorrect, because we assume *.- where toString' k (TV i) = ('a':) . shows i -- can be used to synthesize a generically typed program.- toString' k (TC i) = ('K':) . shows k . ('I':) . shows i- toString' k (TA t0 t1) = showParen True (toString' (k+1) t0 . (' ':) . toString' 0 t1) -- mandatory, just in case.- toString' k (t0 :=> t1) = showParen True (toString' 0 t0 . ("=>"++) . toString' 0 t1)- toString' k (t0 :-> t1) = showParen True (toString' 0 t0 . ("->"++) . toString' 0 t1)+ where toString' k (TV i) = ('a':) . shows i -- can be used to synthesize a generically typed program.+ toString' k (TC i) = ('K':) . shows k . ('I':) . shows i+ toString' k (TA t0 t1) = showParen True (toString' (k+1) t0 . (' ':) . toString' 0 t1) -- mandatory, just in case.+ toString' k (t0 :=> t1) = showParen True (toString' 0 t0 . ("=>"++) . toString' 0 t1)+ toString' k (t0 :-> t1) = showParen True (toString' 0 t0 . ("->"++) . toString' 0 t1) toString' k (t0 :> t1) = showParen True (("(->) "++) . toString' 0 t0 . (' ':) . toString' 0 t1) plusSubst :: Subst -> Subst -> Subst s0 `plusSubst` s1 = [(u, -- if u `elem` tvids t then error "u is in t" else- -- trace ("in plusSubst, s0="++show s0) $+ -- trace ("in plusSubst, s0="++show s0) $ applyCheck s0 t) | (u,t) <- s1] ++ s0 {- prop_merge t0 t1 u0 u1 = mgu (t0:->t1) (u0:->u1) == ((do s0 <- mgu t0 u0- s1 <- mgu t1 u1- symPlus s0 s1) :: [Subst])+ s1 <- mgu t1 u1+ symPlus s0 s1) :: [Subst]) -} -- $B=[4D$7$F$$$k>l9g$O(BplusSubst$B$,(Billegal$B$K$J$j$&$k(B@@ -383,14 +383,14 @@ apply :: Subst -> Type -> Type apply subst ty = apply' ty- where apply' tc@(TC _) = tc- apply' tg@(TV tv)+ where apply' tc@(TC _) = tc+ apply' tg@(TV tv) = case lookupSubst subst tv of Just tt -> tt- Nothing -> tg- apply' (TA t0 t1) = TA (apply' t0) (apply' t1)- apply' (t0:->t1) = apply' t0 :-> apply' t1- apply' (t0:>t1) = apply' t0 :> apply' t1- apply' (t0:=>t1) = apply' t0 :=> apply' t1+ Nothing -> tg+ apply' (TA t0 t1) = TA (apply' t0) (apply' t1)+ apply' (t0:->t1) = apply' t0 :-> apply' t1+ apply' (t0:>t1) = apply' t0 :> apply' t1+ apply' (t0:=>t1) = apply' t0 :=> apply' t1 applyCheck subst t = -- trace ("t= " ++ show t ++ " and subst = "++ show subst) $ apply subst t