# LANGUAGE MultiParamTypeClasses #
# LANGUAGE FlexibleInstances #
# LANGUAGE FlexibleContexts #
# LANGUAGE ScopedTypeVariables #
{-# LANGUAGE TypeSynonymInstances #-}
-----------------------------------------------------------------------------
-- |
  Module       :    . Lib
  License      :   MIT - style ( see LICENSE )
--
-- Stability   :  provisional
-- Portability :  portable
--
  Library routines and helper functions for the Sindre programming
-- language.
--
-----------------------------------------------------------------------------
module Sindre.Lib ( stdFunctions
                  , ioFunctions
                  , ioGlobals
                  , LiftFunction(..)
                  , KeyLike(..)
                  )
    where

import Sindre.Sindre
import Sindre.Compiler
import Sindre.Runtime
import Sindre.Util

import System.Environment
import System.Exit
import System.IO
import System.Process hiding (env)
import Text.Regex.PCRE

import Control.Monad
import Control.Monad.Trans
import Data.Char
import Data.List
import qualified Data.Map as M
import qualified Data.Set as S

lengthFun :: Value -> Integer
lengthFun (Dict m) = fi $ M.size m
lengthFun v = maybe 0 genericLength (mold v :: Maybe String)

builtin :: LiftFunction im m a => a -> Compiler im ([Value] -> m im Value)
builtin f = return $ function f

  | A set of pure functions that can work with any  backend .
  Includes the functions @abs@ ,  , @cos@ , @sin@ ,  , @log@ ,
  @int@ , @sqrt@ , @length@ , @substr@ , @index@ , @match@ , @sub@ , @gsub@ ,
-- @tolower@, and @toupper@.
stdFunctions :: forall im. MonadBackend im => FuncMap im
stdFunctions = M.fromList
               [ ("abs" , builtin $ return' . (abs :: Int -> Int))
               , ("atan2", builtin $ \(x::Double) (y::Double) ->
                    return' $ atan2 x y)
               , ("cos", builtin $ return' . (cos :: Double -> Double))
               , ("sin", builtin $ return' . (sin :: Double -> Double))
               , ("exp", builtin $ return' . (exp :: Double -> Double))
               , ("log", builtin $ return' . (log :: Double -> Double))
               , ("int", builtin $ return' . (floor :: Double -> Integer))
               , ("sqrt", builtin $ return' . (sqrt :: Double -> Double))
               , ("length", builtin $ return' . lengthFun)
               , ("substr", builtin $ \(s::String) m n ->
                   return' $ take n $ drop (m-1) s)
               , ("index",  builtin $ \(s::String) t ->
                   return' $ maybe 0 (1+) $ findIndex (isPrefixOf t) $ tails s)
               , ("match", do
                     rstart  <- setValue "RSTART"
                     rlength <- setValue "RLENGTH"
                     return $ function $ \(s::String) (r::String) -> do
                       let (stt, len) = s =~ r :: (Int, Int)
                       execute_ $ do rstart $ unmold (stt+1)
                                     rlength $ unmold len
                       return' $ unmold (stt+1))
               , ("sub", builtin sub)
               , ("gsub", builtin gsub)
               , ("tolower", builtin $ return' . map toLower)
               , ("toupper", builtin $ return' . map toUpper)
               ]
    where return' :: Mold a => a -> Sindre im a
          return' = return
          sub (r::String) t (s::String) =
            case s =~ r of
              (-1,_) -> return' s
              (i,n)  -> return' $ take i s ++ t ++ drop (i+n) s
          gsub (r::String) t (s::String) =
            case s =~ r of
              (-1,_) -> return' s
              (i,n)  -> do s' <- gsub r t $ drop (i+n) s
                           return' $ take i s ++ t ++ s'
  | A set of impure functions that only work in IO backends .
-- Includes the @system@ function.
ioFunctions :: (MonadIO m, MonadBackend m) => FuncMap m
ioFunctions = M.fromList
              [ ("system", do
                   exitval <- setValue "EXITVAL"
                   builtin $ \s -> do
                     c <- io $ system s
                     let v = case c of ExitSuccess   -> 0
                                       ExitFailure e -> e
                     execute_ $ exitval $ unmold v
                     return' v)
              , ("osystem", do
                    exitval <- setValue "EXITVAL"
                    return $ function $ \s -> do
                      (Just inh, Just outh, _, pid) <-
                        io $ createProcess (shell s) { std_in  = CreatePipe,
                                                       std_out = CreatePipe,
                                                       std_err = Inherit }
                      io $ hClose inh
                      output <- io $ hGetContents outh
                      ex <- io $ waitForProcess pid
                      execute_ $ exitval $ unmold $ case ex of
                        ExitSuccess   -> 0
                        ExitFailure r -> r
                      return' output)
              ]
    where return' :: Mold a => a -> Sindre im a
          return' = return

-- | Global variables that require an IO backend.  Includes the
-- @ENVIRON@ global.
ioGlobals :: MonadIO im => M.Map Identifier (im Value)
ioGlobals = M.fromList [("ENVIRON", do
                           env <- io getEnvironment
                           let f (k, s) = (unmold k, unmold s)
                           return $ Dict $ M.fromList $ map f env)
                       ]

  | A class making it easy to adapt  functions as 
-- functions that take and return 'Value's.
class (MonadBackend im, MonadSindre im m) => LiftFunction im m a where
  function :: a -> [Value] -> m im Value
  -- ^ @function f@ is a monadic function that accepts a list of
  -- 'Value's and returns a 'Value'.  If the list does not contain the
  number , or type , of arguments expected by  , ' fail ' will be
  -- called with an appropriate error message.

instance (Mold a, MonadSindre im m) => LiftFunction im m (m im a) where
  function x [] = liftM unmold x
  function _ _ = fail "Too many arguments"

instance (Mold a, LiftFunction im m b, MonadSindre im m)
    => LiftFunction im m (a -> b) where
  function f (x:xs) = case mold x of
                        Nothing -> fail "Cannot mold argument"
                        Just x' -> f x' `function` xs
  function _ [] = fail "Not enough arguments"

-- | Convenience class for writing 'Chord' values.
class KeyLike a where
  chord :: [KeyModifier] -> a -> Chord
  -- ^ Given a list of modifiers and either a 'char' or a 'String',
  yield a ' Chord ' .   If given a character , the Chord will contain a
  ' CharKey ' , if given a string , it will contain a ' CtrlKey ' .

instance KeyLike Char where
  chord ms c = (S.fromList ms, CharKey c)

instance KeyLike String where
  chord ms s = (S.fromList ms, CtrlKey s)

# LANGUAGE TypeSynonymInstances #
---------------------------------------------------------------------------
 |

 Stability   :  provisional
 Portability :  portable

 language.

---------------------------------------------------------------------------
 @tolower@, and @toupper@.
 Includes the @system@ function.
 | Global variables that require an IO backend.  Includes the
 @ENVIRON@ global.
 functions that take and return 'Value's.
 ^ @function f@ is a monadic function that accepts a list of
 'Value's and returns a 'Value'.  If the list does not contain the
 called with an appropriate error message.
 | Convenience class for writing 'Chord' values.
 ^ Given a list of modifiers and either a 'char' or a 'String',
# LANGUAGE MultiParamTypeClasses #
# LANGUAGE FlexibleInstances #
# LANGUAGE FlexibleContexts #
# LANGUAGE ScopedTypeVariables #
  Module       :    . Lib
  License      :   MIT - style ( see LICENSE )
  Library routines and helper functions for the Sindre programming
module Sindre.Lib ( stdFunctions
                  , ioFunctions
                  , ioGlobals
                  , LiftFunction(..)
                  , KeyLike(..)
                  )
    where

import Sindre.Sindre
import Sindre.Compiler
import Sindre.Runtime
import Sindre.Util

import System.Environment
import System.Exit
import System.IO
import System.Process hiding (env)
import Text.Regex.PCRE

import Control.Monad
import Control.Monad.Trans
import Data.Char
import Data.List
import qualified Data.Map as M
import qualified Data.Set as S

lengthFun :: Value -> Integer
lengthFun (Dict m) = fi $ M.size m
lengthFun v = maybe 0 genericLength (mold v :: Maybe String)

builtin :: LiftFunction im m a => a -> Compiler im ([Value] -> m im Value)
builtin f = return $ function f

  | A set of pure functions that can work with any  backend .
  Includes the functions @abs@ ,  , @cos@ , @sin@ ,  , @log@ ,
  @int@ , @sqrt@ , @length@ , @substr@ , @index@ , @match@ , @sub@ , @gsub@ ,
stdFunctions :: forall im. MonadBackend im => FuncMap im
stdFunctions = M.fromList
               [ ("abs" , builtin $ return' . (abs :: Int -> Int))
               , ("atan2", builtin $ \(x::Double) (y::Double) ->
                    return' $ atan2 x y)
               , ("cos", builtin $ return' . (cos :: Double -> Double))
               , ("sin", builtin $ return' . (sin :: Double -> Double))
               , ("exp", builtin $ return' . (exp :: Double -> Double))
               , ("log", builtin $ return' . (log :: Double -> Double))
               , ("int", builtin $ return' . (floor :: Double -> Integer))
               , ("sqrt", builtin $ return' . (sqrt :: Double -> Double))
               , ("length", builtin $ return' . lengthFun)
               , ("substr", builtin $ \(s::String) m n ->
                   return' $ take n $ drop (m-1) s)
               , ("index",  builtin $ \(s::String) t ->
                   return' $ maybe 0 (1+) $ findIndex (isPrefixOf t) $ tails s)
               , ("match", do
                     rstart  <- setValue "RSTART"
                     rlength <- setValue "RLENGTH"
                     return $ function $ \(s::String) (r::String) -> do
                       let (stt, len) = s =~ r :: (Int, Int)
                       execute_ $ do rstart $ unmold (stt+1)
                                     rlength $ unmold len
                       return' $ unmold (stt+1))
               , ("sub", builtin sub)
               , ("gsub", builtin gsub)
               , ("tolower", builtin $ return' . map toLower)
               , ("toupper", builtin $ return' . map toUpper)
               ]
    where return' :: Mold a => a -> Sindre im a
          return' = return
          sub (r::String) t (s::String) =
            case s =~ r of
              (-1,_) -> return' s
              (i,n)  -> return' $ take i s ++ t ++ drop (i+n) s
          gsub (r::String) t (s::String) =
            case s =~ r of
              (-1,_) -> return' s
              (i,n)  -> do s' <- gsub r t $ drop (i+n) s
                           return' $ take i s ++ t ++ s'
  | A set of impure functions that only work in IO backends .
ioFunctions :: (MonadIO m, MonadBackend m) => FuncMap m
ioFunctions = M.fromList
              [ ("system", do
                   exitval <- setValue "EXITVAL"
                   builtin $ \s -> do
                     c <- io $ system s
                     let v = case c of ExitSuccess   -> 0
                                       ExitFailure e -> e
                     execute_ $ exitval $ unmold v
                     return' v)
              , ("osystem", do
                    exitval <- setValue "EXITVAL"
                    return $ function $ \s -> do
                      (Just inh, Just outh, _, pid) <-
                        io $ createProcess (shell s) { std_in  = CreatePipe,
                                                       std_out = CreatePipe,
                                                       std_err = Inherit }
                      io $ hClose inh
                      output <- io $ hGetContents outh
                      ex <- io $ waitForProcess pid
                      execute_ $ exitval $ unmold $ case ex of
                        ExitSuccess   -> 0
                        ExitFailure r -> r
                      return' output)
              ]
    where return' :: Mold a => a -> Sindre im a
          return' = return

ioGlobals :: MonadIO im => M.Map Identifier (im Value)
ioGlobals = M.fromList [("ENVIRON", do
                           env <- io getEnvironment
                           let f (k, s) = (unmold k, unmold s)
                           return $ Dict $ M.fromList $ map f env)
                       ]

  | A class making it easy to adapt  functions as 
class (MonadBackend im, MonadSindre im m) => LiftFunction im m a where
  function :: a -> [Value] -> m im Value
  number , or type , of arguments expected by  , ' fail ' will be

instance (Mold a, MonadSindre im m) => LiftFunction im m (m im a) where
  function x [] = liftM unmold x
  function _ _ = fail "Too many arguments"

instance (Mold a, LiftFunction im m b, MonadSindre im m)
    => LiftFunction im m (a -> b) where
  function f (x:xs) = case mold x of
                        Nothing -> fail "Cannot mold argument"
                        Just x' -> f x' `function` xs
  function _ [] = fail "Not enough arguments"

class KeyLike a where
  chord :: [KeyModifier] -> a -> Chord
  yield a ' Chord ' .   If given a character , the Chord will contain a
  ' CharKey ' , if given a string , it will contain a ' CtrlKey ' .

instance KeyLike Char where
  chord ms c = (S.fromList ms, CharKey c)

instance KeyLike String where
  chord ms s = (S.fromList ms, CtrlKey s)
