{-# LANGUAGE NoImplicitPrelude #-}
module Language.Fay.Stdlib
  (($)
  ,($!)
  ,(!!)
  ,(++)
  ,(.)
  ,(=<<)
  ,(**)
  ,(^^)
  ,(^)
  ,Either(..)
  ,Ordering(..)
  ,abs
  ,acos
  ,acosh
  ,all
  ,and
  ,any
  ,asin
  ,asinh
  ,asTypeOf
  ,atan
  ,atanh
  ,break
  ,ceiling
  ,compare
  ,concat
  ,concatMap
  ,const
  ,cos
  ,cosh
  ,curry
  ,cycle
  ,div
  ,divMod
  ,drop
  ,dropWhile
  ,either
  ,elem
  ,enumFrom
  ,enumFromThen
  ,enumFromThenTo
  ,enumFromTo
  ,error
  ,even
  ,exp
  ,filter
  ,find
  ,flip
  ,floor
  ,foldl
  ,foldl1
  ,foldr
  ,foldr1
  ,forM_
  ,fromInteger
  ,fromIntegral
  ,fromRational
  ,fst
  ,gcd
  ,head
  ,id
  ,init
  ,insertBy
  ,intercalate
  ,intersperse
  ,iterate
  ,last
  ,lcm
  ,length
  ,lines
  ,log
  ,logBase
  ,lookup
  ,map
  ,mapM_
  ,max
  ,maximum
  ,maybe
  ,min
  ,minimum
  ,mod
  ,negate
  ,not
  ,notElem
  ,nub
  ,null
  ,odd
  ,or
  ,otherwise
  ,pi
  ,pred
  ,prependToAll
  ,print
  ,product
  ,properFraction
  ,putStrLn
  ,quot
  ,quotRem
  ,recip
  ,rem
  ,repeat
  ,replicate
  ,reverse
  ,round
  ,scanl
  ,scanl1
  ,scanr
  ,scanr1
  ,seq
  ,sequence
  ,sequence_
  ,show
  ,signum
  ,sin
  ,sinh
  ,snd
  ,sort
  ,sortBy
  ,span
  ,splitAt
  ,sqrt
  ,subtract
  ,succ
  ,sum
  ,tail
  ,take
  ,takeWhile
  ,tan
  ,tanh
  ,truncate
  ,uncurry
  ,undefined
  ,unlines
  ,until
  ,unwords
  ,unzip
  ,unzip3
  ,when
  ,words
  ,zip
  ,zip3
  ,zipWith
  ,zipWith3)
  where

import           Language.Fay.FFI
import           Prelude          (Bool (..), Double, Eq (..), Fractional,
                                   Fractional ((/)), Int, Integer, Maybe (..),
                                   Monad (..), Num ((+), (-), (*)),
                                   Ord ((>), (<)), Rational, Show, String, seq,
                                   (&&), (||))

error :: String -> a
error str = case error' str of 0 -> error str ; _ -> error str

error' :: String -> Int
error' = ffi "(function() { throw %1 })()"

undefined :: a
undefined = error "Prelude.undefined"

show :: (Foreign a, Show a) => a -> String
show = ffi "JSON.stringify(%1)"

data Either a b = Left a | Right b

either :: (a -> c) -> (b -> c) -> Either a b -> c
either f _ (Left a) = f a
either _ g (Right b) = g b

-- There is only Double in JS.
fromInteger :: a -> a
fromInteger x = x

fromRational :: a -> a
fromRational x = x

negate :: Num a => a -> a
negate x = (-x)

abs :: (Num a, Ord a) => a -> a
abs x = if x < 0 then negate x else x

signum :: (Num a, Ord a) => a -> a
signum x = if x > 0 then 1 else if x == 0 then 0 else -1

pi :: Double
pi = ffi "Math.PI"

exp :: Double -> Double
exp = ffi "Math.exp(%1)"

sqrt :: Double -> Double
sqrt = ffi "Math.sqrt(%1)"

log :: Double -> Double
log = ffi "Math.log(%1)"

(**) :: Double -> Double -> Double
(**) = unsafePow
infixr 8 **

(^^) :: Double -> Int -> Double
(^^) = unsafePow
infixr 8 ^^

unsafePow :: (Foreign a, Num a, Foreign b, Num b) => a -> b -> a
unsafePow = ffi "Math.pow(%1,%2)"

(^) :: Num a => a -> Int -> a
a ^ b | b < 0  = error "(^): negative exponent"
      | b == 0 = 1
      | even b = let x = a ^ (b `quot` 2) in x * x
a ^ b          = a * a ^ (b - 1)
infixr 8 ^

logBase :: Double -> Double -> Double
logBase b x = log x / log b

sin :: Double -> Double
sin = ffi "Math.sin(%1)"

tan :: Double -> Double
tan = ffi "Math.tan(%1)"

cos :: Double -> Double
cos = ffi "Math.cos(%1)"

asin :: Double -> Double
asin = ffi "Math.asin(%1)"

atan :: Double -> Double
atan = ffi "Math.atan(%1)"

acos :: Double -> Double
acos = ffi "Math.acos(%1)"

sinh :: Double -> Double
sinh x = (exp x - exp (-x)) / 2

tanh :: Double -> Double
tanh x = let a = exp x ; b = exp (-x) in (a - b) / (a + b)

cosh :: Double -> Double
cosh x = (exp x + exp (-x)) / 2

asinh :: Double -> Double
asinh x = log (x + sqrt(x**2 + 1))

atanh :: Double -> Double
atanh x = log ((1 + x) / (1 - x)) / 2

acosh :: Double -> Double
acosh x = log (x + sqrt (x**2 - 1))

properFraction :: Double -> (Int, Double)
properFraction x = let a = truncate x in (a, x - fromIntegral a)

truncate :: Double -> Int
truncate x = if x < 0 then ceiling x else floor x

round :: Double -> Int
round = ffi "Math.round(%1)"

ceiling :: Double -> Int
ceiling = ffi "Math.ceil(%1)"

floor :: Double -> Int
floor = ffi "Math.floor(%1)"

subtract :: Num a => a -> a -> a
subtract = flip (-)

even :: Int -> Bool
even x = x `rem` 2 == 0

odd :: Int -> Bool
odd x = not (even x)

gcd :: Int -> Int -> Int
gcd a b = go (abs a) (abs b)
  where go x 0 = x
        go x y = go y (x `rem` y)

lcm :: Int -> Int -> Int
lcm _ 0 = 0
lcm 0 _ = 0
lcm a b = abs ((a `quot` (gcd a b)) * b)

curry :: ((a, b) -> c) -> a -> b -> c
curry f x y = f (x, y)

uncurry :: (a -> b -> c) -> (a, b) -> c
uncurry f p = case p of (x, y) -> f x y

snd :: (t, t1) -> t1
snd (_,x) = x

fst :: (t, t1) -> t
fst (x,_) = x

find :: (a -> Bool) -> [a] -> Maybe a
find p (x:xs) = if p x then Just x else find p xs
find _ [] = Nothing

filter :: (a -> Bool) -> [a] -> [a]
filter p (x:xs) = if p x then x : filter p xs else filter p xs
filter _ []     = []

not :: Bool -> Bool
not p = if p then False else True

null :: [t] -> Bool
null [] = True
null _ = False

map :: (a -> b) -> [a] -> [b]
map _ []     = []
map f (x:xs) = f x : map f xs

nub :: Eq a => [a] -> [a]
nub ls = nub' ls []

nub' :: Eq a => [a] -> [a] -> [a]
nub' []     _ = []
nub' (x:xs) ls =
  if elem x ls
     then nub' xs ls
     else x : nub' xs (x : ls)

elem :: Eq a => a -> [a] -> Bool
elem x (y:ys)   = x == y || elem x ys
elem _ []       = False

notElem :: Eq a => a -> [a] -> Bool
notElem x ys = not (elem x ys)

data Ordering = GT | LT | EQ

sort :: Ord a => [a] -> [a]
sort = sortBy compare

compare :: Ord a => a -> a -> Ordering
compare x y =
  if x > y
     then GT
     else if x < y
             then LT
             else EQ


sortBy :: (t -> t -> Ordering) -> [t] -> [t]
sortBy cmp = foldr (insertBy cmp) []

insertBy :: (a -> a -> Ordering) -> a -> [a] -> [a]
insertBy _   x [] = [x]
insertBy cmp x ys =
  case ys of
    [] -> [x]
    y:ys' ->
      case cmp x y of
         GT -> y : insertBy cmp x ys'
         _  -> x : ys

when :: Monad m => Bool -> m a -> m ()
when p m = if p then m >> return () else return ()

succ :: Num a => a -> a
succ x = x + 1

pred :: Num a => a -> a
pred x = x - 1

enumFrom :: Num a => a -> [a]
enumFrom i = i : enumFrom (i + 1)

enumFromTo :: (Ord t, Num t) => t -> t -> [t]
enumFromTo i n =
  if i > n then [] else i : enumFromTo (i + 1) n

enumFromBy :: (Num t) => t -> t -> [t]
enumFromBy fr by = fr : enumFromBy (fr + by) by

enumFromThen :: (Num t) => t -> t -> [t]
enumFromThen fr th = enumFromBy fr (th - fr)

enumFromByTo :: (Ord t, Num t) => t -> t -> t -> [t]
enumFromByTo fr by to = if by < 0 then neg fr else pos fr
  where neg x = if x < to then [] else x : neg (x + by)
        pos x = if x > to then [] else x : pos (x + by)

enumFromThenTo :: (Ord t, Num t) => t -> t -> t -> [t]
enumFromThenTo fr th to = enumFromByTo fr (th - fr) to

zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]
zipWith f (a:as) (b:bs) = f a b : zipWith f as bs
zipWith _ _      _      = []

zipWith3 :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 f (a:as) (b:bs) (c:cs) = f a b c : zipWith3 f as bs cs
zipWith3 _ _      _      _      = []

zip :: [a] -> [b] -> [(a,b)]
zip (a:as) (b:bs) = (a,b) : zip as bs
zip _      _      = []

zip3 :: [a] -> [b] -> [c] -> [(a, b, c)]
zip3 (a:as) (b:bs) (c:cs) = (a,b,c) : zip3 as bs cs
zip3 _      _      _      = []

unzip :: [(a, b)] -> ([a], [b])
unzip ((x,y):ps) = case unzip ps of (xs,ys) -> (x:xs, y:ys)
unzip []         = ([], [])

unzip3 :: [(a, b, c)] -> ([a], [b], [c])
unzip3 ((x,y,z):ps) = case unzip3 ps of (xs,ys,zs) -> (x:xs, y:ys, z:zs)
unzip3 []           = ([], [], [])

lines :: String -> [String]
lines []   = []
lines s    = case break isLineBreak s of (a, [])   -> [a]
                                         (a, _:cs) -> a : lines cs
  where isLineBreak c = c == '\r' || c == '\n'

unlines :: [String] -> String
unlines = intercalate "\n"

words :: String -> [String]
words str = words' (dropWhile isSpace str)
  where words' []  = []
        words' s = case break isSpace s of (a,b) -> a : words b
        isSpace c  = c `elem` " \t\r\n\f\v"

unwords :: [String] -> String
unwords = intercalate " "

flip :: (t1 -> t2 -> t) -> t2 -> t1 -> t
flip f x y = f y x

maybe :: t -> (t1 -> t) -> Maybe t1 -> t
maybe m _ Nothing = m
maybe _ f (Just x) = f x

(.) :: (t1 -> t) -> (t2 -> t1) -> t2 -> t
(f . g) x = f (g x)
infixr 9 .

(++) :: [a] -> [a] -> [a]
x ++ y = conc x y
infixr 5 ++

($) :: (t1 -> t) -> t1 -> t
f $ x = f x
infixr 0 $

-- | Append two lists.
conc :: [a] -> [a] -> [a]
conc (x:xs) ys = x : conc xs ys
conc []     ys = ys

concat :: [[a]] -> [a]
concat = foldr conc []

concatMap :: (a -> [b]) -> [a] -> [b]
concatMap f = foldr ((++) . f) []

foldr :: (t -> t1 -> t1) -> t1 -> [t] -> t1
foldr _ z []     = z
foldr f z (x:xs) = f x (foldr f z xs)

foldr1 :: (a -> a -> a) -> [a] -> a
foldr1 _ [x]    = x
foldr1 f (x:xs) = f x (foldr1 f xs)
foldr1 _ []     = error "foldr1: empty list"

foldl :: (t1 -> t -> t1) -> t1 -> [t] -> t1
foldl _ z []     = z
foldl f z (x:xs) = foldl f (f z x) xs

foldl1 :: (a -> a -> a) -> [a] -> a
foldl1 f (x:xs) = foldl f x xs
foldl1 _ []     = error "foldl1: empty list"

and :: [Bool] -> Bool
and []     = True
and (x:xs) = x && and xs

or :: [Bool] -> Bool
or []     = False
or (x:xs) = x || or xs

any :: (a -> Bool) -> [a] -> Bool
any _ []     = False
any p (x:xs) = p x || any p xs

all :: (a -> Bool) -> [a] -> Bool
all _ []     = True
all p (x:xs) = p x && all p xs

maximum :: (Num a, Foreign a) => [a] -> a
maximum [] = error "maximum: empty list"
maximum xs = foldl1 max xs

minimum :: (Num a, Foreign a) => [a] -> a
minimum [] = error "minimum: empty list"
minimum xs = foldl1 min xs

product :: Num a => [a] -> a
product [] = error "product: empty list"
product xs = foldl (*) 1 xs

sum :: Num a => [a] -> a
sum [] = error "sum: empty list"
sum xs = foldl (+) 0 xs

scanl :: (a -> b -> a) -> a -> [b] -> [a]
scanl f z l = z : case l of [] -> []
                            (x:xs) -> scanl f (f z x) xs

scanl1 :: (a -> a -> a) -> [a] -> [a]
scanl1 _ [] = []
scanl1 f (x:xs) = scanl f x xs

scanr :: (a -> b -> b) -> b -> [a] -> [b]
scanr _ z [] = [z]
scanr f z (x:xs) = case scanr f z xs of (h:t) -> f x h : h : t
                                        _     -> undefined

scanr1 :: (a -> a -> a) -> [a] -> [a]
scanr1 _ []     = []
scanr1 _ [x]    = [x]
scanr1 f (x:xs) = case scanr1 f xs of (h:t) -> f x h : h : t
                                      _     -> undefined

lookup :: Eq a1 => a1 -> [(a1, a)] -> Maybe a
lookup _key []          =  Nothing
lookup  key ((x,y):xys) =
  if key == x
     then Just y
     else lookup key xys

intersperse :: a -> [a] -> [a]
intersperse _   []      = []
intersperse sep (x:xs)  = x : prependToAll sep xs

prependToAll :: a -> [a] -> [a]
prependToAll _   []     = []
prependToAll sep (x:xs) = sep : x : prependToAll sep xs

intercalate :: [a] -> [[a]] -> [a]
intercalate xs xss = concat (intersperse xs xss)

forM_ :: Monad m => [t] -> (t -> m a) -> m ()
forM_ (x:xs) m = m x >> forM_ xs m
forM_ []     _ = return ()

mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
mapM_ m (x:xs) = m x >> mapM_ m xs
mapM_ _ []     = return ()

const :: a -> b -> a
const a _ = a

length :: [a] -> Int
length xs = length' 0 xs

length' :: Int -> [a] -> Int
length' acc (_:xs) = length' (acc+1) xs
length' acc _ = acc

rem :: Int -> Int -> Int
rem x y = if y == 0 then error "Division by zero" else rem' x y
infixl 7 `rem`

rem' :: Int -> Int -> Int
rem' = ffi "%1 %% %2"

quot :: Int -> Int -> Int
quot x y = if y == 0 then error "Division by zero" else quot' x y
infixl 7 `quot`

quot' :: Int -> Int -> Int
quot' = ffi "~~(%1/%2)"

quotRem :: Int -> Int -> (Int, Int)
quotRem x y = (quot x y, rem x y)

div :: Int -> Int -> Int
div x y
  | x > 0 && y < 0 = quot (x-1) y - 1
  | x < 0 && y > 0 = quot (x+1) y - 1
div x y            = quot x y
infixl 7 `div`

mod :: Int -> Int -> Int
mod x y
  | x > 0 && y < 0 = rem (x-1) y + y + 1
  | x < 0 && y > 0 = rem (x+1) y + y - 1
mod x y            = rem x y
infixl 7 `mod`

divMod :: Int -> Int -> (Int, Int)
divMod x y
  | x > 0 && y < 0 = case (x-1) `quotRem` y of (q,r) -> (q-1, r+y+1)
  | x < 0 && y > 1 = case (x+1) `quotRem` y of (q,r) -> (q-1, r+y-1)
divMod x y         = quotRem x y

min :: (Num a, Foreign a) => a -> a -> a
min = ffi "Math.min(%1,%2)"

max :: (Num a, Foreign a) => a -> a -> a
max = ffi "Math.max(%1,%2)"

recip :: Double -> Double
recip x = 1 / x

fromIntegral :: Int -> Double
fromIntegral = ffi "%1"

otherwise :: Bool
otherwise = True

reverse :: [a] -> [a]
reverse (x:xs) = reverse xs ++ [x]
reverse [] = []

(=<<) :: Monad m => (a -> m b) -> m a -> m b
f =<< x = x >>= f
infixl 1 =<<

-- | Evaluate each action in the sequence from left to right,
-- and collect the results.
-- sequence :: [Fay a] -> Fay [a]
sequence :: (Monad m) => [m a] -> m [a]
sequence ms = foldr k (return []) ms
            where
              k m m' = do { x <- m; xs <- m'; return (x:xs) }

sequence_ :: Monad m => [m a] -> m ()
sequence_ []     = return ()
sequence_ (m:ms) = m >> sequence_ ms

id :: a -> a
id x = x

asTypeOf :: a -> a -> a
asTypeOf = const

until :: (a -> Bool) -> (a -> a) -> a -> a
until p f x = if p x then x else until p f (f x)

($!) :: (a -> b) -> a -> b
f $! x = x `seq` f x
infixr 0 $!

(!!) :: [a] -> Int -> a
a !! b = if b < 0 then error "(!!): negative index" else go a b
  where go []    _ = error "(!!): index too large"
        go (h:_) 0 = h
        go (_:t) n = go t (n-1)
infixl 9 !!

head :: [a] -> a
head []    = error "head: empty list"
head (h:_) = h

tail :: [a] -> [a]
tail []    = error "tail: empty list"
tail (_:t) = t

init :: [a] -> [a]
init []    = error "init: empty list"
init [a]   = [a]
init (h:t) = h : init t

last :: [a] -> a
last []    = error "last: empty list"
last [a]   = a
last (_:t) = last t

iterate :: (a -> a) -> a -> [a]
iterate f x = x : iterate f (f x)

repeat :: a -> [a]
repeat x = x : repeat x

replicate :: Int -> a -> [a]
replicate 0 _ = []
replicate n x = if n < 0 then error "replicate: negative length"
                         else x : replicate (n-1) x

cycle :: [a] -> [a]
cycle [] = error "cycle: empty list"
cycle xs = xs' where xs' = xs ++ xs'

take :: Int -> [a] -> [a]
take 0 _  = []
take _ [] = []
take n (x:xs) = if n < 0 then error "take: negative length"
                         else x : take (n-1) xs

drop :: Int -> [a] -> [a]
drop 0 xs = xs
drop _ [] = []
drop n (_:xs) = if n < 0 then error "drop: negative length"
                         else drop (n-1) xs

splitAt :: Int -> [a] -> ([a], [a])
splitAt 0 xs     = ([], xs)
splitAt _ []     = ([], [])
splitAt n (x:xs) = if n < 0 then error "splitAt: negative length"
                            else case splitAt (n-1) xs of (a,b) -> (x:a, b)

takeWhile :: (a -> Bool) -> [a] -> [a]
takeWhile _ []     = []
takeWhile p (x:xs) = if p x then x : takeWhile p xs else []

dropWhile :: (a -> Bool) -> [a] -> [a]
dropWhile _ []     = []
dropWhile p (x:xs) = if p x then dropWhile p xs else x:xs

span :: (a -> Bool) -> [a] -> ([a], [a])
span _ []     = ([], [])
span p (x:xs) = if p x then case span p xs of (a,b) -> (x:a, b) else ([], x:xs)

break :: (a -> Bool) -> [a] -> ([a], [a])
break p = span (not . p)

print :: (Foreign a) => a -> Fay ()
print = ffi "(function(x) { if (console && console.log) console.log(x) })(%1)"

putStrLn :: String -> Fay ()
putStrLn = ffi "(function(x) { if (console && console.log) console.log(x) })(%1)"