{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
-- | bs primitives
--
-- I would like to reduce the number of primitives in the language to some
-- minimal number, like SKI combinator or Nock instructions. I'm not sure what
-- the minimal number is. The idea is to move primitives from here into core.scm
-- over time.
module Language.Bs.Primitives where

import Control.Exception
import Control.Monad.Except
import Data.Text as T
import Data.Text.IO as TIO
import Language.Bs.Expr
import Network.HTTP
import Protolude
import System.Directory
import System.IO

type Prim   = [(T.Text, Expr)]
type Unary  = Expr -> Eval Expr
type Binary = Expr -> Expr -> Eval Expr

mkF :: ([Expr] -> Eval Expr) -> Expr
mkF = IFun . IFunc

primEnv :: Prim
primEnv = [
    ("+"            , mkF $ binopFold (numOp    (+))  (Numb 0) )
  , ("*"            , mkF $ binopFold (numOp    (*))  (Numb 1) )
  , ("string-append", mkF $ binopFold (strOp    (<>)) (Tape "") )
  , ("-"            , mkF $ binop $    numOp    (-))
  , ("<"            , mkF $ binop $    numCmp   (<))
  , ("<="           , mkF $ binop $    numCmp   (<=))
  , (">"            , mkF $ binop $    numCmp   (>))
  , (">="           , mkF $ binop $    numCmp   (>=))
  , ("=="           , mkF $ binop $    numCmp   (==))
  , ("even?"        , mkF $ unop $     numBool   even)
  , ("odd?"         , mkF $ unop $     numBool   odd)
  , ("neg?"         , mkF $ unop $     numBool (< 0))
  , ("pos?"         , mkF $ unop $     numBool (> 0))
  , ("eq?"          , mkF $ binop eqCmd )
  , ("null?"        , mkF $ unop (eqCmd Nil) )
  , ("bl-eq?"       , mkF $ binop $ eqOp (==))
  , ("and"          , mkF $ binopFold (eqOp (&&)) (Bool True))
  , ("or"           , mkF $ binopFold (eqOp (||)) (Bool False))
  , ("not"          , mkF $ unop $ notOp)
  , ("cons"         , mkF $ Language.Bs.Primitives.cons)
  , ("cdr"          , mkF $ Language.Bs.Primitives.cdr)
  , ("car"          , mkF $ Language.Bs.Primitives.car)
  , ("quote"        , mkF $ quote)
  , ("file?"        , mkF $ unop fileExists)
  , ("slurp"        , mkF $ unop slurp)
  , ("wslurp"       , mkF $ unop wSlurp)
  , ("put"          , mkF $ binop put_)
  ]

unop :: Unary -> [Expr] -> Eval Expr
unop op [x]    = op x
unop _ args    = throw $ NumArgs 1 args

binop :: Binary -> [Expr] -> Eval Expr
binop op [x,y]  = op x y
binop _  args   = throw $ NumArgs 2 args

fileExists :: Expr  -> Eval Expr
fileExists (Tape txt) = Bool <$> liftIO (doesFileExist $ T.unpack txt)
fileExists val          = throw $ TypeMismatch "read expects string, instead got: " val

slurp :: Expr  -> Eval Expr
slurp (Tape txt) = liftIO $ wFileSlurp txt
slurp val          =  throw $ TypeMismatch "read expects string, instead got: " val

wFileSlurp :: T.Text -> IO Expr
wFileSlurp fileName = withFile (T.unpack fileName) ReadMode go
  where go = readTextFile fileName

openURL :: T.Text -> IO Expr
openURL x = do
  req  <- simpleHTTP (getRequest $ T.unpack x)
  body <- getResponseBody req
  return $ Tape $ T.pack body

wSlurp :: Expr -> Eval Expr
wSlurp (Tape txt) =  liftIO  $  openURL txt
wSlurp val = throw $ TypeMismatch "wSlurp expects a string, instead got: " val

readTextFile :: T.Text -> Handle -> IO Expr
readTextFile fileName h = do
  exists <- doesFileExist $ T.unpack fileName
  if exists
  then (TIO.hGetContents h) >>= (return . Tape)
  else throw $ ReadFileError $ T.concat [" file does not exist: ", fileName]

put_ :: Expr -> Expr -> Eval Expr
put_ (Tape file) (Tape msg) =  liftIO $ wFilePut file msg
put_ (Tape _)  val = throw $ TypeMismatch "put expects string in the second argument (try using show), instead got: " val
put_ val  _ = throw $ TypeMismatch "put expects string, instead got: " val

wFilePut :: T.Text -> T.Text -> IO Expr
wFilePut fileName msg = withFile (T.unpack fileName) WriteMode go
  where go = putTextFile fileName msg

putTextFile :: T.Text -> T.Text -> Handle -> IO Expr
putTextFile fileName msg h = do
  canWrite <- hIsWritable h
  if canWrite
  then (TIO.hPutStr h msg) >> (return $ Tape msg)
  else throw $ ReadFileError $ T.concat [" file does not exist: ", fileName]

binopFold :: Binary -> Expr -> [Expr] -> Eval Expr
binopFold op farg args = case args of
    []-> throw $ NumArgs 2 args
    [a,b]  -> op a b
    _ -> foldM op farg args

numBool :: (Integer -> Bool) -> Expr -> Eval Expr
numBool op (Numb x) = return $ Bool $ op x
numBool _   x       = throw $ TypeMismatch "numeric op " x

numOp :: (Integer -> Integer -> Integer) -> Expr -> Expr -> Eval Expr
numOp op (Numb x) (Numb y) = return $ Numb $ op x  y
numOp _  Nil      (Numb y) = return $ Numb y
numOp _  (Numb x) Nil      = return $ Numb x
numOp _  x        (Numb _) = throw $ TypeMismatch "numeric op" x
numOp _  (Numb _)  y       = throw $ TypeMismatch "numeric op" y
numOp _  x         _       = throw $ TypeMismatch "numeric op" x

strOp :: (T.Text -> T.Text -> T.Text) -> Expr -> Expr -> Eval Expr
strOp op (Tape x) (Tape y) = return $ Tape $ op x y
strOp _  Nil      (Tape y) = return $ Tape y
strOp _  (Tape x) Nil      = return $ Tape x
strOp _  x        (Tape _) = throw $ TypeMismatch "string op" x
strOp _  (Tape _) y        = throw $ TypeMismatch "string op" y
strOp _  x        _        = throw $ TypeMismatch "string op" x

eqOp :: (Bool -> Bool -> Bool) -> Expr -> Expr -> Eval Expr
eqOp op (Bool x) (Bool y) = return $ Bool $ op x y
eqOp _  x        (Bool _) = throw $ TypeMismatch "bool op" x
eqOp _  (Bool _)  y       = throw $ TypeMismatch "bool op" y
eqOp _  x         _       = throw $ TypeMismatch "bool op" x

numCmp :: (Integer -> Integer -> Bool) -> Expr -> Expr -> Eval Expr
numCmp op (Numb x) (Numb y) = return . Bool $ op x  y
numCmp _  x        (Numb _) = throw $ TypeMismatch "numeric op" x
numCmp _  (Numb _) y        = throw $ TypeMismatch "numeric op" y
numCmp _  x        _        = throw $ TypeMismatch "numeric op" x

notOp :: Expr -> Eval Expr
notOp (Bool True) = return $ Bool False
notOp (Bool False) = return $ Bool True
notOp x = throw $ TypeMismatch " not expects Bool" x

eqCmd :: Expr -> Expr -> Eval Expr
eqCmd (Atom x) (Atom y) = return . Bool $ x == y
eqCmd (Numb x) (Numb y) = return . Bool $ x == y
eqCmd (Tape x) (Tape y) = return . Bool $ x == y
eqCmd (Bool x) (Bool y) = return . Bool $ x == y
eqCmd  Nil      Nil     = return $ Bool True
eqCmd  _        _       = return $ Bool False

cons :: [Expr] -> Eval Expr
cons [x,(List ys)] = return $ List $ x:ys
cons [x,y]         = return $ List [x,y]
cons _  = throw $ ExpectedList "cons, in second argument"

car :: [Expr] -> Eval Expr
car [List []    ] = return Nil
car [List (x:_)]  = return x
car []            = return Nil
car _             = throw $ ExpectedList "car"

cdr :: [Expr] -> Eval Expr
cdr [List (_:xs)] = return $ List xs
cdr [List []]     = return Nil
cdr []            = return Nil
cdr _             = throw $ ExpectedList "cdr"

quote :: [Expr] -> Eval Expr
quote [List xs]   = return $ List $ Atom "quote" : xs
quote [expr]      = return $ List $ Atom "quote" : [expr]
quote args        = throw $ NumArgs 1 args