MagicHaskeller 0.9.6.4.7 → 0.9.6.5
raw patch · 13 files changed
+168/−137 lines, 13 filesdep ~tf-random
Dependency ranges changed: tf-random
Files
- MagicHaskeller.cabal +10/−4
- MagicHaskeller/CGI.lhs +14/−16
- MagicHaskeller/ExpToHtml.hs +7/−4
- MagicHaskeller/Expression.hs +38/−7
- MagicHaskeller/LibExcel.hs +2/−5
- MagicHaskeller/LibExcelStaged.hs +2/−3
- MagicHaskeller/ProgGenSF.lhs +35/−32
- MagicHaskeller/ProgGenSFIORef.lhs +2/−2
- MagicHaskeller/ProgramGenerator.lhs +20/−32
- MagicHaskeller/Types.lhs +27/−24
- MagicHaskeller/predicatesAug2014 +2/−4
- MagicHaskeller/predicatesServed +2/−4
- changelog.txt +7/−0
MagicHaskeller.cabal view
@@ -1,5 +1,5 @@ Name: MagicHaskeller-Version: 0.9.6.4.7+Version: 0.9.6.5 Cabal-Version: >= 1.8 License: BSD3 License-file: LICENSE @@ -63,7 +63,7 @@ cpp-options: -DCHTO -DCABAL if flag(TFRANDOM)- Build-depends: tf-random <= 0.3+ Build-depends: tf-random <= 0.3 || >= 0.5 cpp-options: -DTFRANDOM if flag(GHCAPI) && !os(windows)@@ -97,7 +97,7 @@ cpp-options: -DUNIX if flag(TFRANDOM)- Build-depends: tf-random+ Build-depends: tf-random <= 0.3 || >= 0.5 cpp-options: -DTFRANDOM -- just for avoiding rebuilding everything@@ -108,6 +108,9 @@ if impl(ghc >= 7) GHC-options: -with-rtsopts=-N + if flag(DEBUG)+ cpp-options: -DREALDYNAMIC+ if flag(NETWORKURI) Build-depends: network >= 2.6, network-uri >= 2.6 else@@ -128,8 +131,11 @@ cpp-options: -DUNIX if flag(TFRANDOM)- Build-depends: tf-random+ Build-depends: tf-random <= 0.3 || >= 0.5 cpp-options: -DTFRANDOM++ if flag(DEBUG)+ cpp-options: -DREALDYNAMIC if flag(NETWORKURI) Build-depends: network >= 2.6, network-uri >= 2.6
MagicHaskeller/CGI.lhs view
@@ -176,7 +176,7 @@ detail' config predicate = "<FORM ACTION=\""++myPath config++"\" METHOD=GET>" ++- " f = <INPUT TYPE=TEXT NAME='predicate' VALUE='"++ parenthesize (concatMap escapeQuote predicate)++"' SIZE=90> <INPUT TYPE=\"submit\" VALUE=\"Exemplify\">" +++ " f = <INPUT TYPE=TEXT NAME='predicate' VALUE='"++ concatMap escapeQuote predicate ++"' SIZE=90> <INPUT TYPE=\"submit\" VALUE=\"Exemplify\">" ++ " </FORM>" ++ " <BR> satisfies the following input-output relation: <BR><BR>" -- about `display: inline;', See newnotes on Nov. 1, 2012 and http://www.cs.tut.fi/~jkorpela/forms/extraspace.html@@ -280,7 +280,7 @@ -- liftIO $ putStrLn "exemplified." logCGI $ "MagHLogUser " ++ candi case mbresult of Left msg -> output $ detailsHead config ++ blameQuery (qBox "Exemplify") msg ++ lastLines False- Right result -> output $ detail config candi ++ "<table border=0 cellspacing=0 align=left>"++result ++"</table>"++ lastLines useJS+ Right result -> output $ detail config (parenthesize candi) ++ "<table border=0 cellspacing=0 align=left>"++result ++"</table>"++ lastLines useJS #else output $ unavailable config #endif@@ -433,17 +433,15 @@ _ -> error "Only one of 'inputs' and 'output' is set." case review augPred of- Nothing -> - showError verInfo config augPred- "<br><br>Error: <b>let</b> expressions and <b>where</b> clauses are prohibited here. You can still use <b>case</b> expressions without <b>where</b> clauses for non-recursive bindings.<br>"- Just (predi, corrected) -> + Left msg -> showError verInfo config augPred msg+ Right (predi, corrected) -> if needSignature config then case addSignature predi of- [] -> showError verInfo config augPred "<br><br>lex error<br>"- [sigPred] -> organizeSynthesis' verInfo config True showAbsents predi sigPred useJS- else organizeSynthesis' verInfo config corrected showAbsents predi predi useJS+ [] -> showError verInfo config augPred "<br><br>Lex error!<br>"+ [sigPred] -> organizeSynthesis' verInfo config True showAbsents augPred predi sigPred useJS+ else organizeSynthesis' verInfo config corrected showAbsents augPred predi predi useJS -organizeSynthesis' verInfo config corrected showAbsents predicate sigPred useJS = do+organizeSynthesis' verInfo config corrected showAbsents origPred predicate sigPred useJS = do mbPage <- readInput "page" mbDepth <- readInput "depth" @@ -456,20 +454,20 @@ result <- liftIO $ synthesize config $ shows Q{depth = theReqDepth, absents = showAbsents} sigPred - let body = case result of '!':res -> "<p>"++blamePredicate predicate res+ let body = case result of '!':res -> "<p>"++blamePredicate origPred res _ -> notice++clipped results = lines result- notice | corrected = "<H3>Results:<div class=notice>(Interpreted as "++stringToHtmlString sigPred++")</div></H3>"+ notice | corrected = "<H3>Results:<div class=notice>(Corrected from "++stringToHtmlString origPred++")</div></H3>" | otherwise = "<H3>Results:</H3>" clipped = case mbPage of Nothing -> case mbDepthBound of Nothing -> let shownDepth = maybe (minimalDepth config) id mbDepth- in byDepth config shownDepth showAbsents results predicate useJS+ in byDepth config shownDepth showAbsents results origPred useJS Just shownDepth ->- byDepthBound config shownDepth (showAbsents && useJS) results predicate+ byDepthBound config shownDepth (showAbsents && useJS) results origPred Just pg -> absentButton (showAbsents && useJS) ++ case takeNFORMs (pagesize config) (dropNFORMs (pred pg * pagesize config) result) of- (True, sc) -> sc ++ next (myPath config) (succ pg) showAbsents predicate+ (True, sc) -> sc ++ next (myPath config) (succ pg) showAbsents origPred (False,sc) -> sc output $ firstlines verInfo config showAbsents predicate ++ body ++ lastLines useJS @@ -497,7 +495,7 @@ , loadFile = "" , printType = False , extensions = False- , namedExtensions = []+ , namedExtensions = ["FlexibleInstances", "UndecidableInstances", "OverlappingInstances", "IncoherentInstances", "ExtendedDefaultRules"] , noImports = False , rLimits = False , help = False }
MagicHaskeller/ExpToHtml.hs view
@@ -28,11 +28,14 @@ -- | 'review' makes sure the predicate string does not use either let or where, and may correct grammatical mistakes. -- This check should be done on both the CGI frontend side and the backend server side.-review :: Monad m => String -> m (String,Bool)+-- (But actually is done only on the CGI side.)+review :: String -> Either String (String,Bool) review "" = return ("",False) review xs = case lex xs of- [("let", _)] -> fail "let"- [("where", _)] -> fail "where"+ [] | '"':_ <- dropWhile isSpace xs -> Left "<br><br>Lex error: maybe double-quotes are not balanced.<br>" -- Unbalanced double-quotes may be automatically closed at the end, but that can be confusing.+ | otherwise -> Left "<br><br>Lex error!<br>"+ [("let", _)] -> Left loopErrMsg+ [("where", _)] -> Left loopErrMsg [("=", rest)] -> do (zs,_) <- review rest return ("~= "++zs, True) [("&", rest)] -> do (zs,_) <- review rest@@ -43,7 +46,7 @@ return ("(1/0) "++zs, True) [(tkn, rest)] -> do (zs,repl) <- review rest return (tkn++' ':zs, repl)-+loopErrMsg = "<br><br>Error: <b>let</b> expressions and <b>where</b> clauses are prohibited here. You can still use " ++ refLink "case" "case" ++ " expressions without <b>where</b> clauses for non-recursive bindings.<br>"
MagicHaskeller/Expression.hs view
@@ -24,7 +24,8 @@ import qualified Data.Set as S import qualified Data.IntMap as IM -import Data.List(sortBy, genericIndex)+import Data.List+import Data.Array -- AnnExpr remembers each Dynamic corresponding to the CoreExpr. data AnnExpr = AE CoreExpr Dynamic deriving Show@@ -52,7 +53,7 @@ {-# SPECIALIZE mkHead :: (CoreExpr->Dynamic) -> Int -> Int -> CoreExpr -> e #-} {-# SPECIALIZE mkHead :: (CoreExpr->Dynamic) -> Int8 -> Int8 -> CoreExpr -> e #-} class (Ord e, Show e) => Expression e where- mkHead :: (Integral i, Integral j) => (CoreExpr->Dynamic) -> i -> j -> CoreExpr -> e+ mkHead :: (Integral i, Integral j) => (CoreExpr->Dynamic) -> i -> j -> j -> CoreExpr -> e toCE :: e -> CoreExpr fromCE :: (CoreExpr -> Dynamic) -> CoreExpr -> e mapCE :: (CoreExpr -> CoreExpr) -> e -> e -- $B$3$l$bJQ!%(B@@ -70,9 +71,10 @@ reorganizeId' fun avail = case cvtAvails' avail of (args, newavail) -> fmap (\e -> replaceVars' 0 e args) $ fun newavail+ decodeVars :: Int -> [Int8] -> e -> e instance Expression CoreExpr where- mkHead _ _ _ = id+ mkHead _ _ _ _ = id toCE = id fromCE _ = id mapCE = id@@ -86,9 +88,10 @@ reorganize' = reorganizeCE' reorganizeId = reorganizerId replaceVars' = replaceVarsCE'+ decodeVars = const decodeVarsCE instance Expression AnnExpr where- mkHead reduce lenavails arity ce = mkHeadAE reduce (fromIntegral lenavails) (fromIntegral arity) ce- toCE (AE ce _) = ce+ mkHead reduce lenavails numcxts arity ce = mkHeadAE reduce (fromIntegral lenavails) (fromIntegral numcxts) (fromIntegral arity) ce+ toCE ae@(AE ce _) = ce fromCE = toAnnExpr mapCE f (AE ce d) = AE (f ce) d #ifdef REALDYNAMIC@@ -106,12 +109,40 @@ reorganizeId = id reorganizeId' = id -- Well, this is overridden to id because replaceVars' for AnnExpr is not yet implemented. -- $B$F$JLu$G!%<BAu$9$Y$7!*!*!*!*!*!*!*!*!*!*!*!*!*!*!*!*!*!*!*!*!*!*!*!*!*(B+ decodeVars = decodeVarsAE +mapFst3 f (ces, s, i) = (f ces, s, i)+decodeVarsPos vs = mapFst3 (map (decodeVarsCE vs))++decodeVarsCE :: [Int8] -> CoreExpr -> CoreExpr+decodeVarsCE vs = decodeVarsCE' 0 (listArray (0, genericLength vs-1) vs)+decodeVarsCE' :: Int8 -> Array Int8 Int8 -> CoreExpr -> CoreExpr+decodeVarsCE' offset ar e@(X n) = let nn = n - offset+ in if inRange (bounds ar) nn then X $ (ar ! nn) + offset else e+decodeVarsCE' offset ar (Lambda e) = Lambda $ decodeVarsCE' (offset + 1) ar e+decodeVarsCE' offset ar (f :$ e) = decodeVarsCE' offset ar f :$ decodeVarsCE' offset ar e+decodeVarsCE' offset ar e = e++decodeVarsAE :: Int -> [Int8] -> AnnExpr -> AnnExpr+decodeVarsAE lenav vs (AE ce dyn) = AE (decodeVarsCE vs ce) (decodeVarsDyn lenav vs dyn)++decodeVarsDyn :: Int -> [Int8] -> Dynamic -> Dynamic+decodeVarsDyn lenav vs dyn = insAbsents (fromIntegral lenav) (map (fromIntegral lenav-1-) $ reverse vs) `dynApp` dyn++insAbsents :: Int8 -> [Int8] -> Dynamic+insAbsents lenav ns = -- trace ("insAbsents "++show lenav ++ ' ':show ns) + ia 0 ns where+ ia i [] | i ==lenav = dynI+ ia i (n:ns) | i == n = dynB `dynApp` ia (succ i) ns + ia i ms = dynBK `dynApp` ia (succ i) ms+++ (<$>) :: Expression e => e -> e -> e (<$>) = aeAppErr "" -mkHeadAE _ lenavails arity ce@(X i) = AE ce (getDyn_LambdaBoundHead i lenavails arity) -- Note that 'dynss' and 'dynsss' uses-mkHeadAE reduce lenavails arity ce = AE ce ((getDyn lenavails arity) `dynApp` reduce ce) -- 'unsafeExecute' instead of 'reduce'.+mkHeadAE _ lenavails _ arity ce@(X i) = AE ce (getDyn_LambdaBoundHead i lenavails arity) -- Note that 'dynss' and 'dynsss' uses+mkHeadAE reduce lenavails numcxts arity ce = AE ce ((iterate (dynB `dynApp`) (getDyn lenavails arity) !! numcxts) `dynApp` reduce ce) -- 'unsafeExecute' instead of 'reduce'. windType :: Type -> CoreExpr -> CoreExpr windType (a:->b) e = Lambda (windType b e)
MagicHaskeller/LibExcel.hs view
@@ -8,7 +8,7 @@ import MagicHaskeller.LibExcelStaged import MagicHaskeller.Types(size) import Control.Monad(liftM2)-import Data.List hiding (tail)+import Data.List import Data.Char import Data.Maybe -- import Data.Ratio@@ -20,14 +20,12 @@ import qualified Data.IntMap as IM import Data.Hashable -import Prelude hiding (tail, gcd, enumFromThenTo)- -- whether succ is used only for numbers or not succOnlyForNumbers = True -- This is True for Excel. -- total variants of prelude functions last' = (\x xs -> last (x:xs))-tail = drop 1+ -- init xs = zipWith const xs (drop 1 xs) @@ -79,7 +77,6 @@ ppExcel (AppE (InfixE Nothing op m@(Just _)) e) = ppExcel (InfixE (Just e) op m) ppExcel (AppE v@(VarE name) e) = case nameBase name of- "tail" -> ppdrop 1 e "negate" -> case ppe of LitE (IntegerL i) -> LitE $ IntegerL $ (-i) LitE (RationalL r) -> LitE $ RationalL $ (-r) _ -> mkVarOp (LitE $ IntegerL 0) "-" ppe -- @negate x@ should become @0 - x@
MagicHaskeller/LibExcelStaged.hs view
@@ -2,12 +2,11 @@ import MagicHaskeller import Data.List import Data.Char-import Prelude hiding (gcd) default (Int, Integer, Double) -- gcd in the latest library is total, but with older versions gcd 0 0 causes an error. -gcd x y = gcd' (abs x) (abs y)+totalGCD x y = gcd' (abs x) (abs y) where gcd' a 0 = a gcd' a b = gcd' b (a `rem` b) @@ -128,7 +127,7 @@ radians = ((pi/180)*) -gCD (m, n) = gcd (truncate m) (truncate n)+gCD (m, n) = totalGCD (truncate m) (truncate n) findIx c xs n = finD(char(7), sUBSTITUTE(concatenate(c,xs), c, char(7), 1+abs(n)))-1 finD(c, xs) = maybe undefined id $ fIND(c, xs, 1)
MagicHaskeller/ProgGenSF.lhs view
@@ -40,6 +40,8 @@ import Data.Bits -- used for absence analysis import Data.Word +import Data.Array+ #if __GLASGOW_HASKELL__ >= 710 import Prelude hiding ((<$>)) #endif@@ -113,7 +115,7 @@ -- memocond av ty = size ty + sum (map size av) < 10 -instance ProgramGenerator (PGSF CoreExpr) where+instance (Expression e) => ProgramGenerator (PGSF e) where mkTrieOpt = mkTrieOptSF matchingProgramsWOAbsents ty (PGSF (_,_,cmn) _ etrie) = fromMx $ zipDepthMx (\i es -> if i < getArity ty - 1 then [] else es) $ matchProgs cmn etrie ty -- absents ga nai baai matchingPrograms ty pgsf@(PGSF (_,_,cmn) _ _) = fromRc $ fmap (toAnnExprWindWind (reducer cmn) ty) $ lookupWithAbsents pgsf ty -- absents mo fukumeru baai@@ -123,7 +125,7 @@ unifyingPossibilities ty memodeb = unPS (unifyableExprs memodeb [] ty) emptySubst 0 -matchProgs :: Common -> ExpTrie CoreExpr -> Type -> Matrix AnnExpr+matchProgs :: Expression e => Common -> ExpTrie e -> Type -> Matrix AnnExpr matchProgs cmn etrie ty = fmap (toAnnExprWindWind (reducer cmn) ty) $ lookupReorganized etrie ty -- こっちだとlookup {- matchProgs memodeb ty = fmap toAnnExpr $ wind (fmap (mapCE Lambda)) (lookupFuns memodeb) [] (quantify ty) -- こっちだとrecompute というと語弊がある．recomputeしたきゃlmtのところを変えるべし．@@ -148,7 +150,7 @@ type MemoDeb e = (ClassLib e, (([[Prim]],[[Prim]]),([[Prim]],[[Prim]])), Common) -mkTrieOptSF :: Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]] -> PGSF CoreExpr+mkTrieOptSF :: Expression e => Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]] -> PGSF e mkTrieOptSF cmn classes txsopt txs = fix $ \pgsf -> PGSF memoDeb typeTrie $ mkMTexp (tcl cmn) (\ty -> filtBF cmn ty $ matchFunctions pgsf ty) where qtlopt = splitPrimss txsopt@@ -164,7 +166,7 @@ in Mx $ zipWith (diffSortedBy compare) foo ([]:foo) -- in Mx $ zipWith (\\) foo ([]:foo) -}-mkTrieOptSFIO :: Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]] -> IO (PGSF CoreExpr)+mkTrieOptSFIO :: Expression e => Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]] -> IO (PGSF e) mkTrieOptSFIO cmn classes txsopt txs = fixIO $ \pgsf -> fmap (PGSF memoDeb typeTrie) $ mkMTIO (tcl cmn) (\ty -> filtBFIO cmn ty $ matchFunctions pgsf ty) where qtlopt = splitPrimss txsopt@@ -226,12 +228,12 @@ -specializedTypes :: (Search m) => MemoDeb CoreExpr -> TypeTrie -> [Type] -> Type -> PriorSubsts m ([Type],Type)+specializedTypes :: (Search m, Expression e) => MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m ([Type],Type) specializedTypes memodeb ttrie avail t = do _ <- specializedCases memodeb ttrie avail t subst <- getSubst return (map (apply subst) avail, apply subst t) -- specializedCases is the same as unifyableExprs, except that the latter returns PriorSubsts BF [CoreExpr], and that the latter considers memodepth.-specializedCases, specCases :: (Search m) => MemoDeb CoreExpr -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet+specializedCases, specCases :: (Search m, Expression e) => MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet specializedCases memodeb ttrie = applyDo (specCases memodeb ttrie) -- specCases memodeb = wind_ (\avail reqret -> reorganize_ (\newavail -> uniExprs_ memodeb newavail reqret) avail) specCases memodeb ttrie avail (t0:->t1) = fmap (`unsafeShiftR` 1) $ specCases memodeb ttrie (t0 : avail) t1@@ -241,7 +243,7 @@ -uniExprs_ :: (Search m) => MemoDeb CoreExpr -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet+uniExprs_ :: (Search m, Expression e) => MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet {- uniExprs_ memodeb avail t = convertPS fromRc $ psListToPSRecomp lfp@@ -269,7 +271,7 @@ in reorganizerId' (\av -> lmt md $ popArgs av retty) avs -- entry point for memoization-specTypes :: MemoDeb CoreExpr -> TypeTrie -> Type -> PriorSubsts Recomp Type+specTypes :: Expression e => MemoDeb e -> TypeTrie -> Type -> PriorSubsts Recomp Type specTypes memodeb ttrie ty = let (avail,t) = splitArgs ty in convertPS (zipDepthRc (\i es -> if i < length avail - 1 then [] else es)) $ do@@ -314,7 +316,7 @@ mguAssumptionsBits patty assumptions = applyDo mguAssumptionsBits' assumptions patty mguAssumptionsBits' assumptions patty = msum $ zipWith (\n t -> mguPS patty t >> return (1 `shiftL` n)) [0..] assumptions -specCases' :: MemoDeb CoreExpr -> TypeTrie -> [Type] -> Type -> PriorSubsts Recomp ()+specCases' :: Expression e => MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts Recomp () -- specCases' trie prims@(primgen,primmono) avail reqret = msum (map (retMono.fromPrim) primmono) `mplus` msum (map retMono fromAvail ++ map retGen primgen) specCases' memodeb@(CL classLib, (prims@(primgen,primmono),_),cmn) ttrie avail reqret = mapSum retPrimMono primmono `mplus` msum (zipWith retMono (iterate (`unsafeShiftL` 1) 1) avail) `mplus` mapSum retGen primgen@@ -329,7 +331,7 @@ fullBits | lenavails > 29 = 0 | otherwise = (1 `unsafeShiftL` lenavails) - 1 -- retPrimMono :: (Int, Type, Int, Typed [CoreExpr]) -> PriorSubsts BFT ()- retPrimMono (arity, retty, numtvs, _xs:::ty)+ retPrimMono (_, arity, retty, numtvs, _xs:::ty) = napply arity delayPS $ do tvid <- reserveTVars numtvs mguPS reqret (mapTV (tvid+) retty)@@ -339,7 +341,7 @@ mguPS reqret (getRet ty) fasf ty $ fullBits .&. complement ix -- retGen :: (Int, Type, Int, Typed [CoreExpr]) -> PriorSubsts BFT ()- retGen (arity, _r, numtvs, _s:::ty) = napply arity delayPS $+ retGen (_, arity, _r, numtvs, _s:::ty) = napply arity delayPS $ do tvid <- reserveTVars numtvs -- この（最初の）IDそのもの（つまり返り値のtvID）はすぐに使われなくなる -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTVとapplyはhylo-fusionできるはずだが，勝手にされる？ -- -- unitSubstをinlineにしないと駄目か@@ -351,16 +353,16 @@ fasf gentvar i -- absentを含める場合こっちを使う-lookupWithAbsents :: Search m => PGSF CoreExpr -> Type -> m CoreExpr+lookupWithAbsents :: (Search m, Expression e) => PGSF e -> Type -> m e lookupWithAbsents memodeb ty = case splitArgs ty of (a,r) -> wind (fmap (mapCE Lambda)) (lookupNormalizedSharedET (lookupTypeTrieAndExpTrie memodeb)) a r --unifyableExprs memodeb = applyDo (wind (fmap (map (mapCE Lambda))) (lookupNormalizedShared (\ixs -> map (decodeVarsCE ixs)) (lookupTypeTrieAndExpTrie memodeb))) -lookupNormalizedSharedET :: (Search m, Search n) => (Type -> m ([CoreExpr], Subst, TyVar)) -> [Type] -> Type -> n CoreExpr+lookupNormalizedSharedET :: (Search m, Search n, Expression e) => (Type -> m ([e], Subst, TyVar)) -> [Type] -> Type -> n e lookupNormalizedSharedET fun avail t = let annAvails = zip [0..] avail- in fromRc $ Rc $ \d -> [ decodeVarsCE ixs e+ in fromRc $ Rc $ \d -> [ decodeVars (length avail) ixs e | avs <- combs (d+1) annAvails , let (ixs, newavails) = unzip avs (tn, _decoder) = encode newt (maxVarID newt + 1)@@ -371,22 +373,22 @@ type Generator m e = PGSF e -> [Type] -> Type -> PriorSubsts m ([e], BitSet) -unifyableExprs :: Generator Recomp CoreExpr-unifyableExprs memodeb +unifyableExprs :: Expression e => Generator Recomp e+unifyableExprs memodeb = applyDo (wind (fmap (\ (es, bs) -> (map (mapCE Lambda) es, bs `unsafeShiftR` 1)))- (lookupNormalizedShared (\ixs ixBits e -> (map (decodeVarsCE ixs) e, ixBits)) (lookupTypeTrieAndExpTrie memodeb)))+ (\avail -> lookupNormalizedShared (\ixs ixBits e -> (map (decodeVars (length avail) ixs) e, ixBits)) (lookupTypeTrieAndExpTrie memodeb) avail)) --unifyableExprs memodeb = applyDo (wind (fmap (map (mapCE Lambda))) (lookupNormalizedShared (\ixs -> map (decodeVarsCE ixs)) (lookupTypeTrieAndExpTrie memodeb))) -- memocondexp t d = 1<d && d<7 memocondexp t d = size t < 8 && 0<d && d<7 -lookupTypeTrie :: MemoDeb CoreExpr -> TypeTrie -> Type -> Recomp (Type, Subst, TyVar)+lookupTypeTrie :: Expression e => MemoDeb e -> TypeTrie -> Type -> Recomp (Type, Subst, TyVar) lookupTypeTrie memodeb@(_, _, cmn) ttrie t = Rc $ \d -> unMx (if memoCondPure (opt cmn) t d then lookupNorm (lmtty ttrie) t else freezePS t $ specTypes memodeb ttrie t ) !! d -- if d<8 then d else 7-lookupTypeTrieAndExpTrie :: PGSF CoreExpr -> Type -> Recomp ([CoreExpr], Subst, TyVar)+lookupTypeTrieAndExpTrie :: Expression e => PGSF e -> Type -> Recomp ([e], Subst, TyVar) lookupTypeTrieAndExpTrie (PGSF memodeb@(_, _, cmn) ttrie etrie) t = Rc $ \d -> if memoCondPure (opt cmn) t d then [ (unMx (lookupReorganized etrie $ apply s t) !! d, s, i)@@ -446,16 +448,16 @@ tokoro10fst = M.elems . M.fromListWith const . map (\ t@(k,_,_) -> (k,t)) -- entry for memoization-matchFunctions :: PGSF CoreExpr -> Type -> Recomp CoreExpr+matchFunctions :: (Expression e) => PGSF e -> Type -> Recomp e matchFunctions memodeb ty = -- mapDepth (filter (not . isAbsent (getArity ty))) $ -- KOKO 1 case splitArgs (saferQuantify ty) of (avail,t) -> matchFuns memodeb avail t -- saferQuantify ty = let offset = maxVarID (unquantify ty) + 1 in quantify' $ mapTV (offset+) ty -matchFuns :: PGSF CoreExpr -> [Type] -> Type -> Recomp CoreExpr+matchFuns :: Expression e => PGSF e -> [Type] -> Type -> Recomp e matchFuns memodeb avail reqret = zipDepthRc (\i es -> if i < length avail - 1 then [] else es) $ catBags $ runPS (matchFuns' unifyableExprs memodeb avail reqret) -matchFuns' :: Generator Recomp CoreExpr -> PGSF CoreExpr -> [Type] -> Type -> PriorSubsts Recomp [CoreExpr]+matchFuns' :: Expression e => Generator Recomp e -> PGSF e -> [Type] -> Type -> PriorSubsts Recomp [e] -- matchFuns' = generateFuns matchPS filtExprs lookupListrie -- MemoDebの型の違いでこれはうまくいかなんだ． matchFuns' rec md@(PGSF (CL classLib, (_,(primgen,primmono)),cmn) _ _) avail reqret = let clbehalf = mguPrograms classLib@@ -488,16 +490,16 @@ return es -} convertPS (ndelay arity) $- funApSubBits_forcingNil undefined behalf behalf ty ([ mkHead (reducer cmn) lenavails arity $ X $ fromIntegral n], fullBits `clearBit` n)+ funApSubBits_forcingNil undefined behalf behalf ty ([ mkHead (reducer cmn) lenavails 0 arity $ X $ fromIntegral n], fullBits `clearBit` n) retPrimMonoBits :: (Expression e) => Common -> Int -> BitSet -> (Type -> PriorSubsts Recomp [e]) -> (Type -> PriorSubsts Recomp ([e],BitSet)) -> (Type -> PriorSubsts Recomp ([e],BitSet)) -> (Type -> Type -> PriorSubsts Recomp ()) -> Type -> Prim -> PriorSubsts Recomp [e]-retPrimMonoBits cmn lenavails fullBits clbehalf lltbehalf behalf mps reqret (arity, retty, numtvs, xs:::ty)+retPrimMonoBits cmn lenavails fullBits clbehalf lltbehalf behalf mps reqret (numcxts, arity, retty, numtvs, xs:::ty) = do tvid <- reserveTVars numtvs mps (mapTV (tvid+) retty) reqret convertPS (ndelay arity) $- funApSubBits_forcingNil clbehalf lltbehalf behalf (mapTV (tvid+) ty) (map (mkHead (reducer cmn) lenavails (getLongerArity ty)) xs, fullBits)+ funApSubBits_forcingNil clbehalf lltbehalf behalf (mapTV (tvid+) ty) (map (mkHead (reducer cmn) lenavails numcxts arity) xs, fullBits) funApSubBits, funApSubBits_resetting :: (Search m, Expression e) => (Type -> PriorSubsts m [e]) -> (Type -> PriorSubsts m ([e],BitSet)) -> (Type -> PriorSubsts m ([e],BitSet)) -> Type -> ([e],BitSet) -> PriorSubsts m ([e],BitSet) funApSubBits = funApSubOpBits (<$>)@@ -564,12 +566,12 @@ hex = (quad .&. 0x33333333) + ((quad `unsafeShiftR` 2) .&. 0x33333333) -- hexadecimalary coded in fromIntegral $ ((((hex + (hex `unsafeShiftR` 4)) .&. 0x0F0F0F0F) * 0x01010101) `unsafeShiftR` 24) .&. 0xFF -- The last (.&. 0xFF) should not be necessary when using Word32. -retGenOrdBits cmn lenavails fullBits fe clbehalf lltbehalf behalf reqret (arity, _retty, numtvs, xs:::ty) +retGenOrdBits cmn lenavails fullBits fe clbehalf lltbehalf behalf reqret (numcxts, arity, _retty, numtvs, xs:::ty) = convertPS (ndelay arity) $ do tvid <- reserveTVars numtvs -- この（最初の）IDそのもの（つまり返り値のtvID）はすぐに使われなくなる -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTVとapplyはhylo-fusionできるはずだが，勝手にされる？ -- -- 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)+ (exprs, bs1) <- funApSubBits_resetting clbehalf lltbehalf behalf (mapTV (tvid+) ty) (map (mkHead (reducer cmn) lenavails numcxts (arity+a)) xs, fullBits) gentvar <- applyPS (TV tvid) guard (orderedAndUsedArgs gentvar) -- この辺のcheckをTVnに入る前の早い段階にやるのは1つの考え方だが，TVn中にreplaceされたりはしないのか? (es, bs2) <- funApSub'' False gentvar (fe gentvar ty exprs, bs1)@@ -591,7 +593,7 @@ bs .&. complement ixs) funApSub'' _fe _t tups = return tups -retGenTV1Bits cmn lenavails fullBits fe clbehalf lltbehalf behalf reqret (arity, _retty, numtvs, xs:::ty)+retGenTV1Bits cmn lenavails fullBits fe clbehalf lltbehalf behalf reqret (numcxts, arity, _retty, numtvs, xs:::ty) = convertPS (ndelay arity) $ do tvid <- reserveTVars numtvs -- この（最初の）IDそのもの（つまり返り値のtvID）はすぐに使われなくなる -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTVとapplyはhylo-fusionできるはずだが，勝手にされる？ -- -- unitSubstをinlineにしないと駄目か@@ -602,17 +604,17 @@ guard (usedArg (tvid+1) gentvar) funApSubBits_forcingNil clbehalf lltbehalf behalf gentvar (fe gentvar ty exprs, bs1) -}- funApSubBits_forcingNil_cont clbehalf lltbehalf behalf (mapTV (tvid+) ty) (map (mkHead (reducer cmn) lenavails (getLongerArity ty+a)) xs, fullBits) $ \(exprs, bs1) -> do+ funApSubBits_forcingNil_cont clbehalf lltbehalf behalf (mapTV (tvid+) ty) (map (mkHead (reducer cmn) lenavails numcxts (arity+a)) xs, fullBits) $ \(exprs, bs1) -> do gentvar <- applyPS (TV tvid) guard (usedArg (tvid+1) gentvar) funApSubBits_forcingNil clbehalf lltbehalf behalf gentvar (fe gentvar ty exprs, bs1) -retGenTV0Bits cmn lenavails fullBits fe clbehalf lltbehalf behalf reqret (arity, _retty, numtvs, xs:::ty)+retGenTV0Bits cmn lenavails fullBits fe clbehalf lltbehalf behalf reqret (numcxts, arity, _retty, numtvs, xs:::ty) = convertPS (ndelay arity) $ do tvid <- reserveTVars numtvs -- この（最初の）IDそのもの（つまり返り値のtvID）はすぐに使われなくなる -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTVとapplyはhylo-fusionできるはずだが，勝手にされる？ -- -- unitSubstをinlineにしないと駄目か updatePS (unitSubst tvid reqret)- exprs <- funApSubBits_forcingNil clbehalf lltbehalf behalf (mapTV (tvid+) ty) (map (mkHead (reducer cmn) lenavails (getLongerArity ty)) xs, fullBits)+ exprs <- funApSubBits_forcingNil clbehalf lltbehalf behalf (mapTV (tvid+) ty) (map (mkHead (reducer cmn) lenavails numcxts arity) xs, fullBits) gentvar <- applyPS (TV tvid) return $ fe gentvar ty exprs @@ -623,7 +625,8 @@ matchAssumptionsBits cmn lenavails reqty assumptions = do s <- getSubst let newty = apply s reqty- msum $ zipWith (\n t -> matchPS newty t >> return ([mkHead (reducer cmn) lenavails (getLongerArity newty) (X n)], 1 `shiftL` fromIntegral n)) [0..] assumptions+ (numcxts, arity) = getArities newty+ msum $ zipWith (\n t -> matchPS newty t >> return ([mkHead (reducer cmn) lenavails numcxts arity (X n)], 1 `shiftL` fromIntegral n)) [0..] assumptions -- match の場合，通常はreqtyの方だけapply substすればよい． lookupListrie :: (Search m, Expression e) => Int -> Generator m e -> Generator m e
MagicHaskeller/ProgGenSFIORef.lhs view
@@ -194,7 +194,7 @@ lltbehalf = flip mguAssumptions_ avail clbehalf ty = mguPrograms classLib [] ty >> return () -- retPrimMono :: (Int, Type, Int, Typed [CoreExpr]) -> PriorSubsts BFT ()- retPrimMono (arity, retty, numtvs, _xs:::ty)+ retPrimMono (_, arity, retty, numtvs, _xs:::ty) = napply arity delayPS $ do tvid <- reserveTVars numtvs mguPS reqret (mapTV (tvid+) retty)@@ -204,7 +204,7 @@ do mguPS reqret (getRet ty) fas ty -- retGen :: (Int, Type, Int, Typed [CoreExpr]) -> PriorSubsts BFT ()- retGen (arity, _r, numtvs, _s:::ty) = napply arity delayPS $+ retGen (_, arity, _r, numtvs, _s:::ty) = napply arity delayPS $ do tvid <- reserveTVars numtvs -- この（最初の）IDそのもの（つまり返り値のtvID）はすぐに使われなくなる -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTVとapplyはhylo-fusionできるはずだが，勝手にされる？ -- -- unitSubstをinlineにしないと駄目か
MagicHaskeller/ProgramGenerator.lhs view
@@ -32,8 +32,6 @@ import MagicHaskeller.Options -import Data.Array- #if __GLASGOW_HASKELL__ >= 710 import Prelude hiding ((<$>)) #endif@@ -42,7 +40,7 @@ -- listen = False -- | annotated 'Typed [CoreExpr]'-type Prim = (Int, Type, TyVar, Typed [CoreExpr])+type Prim = (Int, Int, Type, TyVar, Typed [CoreExpr]) class WithCommon a where extractCommon :: a -> Common@@ -90,11 +88,12 @@ -- | options for limiting the hypothesis space. type Options = Opt [[Primitive]] -retsTVar (_, TV tv, _, _) = True-retsTVar _ = False+retsTVar (_, _, TV tv, _, _) = True+retsTVar _ = False annotateTCEs :: Typed [CoreExpr] -> Prim-annotateTCEs tx@(_:::t) = (getArity t, getRet t, maxVarID t + 1, tx) -- getArity returns the shorter arity that does not count contexts.+annotateTCEs tx@(_:::t) = let (numcs, arity, retty) = getAritiesRet t+ in (numcs, arity, retty, maxVarID t + 1, tx) -- arity is the shorter arity that does not count contexts. splitPrims :: [Typed [CoreExpr]] -> ([Prim],[Prim]) splitPrims = partition retsTVar . map annotateTCEs@@ -131,13 +130,13 @@ fromAssumptions :: (Search m, Expression e) => Common -> Int -> (Type -> PriorSubsts m [e]) -> (Type -> Type -> PriorSubsts m ()) -> Type -> [Type] -> PriorSubsts m [e] fromAssumptions cmn lenavails behalf mps reqret avail = msum $ map (retMono cmn lenavails behalf (flip mps reqret)) (fromAvail avail) -retMono :: (Search m, Expression e) => Common -> Int -> (Type -> PriorSubsts m [e]) -> (Type -> PriorSubsts m ()) -> (Int8, (Int8,[Type],Type)) -> PriorSubsts m [e]+retMono :: (Search m, Expression e) => Common -> Int -> (Type -> PriorSubsts m [e]) -> (Type -> PriorSubsts m ()) -> (Int8, (Int,[Type],Type)) -> PriorSubsts m [e] retMono cmn lenavails behalf tok fromBlah = do let (n, (arity,args,retty)) = fromBlah tok retty convertPS (ndelay $ fromIntegral arity) $- fap behalf args (map (mkHead (reducer cmn) lenavails arity) [X n])-fromAvail :: [Type] -> [(Int8, (Int8,[Type],Type))]+ fap behalf args (map (mkHead (reducer cmn) lenavails 0 arity) [X n])+fromAvail :: [Type] -> [(Int8, (Int,[Type],Type))] fromAvail = zipWith (\ n t -> (n, revSplitArgs t)) [0..] @@ -151,7 +150,8 @@ matchAssumptions cmn lenavails reqty assumptions = do s <- getSubst let newty = apply s reqty- msum $ zipWith (\n t -> matchPS newty t >> return [mkHead (reducer cmn) lenavails (getLongerArity newty) (X n)]) [0..] assumptions+ (numcxts, arity) = getArities newty+ msum $ zipWith (\n t -> matchPS newty t >> return [mkHead (reducer cmn) lenavails numcxts arity (X n)]) [0..] assumptions -- 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 ().@@ -162,11 +162,11 @@ {-# SPECIALIZE retPrimMono :: (Search m) => Common -> Int -> (Type -> PriorSubsts m [CoreExpr]) -> (Type -> PriorSubsts m [CoreExpr]) -> (Type -> PriorSubsts m [CoreExpr]) -> (Type -> Type -> PriorSubsts m ()) -> Type -> Prim -> PriorSubsts m [CoreExpr] #-} retPrimMono :: (Search m, Expression e) => Common -> Int -> (Type -> PriorSubsts m [e]) -> (Type -> PriorSubsts m [e]) -> (Type -> PriorSubsts m [e]) -> (Type -> Type -> PriorSubsts m ()) -> Type -> Prim -> PriorSubsts m [e]-retPrimMono cmn lenavails clbehalf lltbehalf behalf mps reqret (arity, retty, numtvs, xs:::ty)+retPrimMono cmn lenavails clbehalf lltbehalf behalf mps reqret (numcxts, arity, retty, numtvs, xs:::ty) = do tvid <- reserveTVars numtvs mps (mapTV (tvid+) retty) reqret convertPS (ndelay $ fromIntegral arity) $- funApSub clbehalf lltbehalf behalf (mapTV (tvid+) ty) (map (mkHead (reducer cmn) lenavails (getLongerArity ty)) xs)+ funApSub clbehalf lltbehalf behalf (mapTV (tvid+) ty) (map (mkHead (reducer cmn) lenavails numcxts arity) xs) funApSub :: (Search m, Expression e) => (Type -> PriorSubsts m [e]) -> (Type -> PriorSubsts m [e]) -> (Type -> PriorSubsts m [e]) -> Type -> [e] -> PriorSubsts m [e] funApSub = funApSubOp (<$>) funApSubOp op clbehalf lltbehalf behalf = faso@@ -213,13 +213,13 @@ retGen, retGenOrd, retGenTV1 :: (Search m, Expression e) => Common -> Int -> (Type -> Type -> [e] -> [e]) -> (Type -> PriorSubsts m [e]) -> (Type -> PriorSubsts m [e]) -> (Type -> PriorSubsts m [e]) -> Type -> Prim -> PriorSubsts m [e] retGen cmn lenavails fe clbehalf lltbehalf behalf = retGen' (funApSub clbehalf lltbehalf behalf) cmn lenavails fe clbehalf lltbehalf behalf-retGen' fas cmn lenavails fe clbehalf lltbehalf behalf reqret (arity, _retty, numtvs, xs:::ty)+retGen' fas cmn lenavails fe clbehalf lltbehalf behalf reqret (numcxts, arity, _retty, numtvs, xs:::ty) = convertPS (ndelay $ fromIntegral arity) $ do tvid <- reserveTVars numtvs -- $B$3$N!J:G=i$N!K(BID$B$=$N$b$N!J$D$^$jJV$jCM$N(BtvID$B!K$O$9$0$K;H$o$l$J$/$J$k(B -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTV$B$H(Bapply$B$O(Bhylo-fusion$B$G$-$k$O$:$@$,!$>!<j$K$5$l$k!)(B -- -- 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)+ exprs <- funApSub clbehalf lltbehalf behalf (mapTV (tvid+) ty) (map (mkHead (reducer cmn) lenavails numcxts (arity+a)) xs) 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)@@ -247,24 +247,24 @@ usedArg n (TV m :-> _) = n /= m usedArg _ _ = True -retGenTV1 cmn lenavails fe clbehalf lltbehalf behalf reqret (arity, _retty, numtvs, xs:::ty)+retGenTV1 cmn lenavails fe clbehalf lltbehalf behalf reqret (numcxts, arity, _retty, numtvs, xs:::ty) = convertPS (ndelay $ fromIntegral arity) $ do tvid <- reserveTVars numtvs -- $B$3$N!J:G=i$N!K(BID$B$=$N$b$N!J$D$^$jJV$jCM$N(BtvID$B!K$O$9$0$K;H$o$l$J$/$J$k(B -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTV$B$H(Bapply$B$O(Bhylo-fusion$B$G$-$k$O$:$@$,!$>!<j$K$5$l$k!)(B -- -- 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)+ exprs <- funApSub clbehalf lltbehalf behalf (mapTV (tvid+) ty) (map (mkHead (reducer cmn) lenavails numcxts (arity+a)) xs) gentvar <- applyPS (TV tvid) guard (usedArg (tvid+1) gentvar) funApSub clbehalf lltbehalf behalf gentvar (fe gentvar ty exprs) -retGenTV0 cmn lenavails fe clbehalf lltbehalf behalf reqret (arity, _retty, numtvs, xs:::ty)+retGenTV0 cmn lenavails fe clbehalf lltbehalf behalf reqret (numcxts, arity, _retty, numtvs, xs:::ty) = convertPS (ndelay $ fromIntegral arity) $ do tvid <- reserveTVars numtvs -- $B$3$N!J:G=i$N!K(BID$B$=$N$b$N!J$D$^$jJV$jCM$N(BtvID$B!K$O$9$0$K;H$o$l$J$/$J$k(B -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTV$B$H(Bapply$B$O(Bhylo-fusion$B$G$-$k$O$:$@$,!$>!<j$K$5$l$k!)(B -- -- unitSubst$B$r(Binline$B$K$7$J$$$HBLL\$+(B updatePS (unitSubst tvid reqret)- exprs <- funApSub clbehalf lltbehalf behalf (mapTV (tvid+) ty) (map (mkHead (reducer cmn) lenavails (getLongerArity ty)) xs)+ exprs <- funApSub clbehalf lltbehalf behalf (mapTV (tvid+) ty) (map (mkHead (reducer cmn) lenavails numcxts arity) xs) gentvar <- applyPS (TV tvid) return $ fe gentvar ty exprs @@ -415,7 +415,7 @@ isUsed _ _ = False -mkSubsts :: Search m => Int -> TyVar -> Type -> PriorSubsts m Int8+mkSubsts :: Search m => Int -> TyVar -> Type -> PriorSubsts m Int mkSubsts n tvid reqret = base `mplus` ndelayPS n recurse where base = do updatePS (unitSubst tvid reqret) -- $B$3$3$r(BsetSubst$B$K$7$F!$(BmguProgs$B$r8F$S=P$9$?$S$K7k2L$N(BSubst$B$r(BplusSubst$B$9$k$h$&$K$7$?J}$,!$L5BL$K(BSubst$B$,Bg$-$/$J$i$J$$!%(B -- $B$a$s$I$/$5$$$+$i$3$&$7$F$k$1$I!$$b$7(BlookupSubst$B$,;~4V$r?)$$2a$.$k$J$i9M$($k!%(B@@ -424,7 +424,7 @@ arity <- mkSubsts n tvid (TV v :-> reqret) return (arity+1) -mkSubst :: Search m => Int -> TyVar -> Type -> PriorSubsts m Int8+mkSubst :: Search m => Int -> TyVar -> Type -> PriorSubsts m Int mkSubst n tvid reqret = base `mplus` ndelayPS n first where base = do updatePS (unitSubst tvid reqret) -- $B$3$3$r(BsetSubst$B$K$7$F!$(BmguProgs$B$r8F$S=P$9$?$S$K7k2L$N(BSubst$B$r(BplusSubst$B$9$k$h$&$K$7$?J}$,!$L5BL$K(BSubst$B$,Bg$-$/$J$i$J$$!%(B -- $B$a$s$I$/$5$$$+$i$3$&$7$F$k$1$I!$$b$7(BlookupSubst$B$,;~4V$r?)$$2a$.$k$J$i9M$($k!%(B@@ -462,18 +462,6 @@ combs n xs = [] : [ y:zs | y:ys <- tails xs, zs <- combs (n-1) ys ] tails [] = [] tails xs@(_:ys) = xs : tails ys--mapFst3 f (ces, s, i) = (f ces, s, i)-decodeVarsPos vs = mapFst3 (map (decodeVarsCE vs))--decodeVarsCE :: [Int8] -> CoreExpr -> CoreExpr-decodeVarsCE vs = decodeVarsCE' 0 (listArray (0, genericLength vs-1) vs)-decodeVarsCE' :: Int8 -> Array Int8 Int8 -> CoreExpr -> CoreExpr-decodeVarsCE' offset ar e@(X n) = let nn = n - offset- in if inRange (bounds ar) nn then X $ (ar ! nn) + offset else e-decodeVarsCE' offset ar (Lambda e) = Lambda $ decodeVarsCE' (offset + 1) ar e-decodeVarsCE' offset ar (f :$ e) = decodeVarsCE' offset ar f :$ decodeVarsCE' offset ar e-decodeVarsCE' offset ar e = e \end{code}
MagicHaskeller/Types.lhs view
@@ -9,7 +9,7 @@ module MagicHaskeller.Types(Type(..), Kind, TyCon, TyVar, TypeName, Typed(..), tyvars, Subst, plusSubst, 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+ alltyvars, mapTV, size, unitSubst, applyCheck, assertsubst, substOK, eqType, getRet, getArity, getArities, getAritiesRet, splitArgs, getArgs, pushArgs, popArgs, mguFunAp, revSplitArgs, revGetArgs, module Data.Int ) where import Data.List import Control.Monad@@ -33,7 +33,7 @@ -- :> is same as :-> except FMType.lhs assumes it is a type constructor.-data Type = TV {-# UNPACK #-} !TyVar | TC {-# UNPACK #-} !TyVar | TA Type Type | Type :> Type | Type :-> Type | Type :=> Type+data Type = TV {-# UNPACK #-} !TyVar | TC {-# UNPACK #-} !TyCon | TA Type Type | Type :> Type | Type :-> Type | Type :=> Type deriving (Eq, Ord, Read) size :: Type -> Int@@ -141,7 +141,7 @@ -- comparison between cs and ds is done in TypeLib, comparing types of different vars. type TyVar = Int8-type TyCon = Int8+type TyCon = TyVar -- TyCon should be the same or bigger than TyVar, because the quantify function converts TyVar into TyCon type TypeName = String @@ -173,7 +173,7 @@ -- quantify freezes tyvars into tycons whose IDs are negative. saferQuantify, quantify, quantify', unquantify :: Type -> Type saferQuantify = quantify . negUnquantify-negUnquantify (TC i) | i < 0 = TV i+negUnquantify (TC i) | i < 0 = TV $ fromIntegral i negUnquantify (TA t u) = TA (negUnquantify t) (negUnquantify u) negUnquantify (u :-> t) = negUnquantify u :-> negUnquantify t negUnquantify (u :> t) = negUnquantify u :> negUnquantify t@@ -181,14 +181,14 @@ negUnquantify t = t quantify ty = quantify' (normalize ty)-quantify' (TV iD) = TC (-iD-1)+quantify' (TV iD) = TC $ fromIntegral (-iD-1) quantify' tc@(TC _) = tc quantify' (TA t u) = TA (quantify' t) (quantify' u) quantify' (u :-> t) = quantify' u :-> quantify' t quantify' (u :> t) = quantify' u :> quantify' t -- unquantify is used only as a preprocessor of normalize, when used as a preprocessor of quantify. See notes on Nov. 17, 2006.-unquantify (TC tc) | tc < 0 = TV (-1-tc)+unquantify (TC tc) | tc < 0 = TV $ fromIntegral (-1-tc) unquantify (TA t u) = TA (unquantify t) (unquantify u) unquantify (u :-> t) = unquantify u :-> unquantify t unquantify (u :> t) = unquantify u :> unquantify t@@ -225,37 +225,40 @@ -pushArgsCPS :: Integral i => (i -> [Type] -> Type -> a) -> [Type] -> Type -> a-pushArgsCPS f = pa 0+pushArgsCPS :: Integral i => (i -> i -> [Type] -> Type -> a) -> [Type] -> Type -> a+pushArgsCPS f = pa 0 0 where - 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 c n args (t0:->t1) = pa c (n+1) (t0:args) t1+ pa c n args (t0:>t1) = pa c (n+1) (t0:args) t1+ pa c n args (t0:=>t1) = pa (c+1) n (t0:args) t1 -- So, the arity is not incremented in this case.+ pa c n args retty = f c n args retty pushArgs :: [Type] -> Type -> ([Type],Type)-pushArgs = pushArgsCPS (\i a r -> (a,r))+pushArgs = pushArgsCPS (\_ _ a r -> (a,r)) -getRet = pushArgsCPS (\i a r -> r) []-getArgs = pushArgsCPS (\i a r -> a) []-getLongerArity :: Integral i => Type -> i-getLongerArity = pushArgsCPS (\i _ _ -> i) undefined-getArity (_:->t) = succ $ getArity t-getArity (_:>t) = succ $ getArity t-getArity (_:=>t) = getArity t -- So, the arity is not incremented in this case.-getArity _ = 0+getRet = pushArgsCPS (\_ _ _ r -> r) undefined+getArgs = pushArgsCPS (\_ _ a _ -> a) []+getNumCxts, getArity :: Integral i => Type -> i+getNumCxts = pushArgsCPS (\c _ _ _ -> c) undefined+getArity = pushArgsCPS (\_ i _ _ -> i) undefined+getArities :: Integral i => Type -> (i,i)+getArities = pushArgsCPS (\c i _ _ -> (c,i)) undefined+getAritiesRet :: Integral i => Type -> (i,i,Type)+getAritiesRet = pushArgsCPS (\c i _ r -> (c,i,r)) undefined -splitArgsCPS :: (Int -> [Type] -> Type -> a) -> Type -> a-splitArgsCPS f = pushArgsCPS f [] +-- splitArgsCPS :: (Int -> [Type] -> Type -> a) -> Type -> a+-- splitArgsCPS f = pushArgsCPS f []+ splitArgs :: Type -> ([Type],Type) splitArgs = pushArgs [] --- $B5U=g$K@Q$s$G$$$/(B+-- $B5U=g$K@Q$s$G$$$/(B. :=>$B$b(B:>$B$b$J$$$H2>Dj!%(B revSplitArgs :: Integral i => Type -> (i,[Type],Type) revSplitArgs (t0:->t1) = case revSplitArgs t1 of (n,args,ret) -> (n+1, t0:args, ret) revSplitArgs t = (0, [], t) +-- $B5U=g$K@Q$s$G$$$/(B. :=>$B$b(B:>$B$b$J$$$H2>Dj!%(B revGetArgs :: Type -> [Type] revGetArgs ty = case revSplitArgs ty of (_,ts,_) -> ts
MagicHaskeller/predicatesAug2014 view
@@ -50,8 +50,7 @@ ( f ( + 4 ) ( Just 6 ) == ( Just 10 ) ) && f id ( Just ( - 1 ) ) ~= Just ( - 1 ) f "123" == 'a' f 32 == ' '-( ( ( ( ( f "kristoffer" "reffotsirk" == True ) && f "" "\nm Z" ~= False ) && f "\nm Z" "" ~= False ) && f "" "-" ~= True ) && f "\nm Z" "\nm Z" ~= False ) && f "" "12345" ~= False+( ( ( ( ( f "kristoffer" "reffotsirk" == True ) && f "" "\nm Z" ~= False ) && f "\nm Z" "" ~= False ) && f "" "" ~= True ) && f "\nm Z" "\nm Z" ~= False ) && f "" "12345" ~= False f "ancd ed ad e ww" == [ 15 , 5 ] f "a" == f "a" f "lollolabacad" 2 ~= "ollbcd"@@ -60,8 +59,7 @@ f 1 'a' ~= ( 2 , 'b' ) f 'a' ~= 'b' f ( Left 3 ) == 3 && f ( Right 4 ) == 4-f 1 ( Just 1 ) ( Just ( Just 1 ) ) ( Just ( Just ( Just 1 ) ) ) ( Just ( Just ( Just ( Just 1 ) ) ) ) ( Just (-Just ( Just ( Just ( Just 1 ) ) ) ) ) == 1+f 1 ( Just 1 ) ( Just ( Just 1 ) ) ( Just ( Just ( Just 1 ) ) ) ( Just ( Just ( Just ( Just 1 ) ) ) ) ( Just (Just ( Just ( Just ( Just 1 ) ) ) ) ) == 1 f 1 [ 1 ] [ [ 1 ] ] [ [ [ 1 ] ] ] [ [ [ [ 1 ] ] ] ] [ [ [ [ [ 1 ] ] ] ] ] == 1 f 1 ~= [ [ ] ] && f 2 ~= [ [ [ ] ] , [ ] ] f 2 ( ) == 1
MagicHaskeller/predicatesServed view
@@ -50,8 +50,7 @@ ( f ( + 4 ) ( Just 6 ) == ( Just 10 ) ) && f id ( Just ( - 1 ) ) ~= Just ( - 1 ) f "123" == 'a' f 32 == ' '-( ( ( ( ( f "kristoffer" "reffotsirk" == True ) && f "" "\nm Z" ~= False ) && f "\nm Z" "" ~= False ) && f "" "-" ~= True ) && f "\nm Z" "\nm Z" ~= False ) && f "" "12345" ~= False+( ( ( ( ( f "kristoffer" "reffotsirk" == True ) && f "" "\nm Z" ~= False ) && f "\nm Z" "" ~= False ) && f "" "" ~= True ) && f "\nm Z" "\nm Z" ~= False ) && f "" "12345" ~= False f "ancd ed ad e ww" == [ 15 , 5 ] f "a" == f "a" f "lollolabacad" 2 ~= "ollbcd"@@ -60,8 +59,7 @@ f 1 'a' ~= ( 2 , 'b' ) f 'a' ~= 'b' f ( Left 3 ) == 3 && f ( Right 4 ) == 4-f 1 ( Just 1 ) ( Just ( Just 1 ) ) ( Just ( Just ( Just 1 ) ) ) ( Just ( Just ( Just ( Just 1 ) ) ) ) ( Just (-Just ( Just ( Just ( Just 1 ) ) ) ) ) == 1+f 1 ( Just 1 ) ( Just ( Just 1 ) ) ( Just ( Just ( Just 1 ) ) ) ( Just ( Just ( Just ( Just 1 ) ) ) ) ( Just (Just ( Just ( Just ( Just 1 ) ) ) ) ) == 1 f 1 [ 1 ] [ [ 1 ] ] [ [ [ 1 ] ] ] [ [ [ [ 1 ] ] ] ] [ [ [ [ [ 1 ] ] ] ] ] == 1 f 1 ~= [ [ ] ] && f 2 ~= [ [ [ ] ] , [ ] ] f 2 ( ) == 1
changelog.txt view
@@ -1,3 +1,10 @@+0.9.6.5:+ * Fix some bugs in CGI. Now you do not need to use GHC 7.4 even for building the CGI.++0.9.6.4.8:+ * Fix some bugs and misfeatures in CGI+ * Replace the "Interpreted as ..." with more informative "Corrected with ..." in CGI+ 0.9.6.4.7: * Add this changelog.txt * Implement copy by drag-and-drop