{-# 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

zip64, unzip64 :: String -> String
zip64 = B.pack > GZip.compress > B.unpack > C.encode
unzip64 = C.decode > B.pack > GZip.decompress > B.unpack