{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans #-}

{-|
    Internal utilities and library imports.

>   Though here at journey's end I lie
>   in darkness buried deep,
>   beyond all towers strong and high,
>   beyond all mountains steep,
>   above all shadows rides the Sun
>   and Stars for ever dwell:
>   I will not say the Day is done,
>   nor bid the Stars farewell.
-}

module Pugs.Internals (
    module UTF8,
    module Unicode,
    module Pugs.Compat,
    module RRegex,
    module RRegex.Syntax,
    module Pugs.Rule.Pos,
    module Data.Dynamic,
    module Data.Unique,
    module Data.FunctorM,
    module Control.Exception,
    module System.Environment,
    module System.Random,
    module System.IO,
    module System.IO.Unsafe,
    module System.IO.Error,
    module System.Exit,
    module System.Time,
    module System.Directory,
    module System.Cmd,
    module System.Process,
    module System.Mem,
    module System.Mem.Weak,
    module Control.Monad.RWS,
    module Control.Monad.Error,
    module Control.Concurrent,
    module Control.Concurrent.STM,
    module Data.Array,
    module Data.Bits,
    module Data.List,
    module Data.Either,
    module Data.Word,
    module Data.Ratio,
    module Data.Char,
    module Data.Tree,
    module Data.Maybe,
    module Data.Complex,
    module Data.Set,
    module Data.Map,
    module Data.IntMap,
    module Debug.Trace,
    module Network,
    internalError,
    split,
    breakOnGlue,
    afterPrefix,
    decodeUTF8,
    encodeUTF8,
    forM,
    forM_,
    tryIO,
    combine,
    modifyTVar,
    unsafePerformSTM,
    possiblyFixOperatorName,
    maybeM,
    safeMode,
) where

import UTF8
import Unicode
import Pugs.Compat
import RRegex
import RRegex.Syntax
import Data.Dynamic
import Data.Array (elems)
import Network
import System.Environment (getArgs, withArgs, getProgName)
import System.Random hiding (split)
import System.Exit
import System.Time
import System.Cmd
import System.Process
import System.IO (
    Handle, stdin, stdout, hClose, hGetLine, hGetChar, hGetContents,
    openFile, hSetBinaryMode, hPutStr, hPutStrLn, IOMode(..), stderr, SeekMode(..),
    hSetBuffering, BufferMode(..), hIsTerminalDevice, hFlush, hPrint, isEOF
    )
import System.IO.Unsafe
import System.IO.Error (ioeGetErrorString, isUserError)
import System.Directory
import System.Mem
import System.Mem.Weak
import Control.Exception (catchJust, errorCalls)
import Control.Monad.RWS
import Control.Monad.Error (MonadError(..))
import Control.Concurrent
import Control.Concurrent.STM
import Data.Bits hiding (shift)
import Data.Maybe
import Data.Either
import Data.FunctorM
import Data.List (
    (\\), find, genericLength, insert, sortBy, intersperse,
    partition, group, sort, genericReplicate, isPrefixOf, isSuffixOf,
    genericTake, genericDrop, unfoldr, nub, nubBy, transpose, delete
    )
import Data.Unique
import Data.Ratio
import Data.Word
import Data.Char (chr, ord, digitToInt)
import Data.Complex
import Data.Tree
import Data.Set (Set)
import Data.Map (Map)
import Data.IntMap (IntMap)
import Debug.Trace
import Pugs.Rule.Pos
-- import GHC.Conc (unsafeIOToSTM)

-- Instances.
instance Show Unique where
    show = show . hashUnique
instance Show (a -> b) where
    show _ = "(->)"
instance Eq (a -> b) where
    _ == _ = False
instance Ord (a -> b) where
    compare _ _ = LT
instance Eq Dynamic where
    _ == _ = False
instance Ord Dynamic where
    compare _ _ = LT

internalError :: String -> a
internalError s = error $
    "Internal error:\n    " ++ s ++ "\nPlease file a bug report."

split :: (Eq a) => [a] -> [a] -> [[a]]
split []  _   = internalError "splitting by an empty list"
split sep str =
   case breakOnGlue sep str of
     Just (before, after) -> before : split sep after
     Nothing -> [str]

-- returns Nothing if the glue isn't there
breakOnGlue :: (Eq a) => [a] -> [a] -> Maybe ([a], [a])
breakOnGlue _    [] = Nothing
breakOnGlue glue list@(x:xs) =
   case afterPrefix glue list of
      Just rest -> Just ([], rest)
      Nothing -> case breakOnGlue glue xs of
                    Just (before, after) -> Just (x : before, after)
                    Nothing -> Nothing

afterPrefix :: (Eq a) => [a] -> [a] -> Maybe [a]
afterPrefix []     list = Just list
afterPrefix _      []   = Nothing  -- non-empty prefix of an empty list
afterPrefix (p:ps) (x:xs)
   | p == x = afterPrefix ps xs
   | otherwise = Nothing

encodeUTF8 :: String -> String
encodeUTF8 = map (chr . fromEnum) . encode

decodeUTF8 :: String -> String
decodeUTF8 str = fst $ decode bytes
    where
    bytes = map (toEnum . ord) str

{-|
Take a list of values, and a monad-producing function, and apply that function
to each element of the list. The resulting monads are combined into a single
monad producing a list of the resulting values.

(This is just @mapM@ with the arguments reversed.)
-}
forM :: (Monad m) 
     => [a]        -- ^ List of values to loop over
     -> (a -> m b) -- ^ The \'body\' of the for loop
     -> m [b]      -- ^ Monad containing a list of the results
forM = flip mapM

{-|
Take a list of values, and a monad-producing function, and apply that function
to each element of the list in sequence. The values produced by the monadic
function are discarded.

(This is just @mapM_@ with the arguments reversed.)
-}
forM_ :: (Monad m) 
      => [a]        -- ^ List of values to loop over
      -> (a -> m b) -- ^ The \'body\' of the for loop
      -> m ()
forM_ = flip mapM_

tryIO :: (MonadIO m) => a -> IO a -> m a
tryIO err = liftIO . (`catch` (const $ return err))

{-|
Compose a list of @(a -> a)@ transformer functions into a single chained
function, using @foldr@ via the @(.)@ operator.

Note that the transformations are applied to the eventual argument in 
right-to-left order.
-}
combine :: [a -> a] -- ^ List of transformer functions
        -> (a -> a) -- ^ The final combined transformer
combine = foldr (.) id

unsafePerformSTM :: STM a -> a
unsafePerformSTM = unsafePerformIO . atomically

{-|
Read an STM variable, apply some transformation function to it, and write the
transformed value back to the same variable.
-}
modifyTVar :: TVar a 
           -> (a -> a) 
           -> STM ()
modifyTVar var f = do
    x <- readTVar var
    writeTVar var (f x)

-- instance MonadIO STM where
--     liftIO = unsafeIOToSTM

{-|
Extract a @Maybe@ value from the first argument (a monad).

If it's a @Just@ (i.e. it contains a value), apply the second argument
(a monad-producing function) to it, and @return@ the contents of /that/ 
wrapped in a @Just@.

Otherwise, merely @return Nothing@.

(Strictly speaking, this function can operate with any @FunctorM@, not just
@Maybe@, but it helps to have a concrete example to explain things.)
-}
maybeM :: (FunctorM f, Monad m) 
       => m (f a)    -- ^ A @Maybe@ value encapsulated in a monad
       -> (a -> m b) -- ^ Action to perform on the first arg /if/ it contains
                     --     a value
       -> m (f b)    -- ^ Monad containing (@Just@ /result/) or @Nothing@
maybeM f m = fmapM m =<< f

{-|
Transform an operator name, for example @&infix:\<+\>@ or @&prefix:«[+]»@, 
into its internal name (@&infix:+@ and @&prefix:[+]@ respectively).
-}
possiblyFixOperatorName :: String -> String
possiblyFixOperatorName name
    -- It doesn't matter if we lookup &foo or &*foo.
    | ('&':'*':rest) <- name = "&*" ++ fixName' rest
    | ('&':rest)     <- name = "&"  ++ fixName' rest
    | otherwise      = name
    where
    -- We've to strip the <>s for &infix:<...>, &prefix:<...>, and
    -- &postfix:<...>.
    -- The other &...:<...> things aren't that simple (e.g. circumfix.).
    fixName' ('i':'n':'f':'i':'x':':':rest)         = "infix:"   ++ dropBrackets rest
    fixName' ('p':'r':'e':'f':'i':'x':':':rest)     = "prefix:"  ++ dropBrackets rest
    fixName' ('p':'o':'s':'t':'f':'i':'x':':':rest) = "postfix:" ++ dropBrackets rest
    fixName' x                                      = x
    -- We have to make sure that the last character(s) match the first one(s),
    -- otherwise 4 <= 4 will stop working.
    -- Kludge. <=> is ambigious.
    dropBrackets "<=>" = "<=>"
    -- «bar» --> bar
    dropBrackets ('\171':(rest@(_:_)))    = if (last rest) == '\187' then init rest else '\171':rest
    -- <<bar>> --> bar
    dropBrackets ('<':'<':(rest@(_:_:_))) = if (last rest) == '>' && (last . init $ rest) == '>' then init . init $ rest else "<<" ++ rest
    -- <bar> --> bar
    dropBrackets ('<':(rest@(_:_)))       = if (last rest) == '>' then init rest else '<':rest
    dropBrackets x                        = x

{-|
Returns @True@ if the environment variable @PUGS_SAFEMODE@ is set to a
true value. Most IO primitives are disabled under safe mode.
-}
{-# NOINLINE safeMode #-}
safeMode :: Bool
safeMode = case (unsafePerformIO $ getEnv "PUGS_SAFEMODE") of
    Nothing     -> False
    Just ""     -> False
    Just "0"    -> False
    _           -> True