{-# OPTIONS -cpp #-}
-- 
-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons
--               2005 Stefan Wehr - http://www.stefanwehr.de
--
-- This program is free software; you can redistribute it and/or
-- modify it under the terms of the GNU General Public License as
-- published by the Free Software Foundation; either version 2 of
-- the License, or (at your option) any later version.
-- 
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- General Public License for more details.
-- 
-- You should have received a copy of the GNU General Public License
-- along with this program; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
-- 02111-1307, USA.
-- 

module Phrac.Error ( 

    phasefail_, panic_, 
    pprPhaseFail_, pprPanic_,
    PException, 
    showWithoutLocation,
    debug_, display_, enableDebug, DebugLevel(..),
    Location

  ) where

import Char (toUpper)
import Data.Dynamic
import Data.IORef
import Control.Exception as E         ( throwDyn, catchDyn )
import Control.Monad.State
import System.Environment             ( getProgName )
import System.IO                      ( hFlush, stdout )
import System.IO.Unsafe               ( unsafePerformIO )

import Phrac.Pretty

--
-- program exceptions
--

type Location = (String, Int)

data PException
    = PhaseFailed Location String -- name of phase, message
    | Panic Location String       -- the `impossible' happened
  deriving Eq

instance Show PException where
  show e = progName ++ ": " ++ showPException e

showPException :: PException -> String
showPException (PhaseFailed (fname, lineno) msg)
    = fname  ++ ":" ++ show lineno ++ ": " ++ msg
showPException (Panic (fname, lineno) msg)
    = fname  ++ ":" ++ show lineno ++ ": PANIC!\n\t" ++ msg

showWithoutLocation :: PException -> String
showWithoutLocation (PhaseFailed (fname, lineno) msg) = msg
showWithoutLocation (Panic (fname, lineno) msg) 
    = fname  ++ ":" ++ show lineno ++ ": PANIC!\n\t" ++ msg

pExceptionTc :: TyCon
pExceptionTc = mkTyCon "PException"
{-# NOINLINE pExceptionTc #-}

instance Typeable PException where
#if __GLASGOW_HASKELL__ >= 603
    typeOf _ = mkTyConApp pExceptionTc []
#else
    typeOf _ = mkAppTy pExceptionTc []
#endif


--
-- panics and general failures
--
panic_ :: Location -> String -> a
panic_ l  x = E.throwDyn (Panic l x)

phasefail_ :: Location -> String -> a
phasefail_ l x = E.throwDyn (PhaseFailed l x)

pprPanic_ :: Pretty a => Location -> String -> a -> b
pprPanic_ loc msg code = 
    panic_ loc $ msg ++ "\nIn the expression:\n" ++ (show (nest 8 (ppr code)))

pprPhaseFail_ :: Pretty a => Location -> String -> a -> b
pprPhaseFail_ loc msg code = 
    phasefail_ loc $ "\n\t" ++ msg ++ 
                   "\nIn the expression:\n" ++ (show (nest 8 (ppr code)))


--
-- Debugging
--

data DebugLevel = Debug
                | Verbose
                | Disabled
                  deriving (Eq,Ord,Show)

genDebug :: MonadIO m => DebugLevel -> Location -> String -> m ()
genDebug level (fname, lineno) msg = 
    let s = "[" ++ map toUpper (show level) ++ "] " ++ fname  ++ ":" 
            ++ show lineno ++ ": " ++ msg
        in do l <- liftIO $ readIORef debugFlag
              if level >= l 
                 then liftIO $ do (putStrLn s) 
                                  hFlush stdout 
                 else return ()

debug_ :: MonadIO m => Location -> String -> m ()
debug_ loc msg = genDebug Debug loc msg

display_ :: MonadIO m => Location -> String -> m ()
display_ loc msg = genDebug Verbose loc msg

enableDebug :: DebugLevel -> IO ()
enableDebug l =
    writeIORef debugFlag l

debugFlag :: IORef DebugLevel
debugFlag = unsafePerformIO (newIORef Disabled)
{-# NOINLINE debugFlag #-}

------------------------------------------------------------------------

progName :: String
progName = unsafePerformIO (getProgName)
{-# NOINLINE progName #-}