TestsInit.hs

-- |
-- Module      :  Emacs.TestsInit
-- Copyright   :  (c) Sergey Vinokurov 2018
-- License     :  Apache-2.0 (see LICENSE)
-- Maintainer  :  serg.foo@gmail.com
----------------------------------------------------------------------------

{-# LANGUAGE CPP                      #-}
{-# LANGUAGE DataKinds                #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE GADTs                    #-}
{-# LANGUAGE OverloadedStrings        #-}
{-# LANGUAGE TypeFamilies             #-}

module Emacs.TestsInit () where

import Data.ByteString.Char8 qualified as C8
import Data.Functor
import Data.Maybe
import Foreign hiding (void)
import Foreign.C

import Data.Emacs.Module.Args
import Data.Emacs.Module.Runtime (Runtime)
import Data.Emacs.Module.Runtime qualified as Runtime
import Data.Emacs.Module.SymbolName.Predefined qualified as Sym
import Emacs.Module
import Emacs.Module.Assert
import Emacs.Module.Monad

foreign export ccall initialise :: Ptr Runtime -> IO CBool

true, false :: CBool
true  = CBool 1
false = CBool 0

initialise :: WithCallStack => Ptr Runtime -> IO CBool
initialise runtime = do
  runtime' <- Runtime.validateRuntime runtime
  case runtime' of
    Nothing        -> pure false
    Just runtime'' ->
      Runtime.withEnvironment runtime'' $ \env -> do
        res <- reportAllErrorsToEmacs env (pure False) $ runEmacsM env initialise'
        pure $ if res then true else false

initialise'
  :: (WithCallStack, MonadEmacs m v)
  => m s Bool
initialise' = do
  bindFunction "haskell-emacs-module-tests-apply2" =<<
    makeFunction apply2 "Apply a function twice."
  bindFunction "haskell-emacs-module-tests-apply2-alt" =<<
    makeFunction apply2Alt "Apply a function twice."
  bindFunction "haskell-emacs-module-tests-add" =<<
    makeFunction add "Add two numbers."
  bindFunction "haskell-emacs-module-tests-get-rest" =<<
    makeFunction getRest "Just return the &rest argument."
  bindFunction "haskell-emacs-module-tests-append-lots-of-strings" =<<
    makeFunction appendLotsOfStrings "Append foo string N times to itself."
  bindFunction "haskell-emacs-module-tests-append-lots-of-vectors" =<<
    makeFunction appendLotsOfVectors "Append [1 2 3] vector N times to itself."
  bindFunction "haskell-emacs-module-tests-replicate" =<<
    makeFunction emacsReplicate "Replicate an item N times"
  bindFunction "haskell-emacs-module-tests-grow-list" =<<
    makeFunction emacsGrowList "Append list with itself"
  bindFunction "haskell-emacs-module-tests-incorrect-vector-assignment" =<<
    makeFunction emacsIncorrectVectorAssignment "vecSet that should result in error"
  pure True

apply2
  :: (WithCallStack, MonadEmacs m v)
  => EmacsFunction ('S ('S 'Z)) 'Z 'False m v s
apply2 (R f (R x Stop)) = do
  y <- funcall f [x]
  funcall f [y]

apply2Alt
  :: (WithCallStack, MonadEmacs m v)
  => EmacsFunction ('S ('S 'Z)) 'Z 'False m v s
apply2Alt (R f (R x Stop)) = do
  funcallSym <- intern Sym.funcall
  y          <- funcall funcallSym [f, x]
  res        <- funcall funcallSym [f, y]
  pure res

add
  :: (WithCallStack, MonadEmacs m v)
  => EmacsFunction ('S ('S 'Z)) 'Z 'False m v s
add (R x (R y Stop)) =
  makeInt =<< (+) <$> extractInt x <*> extractInt y

getRest
  :: (WithCallStack, MonadEmacs m v)
  => EmacsFunction ('S 'Z) 'Z 'True m v s
getRest (R _req (Rest rest)) = do
  vectorSym <- intern Sym.vector
  funcall vectorSym rest

appendLotsOfStrings
  :: forall m v s. (WithCallStack, MonadEmacs m v)
  => EmacsFunction ('S 'Z) 'Z 'False m v s
appendLotsOfStrings (R n Stop) = do
  n'     <- extractInt n
  -- foo'   <- makeString "foo"
  empty' <- makeString ""
  let input :: [(m s (v s), C8.ByteString)]
      input = replicate n' (makeString "foo", "foo")
      res = appendTree concat2' input
  res' <- traverse fst res
  pure $ fromMaybe empty' res'

appendLotsOfVectors
  :: (WithCallStack, MonadEmacs m v)
  => EmacsFunction ('S 'Z) 'Z 'False m v s
appendLotsOfVectors (R n Stop) = do
  n'     <- extractInt n
  one    <- makeInt 1
  two    <- makeInt 2
  three  <- makeInt 3

  empty' <- makeVector []

  let input = replicate n' (makeVector [one, two, three], [1, 2, 3])
      res   = appendTree vconcat2' input
  res' <- traverse fst res
  pure $ fromMaybe empty' res'

emacsReplicate
  :: (WithCallStack, MonadEmacs m v)
  => EmacsFunction ('S ('S 'Z)) 'Z 'False m v s
emacsReplicate (R n (R x Stop)) = do
  n' <- extractInt n
  makeList (replicate n' x)

emacsGrowList
  :: (WithCallStack, MonadEmacs m v)
  => EmacsFunction ('S 'Z) 'Z 'False m v s
emacsGrowList (R xs Stop) = do
  ys <- extractList xs
  makeList $ ys ++ ys ++ ys

emacsIncorrectVectorAssignment
  :: (WithCallStack, MonadEmacs m v)
  => EmacsFunction 'Z 'Z 'False m v s
emacsIncorrectVectorAssignment Stop = do
  n   <- makeInt 36
  vec <- makeVector $ replicate 42 n
  vecSet vec 42 n
  nil

concat2'
  :: (WithCallStack, MonadEmacs m v)
  => (m s (v s), C8.ByteString)
  -> (m s (v s), C8.ByteString)
  -> (m s (v s), C8.ByteString)
concat2' (x, xStr) (y, yStr) =
  (go, xStr <> yStr)
  where
    go = do
      x'    <- x
      y'    <- y
      gcSym <- intern "garbage-collect"
      void $ funcallPrimitiveUnchecked gcSym []
      concat2 x' y'

vconcat2'
  :: (WithCallStack, MonadEmacs m v)
  => (m s (v s), [Int])
  -> (m s (v s), [Int])
  -> (m s (v s), [Int])
vconcat2' (x, xs) (y, ys) =
  (go, xs <> ys)
  where
    go = do
      x'    <- x
      y'    <- y
      gcSym <- intern "garbage-collect"
      void $ funcallPrimitiveUnchecked gcSym []
      vconcat2 x' y'

appendTree :: (a -> a -> a) -> [a] -> Maybe a
appendTree f = reduce
  where
    go []             = []
    go xs@[_]         = xs
    go (x1 : x2 : xs) = f x1 x2 : go xs

    reduce []  = Nothing
    reduce [x] = Just x
    reduce xs  = reduce (go xs)