Values.hs

{-# LANGUAGE OverloadedStrings #-}

module MOO.Builtins.Values ( builtins ) where

import Control.Applicative ((<$>), (<*>))
import Control.Monad (mplus, unless, liftM, (>=>))
import Data.ByteString (ByteString)
import Data.Char (isDigit)
import Data.Digest.Pure.MD5 (MD5Digest)
import Data.Maybe (fromJust)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Word (Word8)
import Text.Printf (printf)

import qualified Data.ByteString as BS
import qualified Data.Digest.Pure.MD5 as MD5
import qualified Data.Vector as V
import qualified Data.Text as T

import MOO.Builtins.Common
import MOO.Builtins.Crypt
import MOO.Builtins.Match
import MOO.Parser (parseNum, parseObj)
import MOO.Task
import MOO.Types

import qualified MOO.String as Str

{-# ANN module ("HLint: ignore Use camelCase" :: String) #-}

-- | § 4.4.2 Manipulating MOO Values
builtins :: [Builtin]
builtins = [
    -- § 4.4.2.1 General Operations Applicable to all Values
    bf_typeof
  , bf_tostr
  , bf_toliteral
  , bf_toint
  , bf_tonum
  , bf_toobj
  , bf_tofloat
  , bf_equal
  , bf_value_bytes
  , bf_value_hash

    -- § 4.4.2.2 Operations on Numbers
  , bf_random
  , bf_min
  , bf_max
  , bf_abs
  , bf_floatstr
  , bf_sqrt
  , bf_sin
  , bf_cos
  , bf_tan
  , bf_asin
  , bf_acos
  , bf_atan
  , bf_sinh
  , bf_cosh
  , bf_tanh
  , bf_exp
  , bf_log
  , bf_log10
  , bf_ceil
  , bf_floor
  , bf_trunc

    -- § 4.4.2.3 Operations on Strings
  , bf_length
  , bf_strsub
  , bf_index
  , bf_rindex
  , bf_strcmp
  , bf_decode_binary
  , bf_encode_binary
  , bf_match
  , bf_rmatch
  , bf_substitute
  , bf_crypt
  , bf_string_hash
  , bf_binary_hash

    -- § 4.4.2.4 Operations on Lists
  , bf_is_member
  , bf_listinsert
  , bf_listappend
  , bf_listdelete
  , bf_listset
  , bf_setadd
  , bf_setremove
  ]

-- § 4.4.2.1 General Operations Applicable to all Values

bf_typeof = Builtin "typeof" 1 (Just 1) [TAny] TInt $ \[value] ->
  return $ Int $ typeCode $ typeOf value

bf_tostr = Builtin "tostr" 0 Nothing [] TStr $
           return . Str . Str.fromText . T.concat . map toText

bf_toliteral = Builtin "toliteral" 1 (Just 1) [TAny] TStr $ \[value] ->
  return $ Str $ Str.fromText $ toLiteral value

-- XXX toint(" - 34  ") does not parse as -34
bf_toint = Builtin "toint" 1 (Just 1) [TAny] TInt $ \[value] -> toint value
  where toint value = case value of
          Int _ -> return value
          Flt x | x >= 0    -> if x > fromIntegral (maxBound :: IntT)
                               then raise E_FLOAT else return (Int $ floor   x)
                | otherwise -> if x < fromIntegral (minBound :: IntT)
                               then raise E_FLOAT else return (Int $ ceiling x)
          Obj x -> return (Int $ fromIntegral x)
          Str x -> maybe (return $ Int 0) toint (parseNum $ Str.toText x)
          Err x -> return (Int $ fromIntegral $ fromEnum x)
          Lst _ -> raise E_TYPE

bf_tonum = bf_toint { builtinName = "tonum" }

bf_toobj = Builtin "toobj" 1 (Just 1) [TAny] TObj $ \[value] -> toobj value
  where toobj value = case value of
          Int x -> return (Obj $ fromIntegral x)
          Flt x | x >= 0    -> if x > fromIntegral (maxBound :: ObjT)
                               then raise E_FLOAT else return (Obj $ floor   x)
                | otherwise -> if x < fromIntegral (minBound :: ObjT)
                               then raise E_FLOAT else return (Obj $ ceiling x)
          Obj _ -> return value
          Str x -> maybe (return $ Obj 0) toobj $
                   parseNum (Str.toText x) `mplus` parseObj (Str.toText x)
          Err x -> return (Obj $ fromIntegral $ fromEnum x)
          Lst _ -> raise E_TYPE

bf_tofloat = Builtin "tofloat" 1 (Just 1)
             [TAny] TFlt $ \[value] -> tofloat value
  where tofloat value = case value of
          Int x -> return (Flt $ fromIntegral x)
          Flt _ -> return value
          Obj x -> return (Flt $ fromIntegral x)
          Str x -> maybe (return $ Flt 0) tofloat (parseNum $ Str.toText x)
          Err x -> return (Flt $ fromIntegral $ fromEnum x)
          Lst _ -> raise E_TYPE

bf_equal = Builtin "equal" 2 (Just 2) [TAny, TAny] TInt $ \[value1, value2] ->
  return $ truthValue (value1 `equal` value2)

bf_value_bytes = Builtin "value_bytes" 1 (Just 1) [TAny] TInt $ \[value] ->
  return $ Int $ fromIntegral $ storageBytes value

bf_value_hash = Builtin "value_hash" 1 (Just 1) [TAny] TStr $
                builtinFunction bf_toliteral >=>
                builtinFunction bf_string_hash . return

-- § 4.4.2.2 Operations on Numbers

bf_random = Builtin "random" 0 (Just 1) [TInt] TInt $ \optional ->
  let [Int mod] = defaults optional [Int maxBound]
  in if mod < 1 then raise E_INVARG
     else Int `liftM` random (1, mod)

bf_min = Builtin "min" 1 Nothing [TNum] TNum $ \args -> case args of
  Int x:xs -> minMaxInt min x xs
  Flt x:xs -> minMaxFlt min x xs

bf_max = Builtin "max" 1 Nothing [TNum] TNum $ \args -> case args of
  Int x:xs -> minMaxInt max x xs
  Flt x:xs -> minMaxFlt max x xs

minMaxInt :: (IntT -> IntT -> IntT) -> IntT -> [Value] -> MOO Value
minMaxInt f = go
  where go x (Int y:rs) = go (f x y) rs
        go x []         = return $ Int x
        go _ _          = raise E_TYPE

minMaxFlt :: (FltT -> FltT -> FltT) -> FltT -> [Value] -> MOO Value
minMaxFlt f = go
  where go x (Flt y:rs) = go (f x y) rs
        go x []         = return $ Flt x
        go _ _          = raise E_TYPE

bf_abs = Builtin "abs" 1 (Just 1) [TNum] TNum $ \[arg] -> case arg of
  Int x -> return $ Int $ abs x
  Flt x -> return $ Flt $ abs x

bf_floatstr = Builtin "floatstr" 2 (Just 3)
              [TFlt, TInt, TAny] TStr $ \(Flt x : Int precision : optional) ->
  let [scientific] = booleanDefaults optional [False]
      prec = min precision 19
      format = printf "%%.%d%c" prec $ if scientific then 'e' else 'f'
  in if precision < 0 then raise E_INVARG
     else return $ Str $ Str.fromString $ printf format x

floatBuiltin :: Id -> (FltT -> FltT) -> Builtin
floatBuiltin name f = Builtin name 1 (Just 1)
                      [TFlt] TFlt $ \[Flt x] -> checkFloat (f x)

bf_sqrt  = floatBuiltin "sqrt" sqrt

bf_sin   = floatBuiltin "sin"  sin
bf_cos   = floatBuiltin "cos"  cos
bf_tan   = floatBuiltin "tan"  tan

bf_asin  = floatBuiltin "asin" asin
bf_acos  = floatBuiltin "acos" acos
bf_atan  = Builtin "atan" 1 (Just 2) [TFlt, TFlt] TFlt $ \args ->
  checkFloat $ case args of
    [Flt y]        -> atan  y
    [Flt y, Flt x] -> atan2 y x

bf_sinh  = floatBuiltin "sinh" sinh
bf_cosh  = floatBuiltin "cosh" cosh
bf_tanh  = floatBuiltin "tanh" tanh

bf_exp   = floatBuiltin "exp"  exp
bf_log   = floatBuiltin "log"  log
bf_log10 = floatBuiltin "log10" (logBase 10)

bf_ceil  = floatBuiltin "ceil"  $ fromInteger . ceiling
bf_floor = floatBuiltin "floor" $ fromInteger . floor
bf_trunc = floatBuiltin "trunc" $ \x ->
  fromInteger $ if x < 0 then ceiling x else floor x

-- § 4.4.2.3 Operations on Strings

bf_length = Builtin "length" 1 (Just 1) [TAny] TInt $ \[arg] -> case arg of
  Str string -> return $ Int $ fromIntegral $ Str.length string
  Lst list   -> return $ Int $ fromIntegral $ V.length list
  _          -> raise E_TYPE

bf_strsub = Builtin "strsub" 3 (Just 4) [TStr, TStr, TStr, TAny]
            TStr $ \(Str subject : Str what : Str with : optional) ->
  let [case_matters] = booleanDefaults optional [False]
      caseFold str = if case_matters then str
                     else Str.fromText (Str.toCaseFold str)
                          -- XXX this won't work for Unicode in general
      subs ""      = []
      subs subject = case Str.breakOn (caseFold what) (caseFold subject) of
        (_, "")     -> [subject]
        (prefix, _) -> let (s, r) = Str.splitAt (Str.length prefix) subject
                       in s : with : subs (Str.drop whatLen r)
      whatLen = Str.length what
  in if Str.null what then raise E_INVARG
     else return $ Str $ Str.concat $ subs subject

indexBuiltin :: Id -> (StrT -> IntT) -> (StrT -> StrT -> IntT) -> Builtin
indexBuiltin name nullCase mainCase =
  Builtin name 2 (Just 3) [TStr, TStr, TAny]
  TInt $ \(Str str1 : Str str2 : optional) ->
  let [case_matters] = booleanDefaults optional [False]
      caseFold str = if case_matters then str
                     else Str.fromText (Str.toCaseFold str)
                          -- XXX this won't work for Unicode in general
  in return $ Int $ if Str.null str2 then nullCase str1
                    else mainCase (caseFold str2) (caseFold str1)

bf_index = indexBuiltin "index" nullCase mainCase
  where nullCase = const 1
        mainCase needle haystack = case Str.breakOn needle haystack of
          (_, "")     -> 0
          (prefix, _) -> fromIntegral $ 1 + Str.length prefix

bf_rindex = indexBuiltin "rindex" nullCase mainCase
  where nullCase haystack = fromIntegral $ Str.length haystack + 1
        mainCase needle haystack = case Str.breakOnEnd needle haystack of
          ("", _)     -> 0
          (prefix, _) -> fromIntegral $
                         1 + Str.length prefix - Str.length needle

bf_strcmp = Builtin "strcmp" 2 (Just 2)
            [TStr, TStr] TInt $ \[Str str1, Str str2] ->
  return $ Int $ case Str.toText str1 `compare` Str.toText str2 of
    LT -> -1
    EQ ->  0
    GT ->  1

bf_decode_binary = Builtin "decode_binary" 1 (Just 2)
                   [TStr, TAny] TLst $ \(Str bin_string : optional) ->
  let [fully] = booleanDefaults optional [False]
      mkResult | fully     = fromListBy (Int . fromIntegral)
               | otherwise = fromList . groupPrinting ("" ++)
  in (mkResult . BS.unpack) `liftM` binaryString bin_string

  where groupPrinting :: (String -> String) -> [Word8] -> [Value]
        groupPrinting g (w:ws)
          | Str.validChar c = groupPrinting (g [c] ++) ws
          | null group      = Int (fromIntegral w) : groupPrinting g ws
          | otherwise       = Str (Str.fromString group) :
                              Int (fromIntegral w) : groupPrinting ("" ++) ws
          where c = toEnum (fromIntegral w)
                group = g ""
        groupPrinting g []
          | null group = []
          | otherwise  = [Str $ Str.fromString group]
          where group = g ""

bf_encode_binary = Builtin "encode_binary" 0 Nothing [] TStr $
                   liftM (Str . Str.fromBinary) . encodeBinary

encodeBinary :: [Value] -> MOO ByteString
encodeBinary = maybe (raise E_INVARG) (return . BS.pack) . encode
  where encode :: [Value] -> Maybe [Word8]
        encode (Int n : rest)
          | n >= 0 && n <= 255 = (fromIntegral n :)           <$> encode rest
          | otherwise          = Nothing
        encode (Str s : rest)  = (++) <$> encodeStr s         <*> encode rest
        encode (Lst v : rest)  = (++) <$> encode (V.toList v) <*> encode rest
        encode (_     : _   )  = Nothing
        encode []              = Just []

        encodeStr :: StrT -> Maybe [Word8]
        encodeStr = mapM encodeChar . Str.toString

        encodeChar :: Char -> Maybe Word8
        encodeChar c
          | n >= 0 && n <= 255 = Just (fromIntegral n)
          | otherwise          = Nothing
          where n = fromEnum c

matchBuiltin :: Id -> (Regexp -> Text -> MatchResult) -> Builtin
matchBuiltin name matchFunc = Builtin name 2 (Just 3) [TStr, TStr, TAny]
                              TLst $ \(Str subject : Str pattern : optional) ->
  let [case_matters] = booleanDefaults optional [False]
  in runMatch matchFunc subject pattern case_matters

bf_match  = matchBuiltin "match"  match
bf_rmatch = matchBuiltin "rmatch" rmatch

runMatch :: (Regexp -> Text -> MatchResult) -> StrT -> StrT -> Bool -> MOO Value
runMatch match subject pattern caseMatters =
  case Str.toRegexp caseMatters pattern of
    Left (err, at) -> raiseException (Err E_INVARG)
                      (Str.fromString $ "Invalid pattern: " ++ err)
                      (Int $ fromIntegral at)
    Right regexp   -> case match regexp (Str.toText subject) of
      MatchFailed            -> return emptyList
      MatchAborted           -> raise E_QUOTA
      MatchSucceeded offsets ->
        let (m : offs)   = offsets
            (start, end) = convert m
            replacements = repls 9 offs
        in return $ fromList
           [Int start, Int end, fromList replacements, Str subject]

  where convert :: (Int, Int) -> (IntT, IntT)
        convert (s, e) = (1 + fromIntegral s, fromIntegral e)
        -- convert from 0-based open interval to 1-based closed one

        repls :: Int -> [(Int, Int)] -> [Value]
        repls n (r:rs) = let (s,e) = convert r
                         in fromList [Int s, Int e] : repls (n - 1) rs
        repls n []
          | n > 0      = fromList [Int 0, Int (-1)] : repls (n - 1) []
          | otherwise  = []

bf_substitute = Builtin "substitute" 2 (Just 2)
                [TStr, TLst] TStr $ \[Str template, Lst subs] ->
  case V.toList subs of
    [Int start', Int end', Lst replacements', Str subject'] -> do
      let start      = fromIntegral start'
          end        = fromIntegral end'
          subject    = Str.toString subject'
          subjectLen = Str.length subject'

          valid s e  = (s == 0 && e == -1) ||
                       (s >  0 && e >= s - 1 && e <= subjectLen)

          substr start end =
            let len = end - start + 1
            in take len $ drop (start - 1) subject

          substitution (Lst sub) = case V.toList sub of
            [Int start', Int end'] -> do
              let start = fromIntegral start'
                  end   = fromIntegral end'
              unless (valid start end) $ raise E_INVARG
              return $ substr start end
            _ -> raise E_INVARG
          substitution _ = raise E_INVARG

      unless (valid start end && V.length replacements' == 9) $
        raise E_INVARG
      replacements <- (substr start end :) `liftM`
                      mapM substitution (V.toList replacements')

      let walk ('%':c:cs)
            | isDigit c = let i = fromEnum c - fromEnum '0'
                          in (replacements !! i ++) `liftM` walk cs
            | c == '%'  = ("%" ++) `liftM` walk cs
            | otherwise = raise E_INVARG
          walk (c:cs) = ([c] ++) `liftM` walk cs
          walk []     = return []

      (Str . Str.fromString) `liftM` walk (Str.toString template)
    _ -> raise E_INVARG

bf_crypt = Builtin "crypt" 1 (Just 2)
           [TStr, TStr] TStr $ \(Str text : optional) ->
  let (saltArg : _) = maybeDefaults optional
      go salt = case crypt (Str.toString text) (Str.toString salt) of
        Just encrypted -> return $ Str $ Str.fromString encrypted
        Nothing        -> raise E_QUOTA
  in if maybe True invalidSalt saltArg
     then generateSalt >>= go
     else go $ fromStr $ fromJust saltArg

  where invalidSalt (Str salt) = salt `Str.compareLength` 2 == LT
        generateSalt = do
          c1 <- randSaltChar
          c2 <- randSaltChar
          return $ Str.fromString [c1, c2]
        randSaltChar = (saltStuff !!) `liftM` random (0, length saltStuff - 1)
        saltStuff = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "./"

hash :: ByteString -> Value
hash bs = Str $ Str.fromString $ show md5hash
  where md5hash = MD5.hash' bs :: MD5Digest

bf_string_hash = Builtin "string_hash" 1 (Just 1)
                 [TStr] TStr $ \[Str text] ->
  return $ hash $ encodeUtf8 (Str.toText text)

bf_binary_hash = Builtin "binary_hash" 1 (Just 1)
                 [TStr] TStr $ \[Str bin_string] ->
  hash `liftM` binaryString bin_string

-- § 4.4.2.4 Operations on Lists

-- bf_length already defined above

bf_is_member = Builtin "is_member" 2 (Just 2)
               [TAny, TLst] TInt $ \[value, Lst list] ->
  return $ Int $ maybe 0 (fromIntegral . succ) $
  V.findIndex (`equal` value) list

bf_listinsert = Builtin "listinsert" 2 (Just 3)
                [TLst, TAny, TInt] TLst $ \(Lst list : value : optional) ->
  let [Int index] = defaults optional [Int 1]
  in return $ Lst $ listInsert list (fromIntegral index - 1) value

bf_listappend = Builtin "listappend" 2 (Just 3)
                [TLst, TAny, TInt] TLst $ \(Lst list : value : optional) ->
  let [Int index] = defaults optional [Int $ fromIntegral $ V.length list]
  in return $ Lst $ listInsert list (fromIntegral index) value

bf_listdelete = Builtin "listdelete" 2 (Just 2)
                [TLst, TInt] TLst $ \[Lst list, Int index] ->
  let index' = fromIntegral index
  in if index' < 1 || index' > V.length list then raise E_RANGE
     else return $ Lst $ listDelete list (index' - 1)

bf_listset = Builtin "listset" 3 (Just 3)
             [TLst, TAny, TInt] TLst $ \[Lst list, value, Int index] ->
  let index' = fromIntegral index
  in if index' < 1 || index' > V.length list then raise E_RANGE
     else return $ Lst $ listSet list (index' - 1) value

bf_setadd = Builtin "setadd" 2 (Just 2)
            [TLst, TAny] TLst $ \[Lst list, value] ->
  return $ Lst $ if value `V.elem` list then list else V.snoc list value

bf_setremove = Builtin "setremove" 2 (Just 2)
               [TLst, TAny] TLst $ \[Lst list, value] ->
  return $ Lst $ case V.elemIndex value list of
    Nothing    -> list
    Just index -> listDelete list (fromIntegral index)