diff --git a/README.markdown b/README.markdown deleted file mode 100644 --- a/README.markdown +++ /dev/null @@ -1,18 +0,0 @@ -Message Passing Style Haskell Toolkit -===================================== - -Example --------- - -### OO (duck) Syntax - - euler_1 = ( [3,6..999] ++ [5,10..999] ).unique.sum - - -### Parallel map reduce - - p_eval' xs = xs.pseq( xs.reduce par ) - p_reduce' op xs = xs.p_eval'.reduce op - - p_map_reduce_to n m r xs = xs.split_to(n).map(m).p_reduce'(r) - p_map_reduce m r xs = p_map_reduce_to 16 m r xs diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,9 @@ +Message Passing Style Haskell Toolkit +===================================== + +Example +-------- + +### OO (duck) Syntax + + euler_1 = ( [3,6..999] ++ [5,10..999] ).unique.sum diff --git a/changelog.markdown b/changelog.markdown deleted file mode 100644 --- a/changelog.markdown +++ /dev/null @@ -1,90 +0,0 @@ -2009.5.13 ---------- - -### Fix - -* Minimal dependency - -2009.4.50 ----------- - -### Feature - -* xml helper, io helper - -### fix - -* unescape unicode parser use (try) - -2009.4.21 ---------- - -### Fix - -* starts_with returns true for the same string - -2009.4.20 ---------- - -### Feature - -* require interpolatedstring-qq -* Add here as alias of istr ( Ruby like string using QQ ). - -2008.11.15 ----------- - -### Fix - -* Replace `from_utf8` `to_utf8` to `b2u` `u2b` -* Comment on dynamic programming usage - -2008.11.6 ----------- - -### Feature - -* UTF8 wrapper -* Almost -Wall clean - -2008.10.25 ----------- - -* More string helpers -* introducing ^ - -2008.10.15 ----------- - -* Fix (use sub, as regexpr works per line) - -2008.10.14 ----------- - -* Fix strip bug - -2008.9.20 ----------- - -* Relax GHC package dependencies - -2008.9.19 ---------- - -* Change version system -* Add unescape_unicode_xml helper - -### Fix: - -* relax directory version - -0.0.0.1.1 ---------- - -relax pandoc version - -0.0.0.1 --------- - -compatible with newest Pandoc -added more helpers diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,99 @@ +2009.6.25 +-------- + +### Feature + +* new mps light with minimal dependency +* cross platform +* wall-all clean + +2009.5.13 +--------- + +### Fix + +* Minimal dependency + +2009.4.50 +---------- + +### Feature + +* xml helper, io helper + +### fix + +* unescape unicode parser use (try) + +2009.4.21 +--------- + +### Fix + +* starts_with returns true for the same string + +2009.4.20 +--------- + +### Feature + +* require interpolatedstring-qq +* Add here as alias of istr ( Ruby like string using QQ ). + +2008.11.15 +---------- + +### Fix + +* Replace `from_utf8` `to_utf8` to `b2u` `u2b` +* Comment on dynamic programming usage + +2008.11.6 +---------- + +### Feature + +* UTF8 wrapper +* Almost -Wall clean + +2008.10.25 +---------- + +* More string helpers +* introducing ^ + +2008.10.15 +---------- + +* Fix (use sub, as regexpr works per line) + +2008.10.14 +---------- + +* Fix strip bug + +2008.9.20 +---------- + +* Relax GHC package dependencies + +2008.9.19 +--------- + +* Change version system +* Add unescape_unicode_xml helper + +### Fix: + +* relax directory version + +0.0.0.1.1 +--------- + +relax pandoc version + +0.0.0.1 +-------- + +compatible with newest Pandoc +added more helpers diff --git a/mps.cabal b/mps.cabal --- a/mps.cabal +++ b/mps.cabal @@ -1,5 +1,5 @@ Name: mps -Version: 2009.5.13 +Version: 2009.6.25 Build-type: Simple Synopsis: message passing style helpers Description: message passing style helpers @@ -8,14 +8,14 @@ Maintainer: Wang, Jinjing Build-Depends: base Cabal-version: >= 1.2 -data-files: README.markdown, changelog.markdown +data-files: README.md, changelog.md category: Development license-file: LICENSE homepage: http://github.com/nfjinjing/mps/ library - ghc-options: -Wall -fno-warn-missing-signatures -fno-warn-name-shadowing -fno-warn-orphans -fno-warn-type-defaults - build-depends: base, containers, array, parallel, time, bytestring >= 0.9, regexpr >= 0.3.4, parsec >= 2, utf8-string >= 0.3.3, directory, interpolatedstring-qq, base64-string, zlib, old-locale, unix, filepath + ghc-options: -Wall + build-depends: base >= 4 && < 5, containers, array, parallel, old-time, time, bytestring >= 0.9, regexpr >= 0.3.4, parsec >= 2, utf8-string >= 0.3.3, directory, interpolatedstring-qq, base64-string, zlib, old-locale, filepath, template-haskell hs-source-dirs: src/ - exposed-modules: MPS, MPSUTF8 + exposed-modules: MPS, MPSUTF8, MPS.Light, MPS.Extra, MPS.Heavy, MPS.TH other-modules: MPS.UTF8 diff --git a/src/MPS.hs b/src/MPS.hs --- a/src/MPS.hs +++ b/src/MPS.hs @@ -1,368 +1,7 @@ -{-# LANGUAGE NoMonomorphismRestriction #-} - -module MPS where - -import Prelude hiding ((.), sum, product, maximum, minimum, - foldl, foldr, foldl1, foldr1, concat, concatMap, and, or, any, all, elem, (^), (>), (/)) -import qualified Prelude as Prelude - -import Control.Arrow ((&&&), (>>>), (<<<)) -import Control.Monad hiding (join) -import Control.Parallel - -import Data.Char -import Data.Maybe -import Data.Foldable -import Data.Time.Clock.POSIX -import Data.Time -import Data.List (transpose, group, (\\), sortBy, isPrefixOf, isSuffixOf) - -import qualified Data.Array as A -import qualified Data.List as L -import qualified Data.Set as S -import qualified Data.Map as M -import qualified Data.ByteString.Lazy.Char8 as B - -import System.Locale -import System.Posix.Files -import System.IO -import System.Directory -import qualified System.IO.Unsafe as Unsafe - -import Text.RegexPR -import Text.InterpolatedString.QQ -import Text.ParserCombinators.Parsec (many, char, many1, digit, (<|>), Parser, anyChar, try) -import qualified Text.ParserCombinators.Parsec as P - -import Codec.Binary.Base64.String as C -import qualified Codec.Binary.UTF8.String as Codec -import qualified Codec.Compression.GZip as GZip -import System.FilePath (()) -import Debug.Trace -import Numeric - - --- base DSL -(.) :: a -> (a -> b) -> b -a . f = f a -infixl 9 . - -(>) = (>>>) -infixl 8 > - -(^) = flip fmap -infixl 8 ^ - -(/) :: FilePath -> FilePath -> FilePath -(/) = () -infixl 5 / - --- List -join = L.intercalate -join' = concat -first = head -second = at 1 -third = at 2 -forth = at 3 -fifth = at 4 -sixth = at 5 -seventh = at 6 -eighth = at 7 -ninth = at 8 -tenth = at 10 - --- Set requires Ord instance, so use nub when --- xs is not comparable -unique = to_set > to_list -is_unique xs = xs.unique.length == xs.length - -same = unique > length > is 1 -times = flip replicate -upto = flip enumFromTo -downto m n = [n, n-1.. m] - -remove_at n xs = xs.take n ++ xs.drop (n+1) -insert_at n x xs = splitted.fst ++ [x] ++ splitted.snd where splitted = xs.splitAt n -replace_at n x xs = xs.take n ++ [x] ++ xs.drop (n+1) -at = flip (!!) - -slice l r xs = xs.take r.drop l -cherry_pick ids xs = ids.map(xs !!) -reduce = foldl1 -reduce' f (x:xs) = inject' x f xs -reduce' _ _ = error "reduce' takes a list of at least 2 elements" -inject init f = foldl f init -inject' init f = foldl' f init -none_of f = any f > not -select = filter -reject f = filter(f > not) -lookup' i xs = xs.lookup i .fromJust - -inner_map f = map (map f) -inner_reduce f = map(reduce f) -inner_inject init f = map(inject init f) - -label_by f = map(f &&& id) -labeling f = map(id &&& f) - - -in_group_of _ [] = [] -in_group_of n xs = h : t.in_group_of(n) where (h, t) = xs.splitAt(n) -split_to n xs = xs.in_group_of(size) where - l = xs.length - size = if l < n then 1 else l `div` n - -apply x f = f x -send_to = apply -let_receive f = flip f -map_send_to x = map(send_to(x)) - -belongs_to = flip elem -has = flip belongs_to - - - -indexed = zip([0..]) -map_with_index f = indexed > map f - - - -ljust n x xs - | n < xs.length = xs - | otherwise = ( n.times x ++ xs ).reverse.take n.reverse - -rjust n x xs - | n < xs.length = xs - | otherwise = ( xs ++ n.times x ).take n - -ub = takeWhile -lb f = dropWhile ( not <<< f ) -between a b xs = xs.lb a .ub b - - -not_null = null > not -powerslice xs = [ xs.slice j (j+i) | - i <- l.downto 1, - j <- [0..l - i] - ] - where l = xs.length - - --- only works for sorted list --- but could be infinite --- e.g. a `common` b `common` c -common _ [] = [] -common [] _ = [] -common a@(x:xs) b@(y:ys) - | x .is y = y : common xs b - | x < y = common xs b - | otherwise = common a ys - - --- faster reverse sort -rsort xs = xs.L.sortBy(\a b -> b `compare` a) - -encode xs = xs.group.map (length &&& head) -decode xs = xs.map(\(l,x) -> l.times x).join' - -only_one [_] = True -only_one _ = False - -concat_map f xs = concatMap f xs - - - --- Map -to_h xs = xs.M.fromList - --- BackPorts -on :: (b -> b -> c) -> (a -> b) -> a -> a -> c -(*) `on` f = \x y -> f x * f y - --- Ord -compare_by = on compare -eq = flip (==) -is = eq -is_not a b = not (is a b) -isn't = is_not -aren't = is_not - --- Tuple -swap (x,y) = (y,x) -tuple2 = first &&& last -tuple3 xs = (xs.first, xs.second, xs.third) -list2 (x,y) = [x,y] -list3 (x,y,z) = [x,y,z] -filter_fst f = filter(fst > f) -filter_snd f = filter(snd > f) -only_fst = map fst -only_snd = map snd -map_fst f = map(\(a,b) -> (f a, b)) -map_snd f = map(\(a,b) -> (a, f b)) -pair f a b = f (a,b) -triple f a b c = f (a,b,c) -splash f (a,b) = f a b -splash3 f (a,b,c) = f a b c -twin x = (x,x) - - - --- Parallel -p_eval xs = xs.par(xs.reduce(par)) -p_reduce op xs = xs.p_eval.reduce(op) -p_map op xs = xs.map(op).p_eval - -p_eval' xs = xs.pseq( xs.reduce par ) -p_reduce' op xs = xs.p_eval'.reduce op -p_map' op xs = xs.map op .p_eval' - - -p_split_to n xs = xs.in_group_of(n).L.transpose -p_map_reduce_to n m r xs = xs.split_to n .map m .p_reduce' r -p_map_reduce m r xs = p_map_reduce_to 16 m r xs - --- Date -date = fromGregorian -splash_date = toGregorian - --- String -split re xs - | xs.match re .isJust = splitRegexPR re xs .reject empty - | otherwise = [xs] - - -split' s = s.lines.reject empty -sub = subRegexPR -gsub = gsubRegexPR -match = matchRegexPR - -strip s = s.sub "^\\s*" "" .reverse .sub "^\\s*" "" .reverse -empty s = case s.match("\\S") of - Just _ -> False - Nothing -> True - -to_s x = x.show - --- Var -is_palindrom s = s.reverse.is s - - --- Integer -collapse' [] _ r = r -collapse' (x:xs) q r = collapse' xs (q+1) (r + x * 10 Prelude.^ q) -collapse xs = collapse' (xs.reverse.map from_i) 0 0 .fromIntegral - -explode n = n.show.map digitToInt - -base p n = showIntAtBase p intToDigit n "" -from_i = fromIntegral - -int_square n = n.fromIntegral.sqrt.round :: Integer - - --- Fold -to_list = toList - --- Set -to_set = S.fromList - --- Array -to_a xs = A.listArray (0, xs.length - 1) xs -to_a' i xs = A.listArray i xs -hist bnds ns = A.accumArray (+) 0 bnds [(n, 1) | n <- ns, A.inRange bnds n] - - --- Parser -parse p s = case (P.parse p "" s) of - Left err -> err.show.error - Right x -> x - - --- Debug -trace' x = trace (x.show) x - - --- String -lower = map toLower -upper = map toUpper - -starts_with = isPrefixOf -ends_with = isSuffixOf - -capitalize [] = [] -capitalize (x:xs) = [x].upper ++ xs.lower -camel_case = split "_" > map capitalize > join' -snake_case = gsub "\\B[A-Z]" "_\\&" > lower - --- XML -unescape_unicode_xml s = parse unescape_parser s - where - unicode_char :: Parser Char - unicode_char = do - char '&' - char '#' - word <- many1 digit - char ';' - return $ chr (read word) - - unescape_parser :: Parser String - unescape_parser = many (try unicode_char <|> anyChar) - -escape_unicode_xml :: String -> String -escape_unicode_xml = concatMap fixChar - where - fixChar '<' = "<" - fixChar '>' = ">" - fixChar '&' = "&" - fixChar '"' = "\"" - fixChar c | ord c < 0x80 = [c] - fixChar c = "&#" ++ show (ord c) ++ ";" - --- IO -purify = Unsafe.unsafePerformIO -read_pure x = x.readFile.purify -write_pure file c = writeFile file c - -ls s = getDirectoryContents s ^ (\\ [".", ".."]) - -file_size :: String -> IO Integer -file_size path = withFile (path.u2b) ReadMode hFileSize - -file_mtime :: String -> IO UTCTime -file_mtime path = getFileStatus (path.u2b) - ^ modificationTime ^ realToFrac ^ posixSecondsToUTCTime - -read_binary_file :: String -> IO String -read_binary_file path = path.u2b.B.readFile ^ B.unpack - -get_permissions :: String -> IO Permissions -get_permissions path = getPermissions (path.u2b) - -get_current_directory :: IO String -get_current_directory = getCurrentDirectory ^ b2u - --- Text -filter_comment = - lines > map strip > reject null > reject (head > (== '#')) > unlines - --- Time -now :: IO UTCTime -now = getCurrentTime - -format_time :: String -> UTCTime -> String -format_time = formatTime defaultTimeLocale - - --- UTF8 -b2u = Codec.decodeString -u2b = Codec.encodeString - --- QQ - -here = istr - --- compress +module MPS ( + module MPS.Light + , module MPS.Extra +) where -zip64, unzip64 :: String -> String -zip64 = B.pack > GZip.compress > B.unpack > C.encode -unzip64 = C.decode > B.pack > GZip.decompress > B.unpack +import MPS.Light +import MPS.Extra diff --git a/src/MPS/Extra.hs b/src/MPS/Extra.hs new file mode 100644 --- /dev/null +++ b/src/MPS/Extra.hs @@ -0,0 +1,135 @@ +module MPS.Extra where + +import Control.Parallel +import Data.Char +import Data.List (transpose, (\\)) +import Data.Maybe +import Data.Time +import Data.Time.Clock.POSIX +import MPS.Light +import Numeric +import Prelude hiding ((.), (^), (>), (/), elem, foldl) +import System.Directory +import System.IO +import System.Locale (defaultTimeLocale) +import System.Time +import Text.RegexPR +import qualified Codec.Binary.UTF8.String as Codec +import qualified Data.ByteString.Lazy.Char8 as B +import qualified Data.List as L +import qualified Prelude as Prelude +import qualified System.IO.Unsafe as Unsafe + + + +-- Parallel +p_eval, p_eval' :: [a] -> [a] +p_reduce, p_reduce' :: (a -> a -> a) -> [a] -> a +p_map, p_map' :: (a -> b) -> [a] -> [b] +p_split_to :: Int -> [t] -> [[t]] +p_map_reduce_to :: Int -> ([a] -> b) -> (b -> b -> b) -> [a] -> b +p_map_reduce :: ([a] -> b) -> (b -> b -> b) -> [a] -> b + +p_eval xs = xs.par(xs.reduce(par)) +p_reduce op xs = xs.p_eval.reduce(op) +p_map op xs = xs.map(op).p_eval + +p_eval' xs = xs.pseq( xs.reduce par ) +p_reduce' op xs = xs.p_eval'.reduce op +p_map' op xs = xs.map op .p_eval' + + +p_split_to n xs = xs.in_group_of(n).L.transpose +p_map_reduce_to n m r xs = xs.split_to n .map m .p_reduce' r +p_map_reduce m r xs = p_map_reduce_to 16 m r xs + +-- Date +date :: Integer -> Int -> Int -> Data.Time.Day +splash_date :: Data.Time.Day -> (Integer, Int, Int) +date = fromGregorian +splash_date = toGregorian + +-- String +split :: String -> String -> [String] +split re xs + | xs.match re .isJust = splitRegexPR re xs .reject empty + | otherwise = [xs] + +split' :: String -> [String] +split' s = s.lines.reject empty + +sub :: String -> String -> String -> String +sub = subRegexPR + +gsub :: String -> String -> String -> String +gsub = gsubRegexPR + +type RegexResult = ( String, (String, String) ) +type MatchList = [ (Int, String) ] +match :: String -> String -> Maybe (RegexResult, MatchList) +match = matchRegexPR + +strip :: String -> String +strip s = s.sub "^\\s*" "" .reverse .sub "^\\s*" "" .reverse + +empty :: String -> Bool +empty s = case s.match("\\S") of + Just _ -> False + Nothing -> True + + +-- Integer +collapse :: (Integral a, Num b) => [a] -> b +collapse xs = collapse' (xs.reverse.map from_i) (0 :: Int) (0 :: Int) .fromIntegral + where + collapse' [] _ r = r + collapse' (x:xs') q r = collapse' xs' (q+1) (r + x * 10 Prelude.^ q) + +base :: (Integral a) => a -> a -> String +base p n = showIntAtBase p intToDigit n "" + +-- String +camel_case, snake_case :: String -> String +camel_case = split "_" > map capitalize > join' +snake_case = gsub "\\B[A-Z]" "_\\&" > lower + +-- IO +purify :: IO a -> a +purify = Unsafe.unsafePerformIO + +ls :: String -> IO [String] +ls s = getDirectoryContents s ^ (\\ [".", ".."]) + +file_size :: String -> IO Integer +file_size path = withFile (path.u2b) ReadMode hFileSize + +file_mtime :: String -> IO UTCTime +file_mtime path = + getModificationTime (path.u2b) ^ seconds ^ from_i ^ posixSecondsToUTCTime + where seconds (TOD s _) = s + +read_binary_file :: String -> IO String +read_binary_file path = path.u2b.B.readFile ^ B.unpack + +get_permissions :: String -> IO Permissions +get_permissions path = getPermissions (path.u2b) + +get_current_directory :: IO String +get_current_directory = getCurrentDirectory ^ b2u + +-- Time +now :: IO UTCTime +now = getCurrentTime + +format_time :: String -> UTCTime -> String +format_time = formatTime defaultTimeLocale + +-- Text +filter_comment :: String -> String +filter_comment = + lines > map strip > reject null > reject (head > (== '#')) > unlines + +-- UTF8 +b2u, u2b :: String -> String +b2u = Codec.decodeString +u2b = Codec.encodeString diff --git a/src/MPS/Heavy.hs b/src/MPS/Heavy.hs new file mode 100644 --- /dev/null +++ b/src/MPS/Heavy.hs @@ -0,0 +1,49 @@ +module MPS.Heavy where + +import Codec.Binary.Base64.String as C +import Data.Char +import MPS.Light +import Prelude hiding ((.), (^), (>), (/), elem, foldl) +import Text.ParserCombinators.Parsec (many, char, many1, digit, (<|>), Parser, anyChar, try) +import qualified Codec.Compression.GZip as GZip +import qualified Data.ByteString.Lazy.Char8 as B +import qualified Text.ParserCombinators.Parsec as P + + +-- compress + +zip64, unzip64 :: String -> String +zip64 = B.pack > GZip.compress > B.unpack > C.encode +unzip64 = C.decode > B.pack > GZip.decompress > B.unpack + +-- Parser +parse :: P.GenParser tok () a -> [tok] -> a +parse p s = case (P.parse p "" s) of + Left err -> err.show.error + Right x -> x + + +-- XML +unescape_unicode_xml :: String -> String +unescape_unicode_xml s = parse unescape_parser s + where + unicode_char :: Parser Char + unicode_char = do + char '&' + char '#' + word <- many1 digit + char ';' + return $ chr (read word) + + unescape_parser :: Parser String + unescape_parser = many (try unicode_char <|> anyChar) + +escape_unicode_xml :: String -> String +escape_unicode_xml = concatMap fixChar + where + fixChar '<' = "<" + fixChar '>' = ">" + fixChar '&' = "&" + fixChar '"' = "\"" + fixChar c | ord c < 0x80 = [c] + fixChar c = "&#" ++ show (ord c) ++ ";" diff --git a/src/MPS/Light.hs b/src/MPS/Light.hs new file mode 100644 --- /dev/null +++ b/src/MPS/Light.hs @@ -0,0 +1,322 @@ +module MPS.Light where + +import Control.Arrow ((&&&), (>>>)) +import Control.Category (Category) +import Data.Char +import Data.Foldable (elem, foldl, foldl', toList, Foldable) +import Data.Function (on) +import Debug.Trace +import Prelude hiding ((.), (^), (>), (/), elem, foldl, foldl1) +import System.FilePath (()) +import qualified Data.Array as A +import qualified Data.List as L +import qualified Data.Map as M +import qualified Data.Set as S + +-- base DSL +(.) :: a -> (a -> b) -> b +a . f = f a +infixl 9 . + +(>) :: (Category cat) => cat a b -> cat b c -> cat a c +(>) = (>>>) +infixl 8 > + +(^) :: (Functor f) => f a -> (a -> b) -> f b +(^) = flip fmap +infixl 8 ^ + +(/) :: FilePath -> FilePath -> FilePath +(/) = () +infixl 5 / + +-- List +join :: [a] -> [[a]] -> [a] +join = L.intercalate + +join' :: [[a]] -> [a] +join' = concat + +first, second, third, forth, fifth :: [a] -> a +sixth, seventh, eighth, ninth, tenth :: [a] -> a +first = head +second = at 1 +third = at 2 +forth = at 3 +fifth = at 4 +sixth = at 5 +seventh = at 6 +eighth = at 7 +ninth = at 8 +tenth = at 10 + +-- Set requires Ord instance, so use nub when +-- xs is not comparable +unique :: (Ord a) => [a] -> [a] +unique = to_set > to_list + +is_unique :: (Ord a) => [a] -> Bool +is_unique xs = xs.unique.length == xs.length + +same :: (Ord a) => [a] -> Bool +same = unique > length > is 1 + +times :: b -> Int -> [b] +times = flip replicate + +upto :: (Enum a) => a -> a -> [a] +upto = flip enumFromTo + +downto :: (Num t, Enum t) => t -> t -> [t] +downto m n = [n, n-1.. m] + +remove_at :: Int -> [a] -> [a] +remove_at n xs = xs.take n ++ xs.drop (n+1) + +insert_at, replace_at :: Int -> a -> [a] -> [a] +insert_at n x xs = splitted.fst ++ [x] ++ splitted.snd + where splitted = xs.splitAt n +replace_at n x xs = xs.take n ++ [x] ++ xs.drop (n+1) + +at :: Int -> [a] -> a +at = flip (!!) + +slice :: Int -> Int -> [a] -> [a] +slice l r = take r > drop l + +cherry_pick :: [Int] -> [a] -> [a] +cherry_pick ids xs = ids.map(xs !!) + +reduce, reduce' :: (a -> a -> a) -> [a] -> a +reduce = L.foldl1 +reduce' = L.foldl1' + +inject, inject' :: (Foldable t) => a -> (a -> b -> a) -> t b -> a +inject = flip foldl +inject' = flip foldl' + +none_of :: (a -> Bool) -> [a] -> Bool +none_of f = any f > not + +select, reject :: (a -> Bool) -> [a] -> [a] +select = filter +reject f = filter (f > not) + +inner_map :: (a -> b) -> [[a]] -> [[b]] +inner_map f = map (map f) + +inner_reduce :: (a -> a -> a) -> [[a]] -> [a] +inner_reduce f = map (reduce f) + +inner_inject :: (Foldable t) => a -> (a -> b -> a) -> [t b] -> [a] +inner_inject x f = map (inject x f) + +label_by :: (a -> c) -> [a] -> [(c, a)] +label_by f = map (f &&& id) + +labeling :: (a -> c') -> [a] -> [(a, c')] +labeling f = map(id &&& f) + +in_group_of :: Int -> [t] -> [[t]] +in_group_of _ [] = [] +in_group_of n xs = h : t.in_group_of(n) where (h, t) = xs.splitAt(n) + +split_to :: Int -> [a] -> [[a]] +split_to n xs = xs.in_group_of(size) where + l = xs.length + size = if l < n then 1 else l `div` n + +apply, send_to :: a -> (a -> b) -> b +apply x f = f x +send_to = apply + +let_receive :: (a -> b -> c) -> b -> a -> c +let_receive f = flip f + +map_send_to :: a -> [a -> b] -> [b] +map_send_to x = map (send_to(x)) + +belongs_to :: (Foldable t, Eq a) => t a -> a -> Bool +belongs_to = flip elem + +has :: (Foldable t, Eq b) => b -> t b -> Bool +has = flip belongs_to + +indexed :: (Num t, Enum t) => [b] -> [(t, b)] +indexed = zip([0..]) + +map_with_index :: (Num t, Enum t) => ((t, b) -> b1) -> [b] -> [b1] +map_with_index f = indexed > map f + +ljust, rjust :: Int -> a -> [a] -> [a] +ljust n x xs + | n < xs.length = xs + | otherwise = ( n.times x ++ xs ).reverse.take n.reverse + +rjust n x xs + | n < xs.length = xs + | otherwise = ( xs ++ n.times x ).take n + +ub, lb :: (a -> Bool) -> [a] -> [a] +ub = takeWhile +lb f = dropWhile ( f > not ) + +between :: (a -> Bool) -> (a -> Bool) -> [a] -> [a] +between a b xs = xs.lb a .ub b + +not_null :: [a] -> Bool +not_null = null > not + +powerslice :: [a] -> [[a]] +powerslice xs = [ xs.slice j (j+i) | + i <- l.downto 1, + j <- [0..l - i] + ] + where l = xs.length + +-- only works for sorted list +-- but could be infinite +-- e.g. a `common` b `common` c +common :: (Ord a) => [a] -> [a] -> [a] +common _ [] = [] +common [] _ = [] +common a@(x:xs) b@(y:ys) + | x .is y = y : common xs b + | x < y = common xs b + | otherwise = common a ys + + +-- faster reverse sort +rsort :: (Ord a) => [a] -> [a] +rsort xs = xs.L.sortBy(\a b -> b `compare` a) + +encode :: (Eq a) => [a] -> [(Int, a)] +encode xs = xs.L.group.map (length &&& head) + +decode :: [(Int, a)] -> [a] +decode xs = xs.map(\(l,x) -> l.times x).join' + + +only_one :: [a] -> Bool +only_one [_] = True +only_one _ = False + +concat_map :: (a -> [b]) -> [a] -> [b] +concat_map = concatMap + +-- Fold +to_list :: (Foldable t) => t a -> [a] +to_list = toList + +-- Set +to_set :: (Ord a) => [a] -> S.Set a +to_set = S.fromList + +-- Map +to_h :: (Ord k) => [(k, a)] -> M.Map k a +to_h xs = xs.M.fromList + +-- Array +to_a :: [a] -> A.Array Int a +to_a xs = A.listArray (0, xs.length - 1) xs + +to_a' :: (A.Ix i) => (i, i) -> [e] -> A.Array i e +to_a' i xs = A.listArray i xs + +hist :: (Num e, A.Ix i) => (i, i) -> [i] -> A.Array i e +hist bnds ns = A.accumArray (+) 0 bnds [(n, 1) | n <- ns, A.inRange bnds n] + + +-- Ord +compare_by :: (Ord b) => (a -> b) -> a -> a -> Ordering +compare_by = on compare + +eq, is, is_not, isn't, aren't :: (Eq a) => a -> a -> Bool +eq = flip (==) +is = eq +is_not a b = not (is a b) +isn't = is_not +aren't = is_not + +-- Tuple +swap :: (a, b) -> (b, a) +swap (x,y) = (y,x) + +tuple2 :: [a] -> (a, a) +tuple2 = first &&& last + +tuple3 :: [a] -> (a, a, a) +tuple3 xs = (xs.first, xs.second, xs.third) + +list2 :: (a, a) -> [a] +list2 (x,y) = [x,y] + +list3 :: (a, a, a) -> [a] +list3 (x,y,z) = [x,y,z] + +filter_fst :: (a -> Bool) -> [(a, b)] -> [(a, b)] +filter_fst f = filter(fst > f) + +filter_snd :: (b -> Bool) -> [(a, b)] -> [(a, b)] +filter_snd f = filter(snd > f) + +only_fst :: [(a, b)] -> [a] +only_fst = map fst + +only_snd :: [(a, b)] -> [b] +only_snd = map snd + +map_fst :: (a -> b) -> [(a, c)] -> [(b, c)] +map_fst f = map(\(a,b) -> (f a, b)) + +map_snd :: (a -> b) -> [(c, a)] -> [(c, b)] +map_snd f = map(\(a,b) -> (a, f b)) + +pair :: ((a, b) -> c) -> a -> b -> c +pair f a b = f (a,b) + +triple :: ((a, b, c) -> d) -> a -> b -> c -> d +triple f a b c = f (a,b,c) + +splash :: (a -> b -> c) -> (a, b) -> c +splash f (a,b) = f a b + +splash3 :: (a -> b -> c -> d) -> (a, b, c) -> d +splash3 f (a,b,c) = f a b c + +twin :: a -> (a, a) +twin x = (x,x) + +-- Integer +from_i :: (Integral a, Num b) => a -> b +from_i = fromIntegral + +explode :: (Show a) => a -> [Int] +explode n = n.show.map digitToInt + +-- String +lower, upper :: String -> String +lower = map toLower +upper = map toUpper + +starts_with, ends_with :: String -> String -> Bool +starts_with = L.isPrefixOf +ends_with = L.isSuffixOf + +capitalize :: String -> String +capitalize [] = [] +capitalize (x:xs) = [x].upper ++ xs.lower + +to_s :: (Show a) => a -> String +to_s x = x.show + + + +-- Simple Math +-- Var +is_palindrom :: (Eq a) => [a] -> Bool +is_palindrom s = s.reverse.is s + +-- Debug +trace' :: (Show a) => a -> a +trace' x = trace (x.show) x diff --git a/src/MPS/TH.hs b/src/MPS/TH.hs new file mode 100644 --- /dev/null +++ b/src/MPS/TH.hs @@ -0,0 +1,8 @@ +module MPS.TH where + +import Language.Haskell.TH.Quote (QuasiQuoter) +import Text.InterpolatedString.QQ + +-- QQ +here :: QuasiQuoter +here = istr diff --git a/src/MPS/UTF8.hs b/src/MPS/UTF8.hs --- a/src/MPS/UTF8.hs +++ b/src/MPS/UTF8.hs @@ -1,24 +1,41 @@ module MPS.UTF8 where -import System.IO.UTF8 (readFile, writeFile) -import qualified MPS as MPS -import Prelude hiding ((.), (^), readFile, writeFile, (>)) import MPS hiding (split, gsub, match, sub, strip) +import Prelude hiding ((.), (^), readFile, writeFile, (>)) import System.Directory - +import System.IO.UTF8 (readFile, writeFile) +import qualified MPS as MPS -- io +read_file :: String -> IO String read_file = readFile + +write_file :: String -> String -> IO () write_file = writeFile -ls x = MPS.ls (x.u2b) ^ map b2u -mkdir_p = u2b > createDirectoryIfMissing True +ls :: String -> IO [String] +ls x = MPS.ls (x.u2b) ^ map b2u + +mkdir_p :: String -> IO () +mkdir_p = u2b > createDirectoryIfMissing True + +file_exist :: String -> IO Bool file_exist = u2b > doesFileExist + +dir_exist :: String -> IO Bool dir_exist = u2b > doesDirectoryExist +split :: String -> String -> [String] split x y = MPS.split (x.u2b) (y.u2b) .map b2u + +gsub :: String -> String -> String -> String gsub x y z = MPS.gsub (x.u2b) (y.u2b) (z.u2b) .b2u + +sub :: String -> String -> String -> String sub x y z = MPS.sub (x.u2b) (y.u2b) (z.u2b) .b2u + +match :: String -> String -> Maybe (RegexResult, MatchList) match x y = MPS.match (x.u2b) (y.u2b) +strip :: String -> String strip x = MPS.strip (x.u2b) .b2u diff --git a/src/MPSUTF8.hs b/src/MPSUTF8.hs --- a/src/MPSUTF8.hs +++ b/src/MPSUTF8.hs @@ -1,6 +1,6 @@ module MPSUTF8 ( - module MPS, - module MPS.UTF8 + module MPS + , module MPS.UTF8 ) where import MPS hiding (split, gsub, sub, match, ls, strip)