String.hs

{- |
Module      : Language.Egison.Primitives.String
Licence     : MIT

This module implements primitive functions that operates on / returns strings.
-}

module Language.Egison.Primitives.String
  ( primitiveStringFunctions
  ) where

import           Control.Monad.Except

import qualified Data.Sequence                    as Sq
import qualified Data.Text                        as T

import           Text.Regex.TDFA                  ((=~~))

import           Language.Egison.Data
import           Language.Egison.Eval
import           Language.Egison.Parser
import           Language.Egison.Pretty
import           Language.Egison.Primitives.Utils


primitiveStringFunctions :: [(String, EgisonValue)]
primitiveStringFunctions =
  map (\(name, fn) -> (name, PrimitiveFunc (fn name))) strictPrimitives

strictPrimitives :: [(String, String -> PrimitiveFunc)]
strictPrimitives =
  [ ("pack", pack)
  , ("unpack", unpack)
  , ("unconsString", unconsString)
  , ("lengthString", lengthString)
  , ("appendString", appendString)
  , ("splitString", splitString)
  , ("regex", regexString)
  , ("regexCg", regexStringCaptureGroup)

  , ("read", read')
  , ("readTsv", readTSV)
  , ("show", show')
  , ("showTsv", showTSV')
  ]

pack :: String -> PrimitiveFunc
pack = unaryOp T.pack

unpack :: String -> PrimitiveFunc
unpack = unaryOp T.unpack

unconsString :: String -> PrimitiveFunc
unconsString = oneArg $ \val -> do
  str <- fromEgison val
  case T.uncons str of
    Just (c, rest) -> return $ Tuple [Char c, String rest]
    Nothing -> throwError $ Default "Tried to unsnoc empty string"

lengthString :: String -> PrimitiveFunc
lengthString = unaryOp (toInteger . T.length)

appendString :: String -> PrimitiveFunc
appendString = binaryOp T.append

splitString :: String -> PrimitiveFunc
splitString = twoArgs $ \pat src -> do
  patStr <- fromEgison pat
  srcStr <- fromEgison src
  return . Collection . Sq.fromList $ map String $ T.splitOn patStr srcStr

regexString :: String -> PrimitiveFunc
regexString = twoArgs $ \pat src -> do
  patStr <- fromEgison pat
  srcStr <- fromEgison src
  case (T.unpack srcStr =~~ T.unpack patStr) :: (Maybe (String, String, String)) of
    Nothing -> return . Collection . Sq.fromList $ []
    Just (a,b,c) -> return . Collection . Sq.fromList $ [Tuple [String (T.pack a), String (T.pack b), String (T.pack c)]]

regexStringCaptureGroup :: String -> PrimitiveFunc
regexStringCaptureGroup = twoArgs $ \pat src -> do
  patStr <- fromEgison pat
  srcStr <- fromEgison src
  case (T.unpack srcStr =~~ T.unpack patStr) :: (Maybe [[String]]) of
    Nothing -> return . Collection . Sq.fromList $ []
    Just ((x:xs):_) -> do let (a, c) = T.breakOn (T.pack x) srcStr
                          return . Collection . Sq.fromList $ [Tuple [String a, Collection (Sq.fromList (map (String . T.pack) xs)), String (T.drop (length x) c)]]

--
-- Read / Show
--

read' :: String -> PrimitiveFunc
read'= oneArg' $ \val -> do
  str <- fromEgison val
  ast <- readExpr (T.unpack str)
  evalExpr nullEnv ast

readTSV :: String -> PrimitiveFunc
readTSV = oneArg' $ \val -> do
  str   <- fromEgison val
  exprs <- mapM (readExpr . T.unpack) (T.split (== '\t') str)
  rets  <- mapM (evalExpr nullEnv) exprs
  case rets of
    [ret] -> return ret
    _     -> return (Tuple rets)

show' :: String -> PrimitiveFunc
show'= oneArg' $ \val -> return $ toEgison $ T.pack $ show val

showTSV' :: String -> PrimitiveFunc
showTSV'= oneArg' $ \val -> return $ toEgison $ T.pack $ showTSV val