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