MagicHaskeller 0.9.6.4.5 → 0.9.6.4.6
raw patch · 7 files changed
+38/−47 lines, 7 files
Files
- MagicHaskeller.cabal +1/−2
- MagicHaskeller/CGI.lhs +1/−1
- MagicHaskeller/ExpToHtml.hs +8/−1
- MagicHaskeller/LibExcelStaged.hs +18/−20
- MagicHaskeller/LibExcelStagedStaged.hs +0/−14
- MagicHaskeller/LibTH.hs +9/−6
- MagicHaskeller/Types.lhs +1/−3
MagicHaskeller.cabal view
@@ -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
MagicHaskeller/CGI.lhs view
@@ -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
MagicHaskeller/ExpToHtml.hs view
@@ -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 ] ]
MagicHaskeller/LibExcelStaged.hs view
@@ -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
− MagicHaskeller/LibExcelStagedStaged.hs
@@ -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)
MagicHaskeller/LibTH.hs view
@@ -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)]),
MagicHaskeller/Types.lhs view
@@ -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