diff --git a/MagicHaskeller.cabal b/MagicHaskeller.cabal
--- a/MagicHaskeller.cabal
+++ b/MagicHaskeller.cabal
@@ -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
diff --git a/MagicHaskeller/CGI.lhs b/MagicHaskeller/CGI.lhs
--- a/MagicHaskeller/CGI.lhs
+++ b/MagicHaskeller/CGI.lhs
@@ -176,7 +176,7 @@
detail' config predicate =
"" ++
"
satisfies the following input-output relation:
"
-- 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 ++ ""++ lastLines useJS
+ Right result -> output $ detail config (parenthesize candi) ++ ""++ 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
- "
Error: let expressions and where clauses are prohibited here. You can still use case expressions without where clauses for non-recursive bindings.
"
- 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 "
lex error
"
- [sigPred] -> organizeSynthesis' verInfo config True showAbsents predi sigPred useJS
- else organizeSynthesis' verInfo config corrected showAbsents predi predi useJS
+ [] -> showError verInfo config augPred "
Lex error!
"
+ [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 -> ""++blamePredicate predicate res
+ let body = case result of '!':res -> "
"++blamePredicate origPred res
_ -> notice++clipped
results = lines result
- notice | corrected = "
Results:
(Interpreted as "++stringToHtmlString sigPred++")
"
+ notice | corrected = "Results:
(Corrected from "++stringToHtmlString origPred++")
"
| otherwise = "Results:
"
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 }
diff --git a/MagicHaskeller/ExpToHtml.hs b/MagicHaskeller/ExpToHtml.hs
--- a/MagicHaskeller/ExpToHtml.hs
+++ b/MagicHaskeller/ExpToHtml.hs
@@ -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 "
Lex error: maybe double-quotes are not balanced.
" -- Unbalanced double-quotes may be automatically closed at the end, but that can be confusing.
+ | otherwise -> Left "
Lex error!
"
+ [("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 = "
Error: let expressions and where clauses are prohibited here. You can still use " ++ refLink "case" "case" ++ " expressions without where clauses for non-recursive bindings.
"
diff --git a/MagicHaskeller/Expression.hs b/MagicHaskeller/Expression.hs
--- a/MagicHaskeller/Expression.hs
+++ b/MagicHaskeller/Expression.hs
@@ -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!% 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)
diff --git a/MagicHaskeller/LibExcel.hs b/MagicHaskeller/LibExcel.hs
--- a/MagicHaskeller/LibExcel.hs
+++ b/MagicHaskeller/LibExcel.hs
@@ -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@
diff --git a/MagicHaskeller/LibExcelStaged.hs b/MagicHaskeller/LibExcelStaged.hs
--- a/MagicHaskeller/LibExcelStaged.hs
+++ b/MagicHaskeller/LibExcelStaged.hs
@@ -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)
diff --git a/MagicHaskeller/ProgGenSF.lhs b/MagicHaskeller/ProgGenSF.lhs
--- a/MagicHaskeller/ProgGenSF.lhs
+++ b/MagicHaskeller/ProgGenSF.lhs
@@ -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 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
diff --git a/MagicHaskeller/ProgGenSFIORef.lhs b/MagicHaskeller/ProgGenSFIORef.lhs
--- a/MagicHaskeller/ProgGenSFIORef.lhs
+++ b/MagicHaskeller/ProgGenSFIORef.lhs
@@ -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にしないと駄目か
diff --git a/MagicHaskeller/ProgramGenerator.lhs b/MagicHaskeller/ProgramGenerator.lhs
--- a/MagicHaskeller/ProgramGenerator.lhs
+++ b/MagicHaskeller/ProgramGenerator.lhs
@@ -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$:$@$,!$>! _) = 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$:$@$,!$>!! 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}
diff --git a/MagicHaskeller/Types.lhs b/MagicHaskeller/Types.lhs
--- a/MagicHaskeller/Types.lhs
+++ b/MagicHaskeller/Types.lhs
@@ -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
diff --git a/MagicHaskeller/predicatesAug2014 b/MagicHaskeller/predicatesAug2014
--- a/MagicHaskeller/predicatesAug2014
+++ b/MagicHaskeller/predicatesAug2014
@@ -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
diff --git a/MagicHaskeller/predicatesServed b/MagicHaskeller/predicatesServed
--- a/MagicHaskeller/predicatesServed
+++ b/MagicHaskeller/predicatesServed
@@ -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
diff --git a/changelog.txt b/changelog.txt
--- a/changelog.txt
+++ b/changelog.txt
@@ -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