Types.hs

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

This module implements primitive functions that dynamically checks the types of
objects.
-}

module Language.Egison.Primitives.Types
  ( primitiveTypeFunctions
  ) where

import           Control.Monad.Except

import           Data.Char                        (chr, ord)
import           Data.Ratio                       ((%))

import           Language.Egison.Data
import           Language.Egison.EvalState        (MonadEval(..))
import           Language.Egison.Math
import           Language.Egison.Primitives.Utils

primitiveTypeFunctions :: [(String, EgisonValue)]
primitiveTypeFunctions =
  map (\(name, fn) -> (name, PrimitiveFunc (fn name))) strictPrimitives ++
    map (\(name, fn) -> (name, LazyPrimitiveFunc (fn name))) lazyPrimitives

strictPrimitives :: [(String, String -> PrimitiveFunc)]
strictPrimitives =
  [ ("itof", integerToFloat)
  , ("rtof", rationalToFloat)
  , ("ctoi", charToInteger)
  , ("itoc", integerToChar)
  ]

lazyPrimitives :: [(String, String -> LazyPrimitiveFunc)]
lazyPrimitives =
  [ ("isBool",       lazyOneArg isBool)
  , ("isInteger",    lazyOneArg isInteger)
  , ("isRational",   lazyOneArg isRational)
  , ("isScalar",     lazyOneArg isScalar)
  , ("isFloat",      lazyOneArg isFloat)
  , ("isChar",       lazyOneArg isChar)
  , ("isString",     lazyOneArg isString)
  , ("isCollection", lazyOneArg isCollection)
  , ("isHash",       lazyOneArg isHash)
  , ("isTensor",     lazyOneArg isTensor)
  ]

--
-- Typing
--

isBool :: WHNFData -> EvalM WHNFData
isBool (Value (Bool _)) = return . Value $ Bool True
isBool _                = return . Value $ Bool False

isInteger :: WHNFData -> EvalM WHNFData
isInteger (Value (ScalarData (Div (Plus []) (Plus [Term 1 []]))))          = return . Value $ Bool True
isInteger (Value (ScalarData (Div (Plus [Term _ []]) (Plus [Term 1 []])))) = return . Value $ Bool True
isInteger _                                                                = return . Value $ Bool False

isRational :: WHNFData -> EvalM WHNFData
isRational (Value (ScalarData (Div (Plus []) (Plus [Term _ []]))))          = return . Value $ Bool True
isRational (Value (ScalarData (Div (Plus [Term _ []]) (Plus [Term _ []])))) = return . Value $ Bool True
isRational _                                                                = return . Value $ Bool False

isScalar :: WHNFData -> EvalM WHNFData
isScalar (Value (ScalarData _)) = return . Value $ Bool True
isScalar _                      = return . Value $ Bool False

isTensor :: WHNFData -> EvalM WHNFData
isTensor (Value (TensorData _)) = return . Value $ Bool True
isTensor (ITensor _)            = return . Value $ Bool True
isTensor _                      = return . Value $ Bool False

isFloat :: WHNFData -> EvalM WHNFData
isFloat (Value (Float _)) = return . Value $ Bool True
isFloat _                 = return . Value $ Bool False

isChar :: WHNFData -> EvalM WHNFData
isChar (Value (Char _)) = return . Value $ Bool True
isChar _                = return . Value $ Bool False

isString :: WHNFData -> EvalM WHNFData
isString (Value (String _)) = return . Value $ Bool True
isString _                  = return . Value $ Bool False

isCollection :: WHNFData -> EvalM WHNFData
isCollection (Value (Collection _)) = return . Value $ Bool True
isCollection (ICollection _)        = return . Value $ Bool True
isCollection _                      = return . Value $ Bool False

isHash :: WHNFData -> EvalM WHNFData
isHash (Value (IntHash _))  = return . Value $ Bool True
isHash (Value (CharHash _)) = return . Value $ Bool True
isHash (Value (StrHash _))  = return . Value $ Bool True
isHash (IIntHash _)         = return . Value $ Bool True
isHash (ICharHash _)        = return . Value $ Bool True
isHash (IStrHash _)         = return . Value $ Bool True
isHash _                    = return . Value $ Bool False

--
-- Transform
--
integerToFloat :: String -> PrimitiveFunc
integerToFloat = rationalToFloat

rationalToFloat :: String -> PrimitiveFunc
rationalToFloat = oneArg $ \val ->
  case val of
    ScalarData (Div (Plus []) _) -> return $ Float 0
    ScalarData (Div (Plus [Term x []]) (Plus [Term y []])) -> return $ Float (fromRational (x % y))
    _ -> throwError =<< TypeMismatch "integer or rational number" (Value val) <$> getFuncNameStack

charToInteger :: String -> PrimitiveFunc
charToInteger = unaryOp ctoi
  where
    ctoi :: Char -> Integer
    ctoi = fromIntegral . ord

integerToChar :: String -> PrimitiveFunc
integerToChar = unaryOp itoc
  where
    itoc :: Integer -> Char
    itoc = chr . fromIntegral