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.5 +Version: 0.9.6.4.6 Cabal-Version: >= 1.8 License: BSD3 License-file: LICENSE @@ -58,7 +58,6 @@ MagicHaskeller.MyDynamic, MagicHaskeller.ClassifyDM, MagicHaskeller.ProgramGenerator, MagicHaskeller.Analytical.FMExpr, MagicHaskeller.Analytical.Parser, MagicHaskeller.Analytical.Syntax, MagicHaskeller.Analytical.UniT, MagicHaskeller.Analytical.Synthesize, MagicHaskeller.ExpToHtml, MagicHaskeller.FMType, MagicHaskeller.NearEq, MagicHaskeller.ClassLib, MagicHaskeller.LibExcelStaged - MagicHaskeller.ExpToHtml, MagicHaskeller.FMType, MagicHaskeller.NearEq, MagicHaskeller.ClassLib, MagicHaskeller.LibExcelStaged, MagicHaskeller.LibExcelStagedStaged Paths_MagicHaskeller Extensions: CPP, TemplateHaskell cpp-options: -DCHTO -DCABAL diff --git a/MagicHaskeller/CGI.lhs b/MagicHaskeller/CGI.lhs --- a/MagicHaskeller/CGI.lhs +++ b/MagicHaskeller/CGI.lhs @@ -246,7 +246,7 @@ let showAbsents = isJust mbAbsent mbPred <- getInput "predicate" case mbPred of - Just command@(':':_) -> passCommand config showAbsents command -- Just pass it if it is a command. (But be careful about any danger.) + Just command@(':':xs) | not $ all (`elem` "!@#$%&*+./<=>?\\^|-~:") xs -> passCommand config showAbsents command -- Just pass it if it is a command. (But be careful about any danger.) -- If unknown commands are also passed without any checking, the backend server must check them and print an error message when necessary. Just predicate | all isSpace predicate -> defaultPage config diff --git a/MagicHaskeller/ExpToHtml.hs b/MagicHaskeller/ExpToHtml.hs --- a/MagicHaskeller/ExpToHtml.hs +++ b/MagicHaskeller/ExpToHtml.hs @@ -229,11 +229,18 @@ ("if", "#x8-320003.6"), -- Conditionals ("then","#x8-320003.6"), -- Conditionals ("else","#x8-320003.6"), -- Conditionals - (":", "#x8-340003.7") -- Lists + (":", "#x8-340003.7"), -- Lists + ("let", ""), -- Let can appear at different places. + ("in", "#x8-440003.12"), -- Let + ("case","#x8-460003.13"), -- Case + ("of", "#x8-460003.13"), -- Case + ("do", "#x8-470003.14"), -- Do + ("::", "#x8-560003.16") -- Expression type-signatures ] ] ++ [ (kw, ("other", const $ repch3 ++ str)) | (kw, str) <- [ ("[", ""), -- There are some possibilities, so the syntax is pointed. ("]", ""), + ("|", ""), ("`", "#x8-240003.2"), -- Variables, Constructors, Operators, and Literals ("-", "#x8-280003.4") -- Operator Applications ] ] diff --git a/MagicHaskeller/LibExcelStaged.hs b/MagicHaskeller/LibExcelStaged.hs --- a/MagicHaskeller/LibExcelStaged.hs +++ b/MagicHaskeller/LibExcelStaged.hs @@ -4,8 +4,6 @@ import Data.Char import Prelude hiding (gcd) -import MagicHaskeller.LibExcelStagedStaged - default (Int, Integer, Double) -- gcd in the latest library is total, but with older versions gcd 0 0 causes an error. @@ -48,13 +46,13 @@ proper (c:cs) | isAlpha c = toUpper c : case span isAlpha cs of (ts, ds) -> map toLower ts ++ proper ds | otherwise = c : proper cs -right, left :: RealFrac a => ([b], a) -> [b] +right, left :: ([b], Int) -> [b] left1 = take 1 right1 str = right (str, 1) -left (b, a) = take (Prelude.round a) b -right (b, a) = reverse (take (Prelude.round a) (reverse b)) +left (b, a) = take a b +right (b, a) = reverse (take a (reverse b)) dropLeft b a = right(b, len(b) - a) -mid (c, a, b) = take (Prelude.round b) (drop (Prelude.round a - 1) c) +mid (c, a, b) = take b (drop (a - 1) c) len :: Num a => String -> a len = fromIntegral . length concatenate (a, b) = a ++ b @@ -90,16 +88,16 @@ | otherwise = fLOOR0 a b -- これらの第２引数は切り捨てで整数にされるみたい。なので、**ではなく^^を用いなければならない。 -rOUND, roundup, rounddown :: RealFrac a => (Double, a) -> Double -rOUND (a, b) = mround (a, 0.1 ^^ floor b) -roundup (a, b) | a > 0 = cEILING (a, 0.1 ^^ floor b) - | otherwise = fLOOR0 a (0.1 ^^ floor b) -rounddown (a, b) | a < 0 = cEILING (a, 0.1 ^^ floor b) - | otherwise = fLOOR0 a (0.1 ^^ floor b) +rOUND, roundup, rounddown :: (Double, Int) -> Double +rOUND (a, b) = mround (a, 0.1 ^^ b) +roundup (a, b) | a > 0 = cEILING (a, 0.1 ^^ b) + | otherwise = fLOOR0 a (0.1 ^^ b) +rounddown (a, b) | a < 0 = cEILING (a, 0.1 ^^ b) + | otherwise = fLOOR0 a (0.1 ^^ b) trim = unwords . words -fIND :: (RealFrac a, Num b) => (String, String, a) -> Maybe b -fIND (pat, xs, pos) = fmap (fromIntegral . fst) $ Data.List.find (isPrefixOf pat . snd) $ zip [1..] $ drop (truncate pos-1) $ tails xs +fIND :: (Num b) => (String, String, Int) -> Maybe b +fIND (pat, xs, pos) = fmap (fromIntegral . fst) $ Data.List.find (isPrefixOf pat . snd) $ zip [1..] $ drop (pos-1) $ tails xs ifERROR :: (Maybe a, a) -> a ifERROR (mb, x) = maybe x id mb aND (a, b) = a && b @@ -121,11 +119,11 @@ fact n | n < 0 = Nothing | otherwise = Just $ product [1..n] combin (n,r) | (signum n + 1) * (signum r + 1) * (signum (r-n) + 1) == 0 = Nothing - | otherwise = Just $ product [n-r+1 .. n] / product [1..r] + | otherwise = Just $ product [n-r+1 .. n] `div` product [1..r] -mOD :: (RealFrac a, RealFrac b, Num c) => (a, b) -> Maybe c +mOD :: (Int, Int) -> Maybe Int mOD(_,0) = Nothing -mOD(m,n) = Just $ fromInteger $ truncate m `mod` truncate n +mOD(m,n) = Just $ m `mod` n degrees = ((180/pi)*) radians = ((pi/180)*) @@ -143,16 +141,16 @@ sUBsTITUTE(text@(t:ts), old, new) = case old `stripPrefix` text of Nothing -> t : sUBsTITUTE(ts, old, new) Just rest -> new ++ sUBsTITUTE(rest, old, new) -sUBSTITUTE :: RealFrac a => (String, String, String, a) -> String +sUBSTITUTE :: (String, String, String, Int) -> String sUBSTITUTE(text, old, new, num) | num <= 0 = error "#NUM" | otherwise = if null old then text - else sUB text old new (floor num) + else sUB text old new num sUB "" _ _ _ = "" sUB text@(t:ts) old new n = case old `stripPrefix` text of Nothing -> t : sUB ts old new n Just rest | n<=1 -> new ++ rest | otherwise -> old ++ sUB rest old new (n-1) -sUBST4 :: RealFrac a => String -> String -> String -> a -> String +sUBST4 :: String -> String -> String -> Int -> String sUBST4 text old new num = sUBSTITUTE(text, old, new, 1+abs(num)) countStr :: Num a => String -> String -> a diff --git a/MagicHaskeller/LibExcelStagedStaged.hs b/MagicHaskeller/LibExcelStagedStaged.hs deleted file mode 100644 --- a/MagicHaskeller/LibExcelStagedStaged.hs +++ /dev/null @@ -1,14 +0,0 @@ --- This module can be included LibExcelStaged when using GHC-7.8, but cannot when using 7.6. -module MagicHaskeller.LibExcelStagedStaged where -import Data.Ratio(numerator, denominator) - -instance RealFrac Int where - properFraction x = (fromIntegral x,0) - truncate = fromIntegral - round = fromIntegral - ceiling = fromIntegral - floor = fromIntegral - -instance Fractional Int where -- This is necessary because Fractional is a superclass of RealFrac - (/) = div - fromRational r = fromIntegral (numerator r) `div` fromIntegral (denominator r) diff --git a/MagicHaskeller/LibTH.hs b/MagicHaskeller/LibTH.hs --- a/MagicHaskeller/LibTH.hs +++ b/MagicHaskeller/LibTH.hs @@ -271,6 +271,8 @@ by1 name = name -} +-- ¤³¤ÎÊÕ¤ÏCoreLang¤Ç¤ä¤ë¤Ù¤­¤È¤¤¤¦µ¤¤â¡¥¾¯¤Ê¤¯¤È¤â¡¤¤½¤Ã¤Á¤Ç´Ø¿ô¤òÄêµÁ¤¹¤Ù¤­¡¥ +-- \x -> iF foo bar x ¤Î¾ì¹ç¤âÀè¤Ë¦Ç´ÊÌ󤵤ì¤Æ¤·¤Þ¤¦¤È¥¤¥Þ¥¤¥Á¤Ç¤Ï¤¢¤ë¡¥¤Î¤Ç¡¤¦Ç´ÊÌó¤ÏiF, nat_cata, tail¤Ê¤É¤Î½èÍý¤Î¸å¤Ë¤ä¤ë¡¥ -- For readability, we apply eta-reduction only when we can fully eta-reduce at the outermost lambda-abstraction. ppLambda [VarP n] (AppE e (VarE n')) | shown == show n' && not (shown `appearsIn` e) = e where shown = show n @@ -395,7 +397,7 @@ -} newtype Partial a = Part {undef :: a} undefs = map (\[a,b] -> (a,b)) $ - [-- x $(p [| (Part False :: Partial Bool, undefined :: Partial Bool) |]), $(p [| (Part EQ :: Partial Ordering, undefined :: Partial Ordering) |]), + [-- Bool や Orderingのように、ありがちな値を返してしまうものは、採用すべきでない。$(p [| (Part False :: Partial Bool, undefined :: Partial Bool) |]), $(p [| (Part EQ :: Partial Ordering, undefined :: Partial Ordering) |]), $(p [| (Part 53 :: Partial Int, undefined :: Partial Int) |]), $(p [| (Part '\29' :: Partial Char, undefined :: Partial Char) |]), $(p [| (Part [43] :: Partial [Int], undefined :: Partial [Int]) |]), @@ -506,7 +508,7 @@ by2_cmpPair (Ord compare1) (Ord compare2) = Ord $ comparePairBy compare1 compare2 comparePairBy compare1 compare2 (x,y) (z,w) = case compare1 x z of EQ -> compare2 y w o -> o -ords = $(p [| (cmp :: Ordered Bool, cmp :: Ordered Ordering, +ords = $(p [| (cmp :: Ordered Bool, cmp :: Ordered Ordering, -- なぜかcomment outされていたので復活させてみた。問題あるなら戻すが。 cmp :: Ordered Int, cmp :: Ordered Char, -- cmp :: Ordered (Ratio Int) is defined in ratioCls by1_cmpMaybe :: Ordered a -> Ordered (Maybe a), by1_cmpList :: Ordered a -> Ordered [a], by2_cmpEither :: Ordered a -> Ordered b -> Ordered (Either a b), by2_cmpPair :: Ordered a -> Ordered b -> Ordered (a,b)) |]) @@ -645,9 +647,9 @@ debug = $(p [| (list_para :: (->) [b] (a -> (b -> [b] -> a -> a) -> a), concatMap :: (a -> [b]) -> (->) [a] [b]) |] ) --- Library used by the program server backend +-- | Library used by the program server backend pgfull :: ProgGenSF --- pgfull = mkPG ($(MagicHaskeller.LibTH.load "libsrc/PreludeList.hs") ++ mb ++ bool ++ boolean ++ $(p [| ([], (:), (+) :: Int -> Int -> Int, replicate :: Int -> a -> [a]) |]) ++ $(p [| until :: (a -> Bool) -> (a -> a) -> a -> a |]) ++ nat ++ intinst) +-- pgfull = mkPG ($(MagicHaskeller.LibTH.load "libsrc/PreludeList.hs") ++ mb ++ bool ++ boolean ++ $(p [| ([], (:), (+) :: Int -> Int -> Int, replicate :: Int -> a -> [a]) |]) ++ $(p [| until :: (a -> Bool) -> (a -> a) -> a -> a |]) ++ nat ++ intinst) -- rich とあまり変わらない． pgfull = mkPGXOpt options{tv1=True,nrands=repeat 20,timeout=Just 100000} (eqs++ords) clspartialss full tupartialssNormal -- A pgfull must be a CAF, so we must have pgfulls and access pgfullSized via pgfulls. Directly calling pgfullSized is heap-inefficient. pgfulls :: [ProgGenSF] @@ -660,9 +662,10 @@ mkPgTotal = mkPGXOpts mkTrieOptSFIO options{tv1=True,nrands=repeat 20,timeout=Just 20000} (eqs++ords) [] full [] mkDebugPg :: IO ProgGenSF -mkDebugPg = mkPGXOpts mkTrieOptSFIO options{tv1=True,nrands=repeat 20,timeout=Just 20000} [] [] deb [] +mkDebugPg = mkPGXOpts mkTrieOptSFIO options{tv1=True,nrands=repeat 20,timeout=Just 20000} [] [] deb [[],[],[]] deb = [ $(p [| (reverse :: [a] -> [a], enumFromTo :: Int -> Int -> [Int], 1::Int, product :: [Int] -> Int, concatMap :: (a -> [b]) -> [a] -> [b]) |]), [],[]] +-- deb = [ $(p [| (show :: Int->[Char]) |]), [],[]] -- x String o [Char] pgfullIO :: IO ProgGenSFIORef pgfullIO = mkPGXOptIO options{tv1=True,nrands=repeat 20} (eqs++ords) clspartialss full tupartialssNormal @@ -710,7 +713,7 @@ flip (flip . either) :: (->) (Either a b) ((a -> c) -> (b -> c) -> c)) |]) ++ intinst2 ++ $(p [| (sum :: (->) [Int] Int, product :: (->) [Int] Int) |]), list2 ++ $(p [| (scanl :: (a -> b -> a) -> a -> [b] -> [a], scanr :: (a -> b -> b) -> b -> [a] -> [b], scanl1 :: (a -> a -> a) -> [a] -> [a], scanr1 :: (a -> a -> a) -> [a] -> [a], - -- until :: (a -> Bool) -> (a -> a) -> a -> a) + -- until :: (a -> Bool) -> (a -> a) -> a -> a) を入れてたが，どうもuntilがあると急に遅くなる．その割に，全く使われない．何じゃらホイ show :: Int -> [Char]) |])++ $(p [| ((,) :: a -> b -> (a,b), flip uncurry :: (->) (a,b) ((a->b->c) -> c)) |]), $(p [| ((,,) :: a -> b -> c -> (a,b,c), Left :: a -> Either a b, Right :: b -> Either a b, zip :: (->) [a] ((->) [b] [(a, b)]), diff --git a/MagicHaskeller/Types.lhs b/MagicHaskeller/Types.lhs --- a/MagicHaskeller/Types.lhs +++ b/MagicHaskeller/Types.lhs @@ -156,7 +156,7 @@ {-# INLINE normalizeVarIDs #-} -- FMType$B!$(BMemoTree$B$J$I$G(Bindex$B$9$k$H$-$N$?$a$K!$(BvarID$B$r(B0,1,...$B$K(Broot$BB&$+$i=g$K@55,2=$9$k(B normalizeVarIDs :: Type -> TyVar -> (Type, Decoder) -normalizeVarIDs ty mx = let decoList = sieve $ tyvars ty +normalizeVarIDs ty mx = let decoList = nub $ tyvars ty tup = zip decoList [0..] encoType = mapTV (\tv -> case lookup tv tup of Just n -> n) ty len = genericLength decoList @@ -164,8 +164,6 @@ mx + 1 - len 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 ] normalize ty = fst $ normalizeVarIDs ty (error "undef of normalize") eqType :: Type -> Type -> Bool