-- Copyright 2016 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Utilities for GHC's implicit call stacks feature.
module Util.CallStack (
    Stack
    , Caller(..), caller, showCaller

    , errorStack
    , errorIO
    , getStack, getStack1
    , throw
) where
import qualified Control.Exception as Exception
import qualified Control.Monad.Trans as Trans
import qualified Data.Aeson as Aeson
import qualified Data.Text as Text
import           Data.Text (Text)

import qualified GHC.Stack as Stack


-- | Add this to the context of a function to give stack-aware functions access
-- to its caller.
--
-- TODO use Stack.HasCallStack instead?  Or not, I already have Derive.Stack
-- and GHC.Stack.HasCallStack is pretty verbose.
type Stack = Stack.HasCallStack

-- | Simplified stack with just the immediate caller.
data Caller = Caller !FilePath !Int | NoCaller deriving (Caller -> Caller -> Bool
(Caller -> Caller -> Bool)
-> (Caller -> Caller -> Bool) -> Eq Caller
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Caller -> Caller -> Bool
$c/= :: Caller -> Caller -> Bool
== :: Caller -> Caller -> Bool
$c== :: Caller -> Caller -> Bool
Eq, Int -> Caller -> ShowS
[Caller] -> ShowS
Caller -> String
(Int -> Caller -> ShowS)
-> (Caller -> String) -> ([Caller] -> ShowS) -> Show Caller
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Caller] -> ShowS
$cshowList :: [Caller] -> ShowS
show :: Caller -> String
$cshow :: Caller -> String
showsPrec :: Int -> Caller -> ShowS
$cshowsPrec :: Int -> Caller -> ShowS
Show, ReadPrec [Caller]
ReadPrec Caller
Int -> ReadS Caller
ReadS [Caller]
(Int -> ReadS Caller)
-> ReadS [Caller]
-> ReadPrec Caller
-> ReadPrec [Caller]
-> Read Caller
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Caller]
$creadListPrec :: ReadPrec [Caller]
readPrec :: ReadPrec Caller
$creadPrec :: ReadPrec Caller
readList :: ReadS [Caller]
$creadList :: ReadS [Caller]
readsPrec :: Int -> ReadS Caller
$creadsPrec :: Int -> ReadS Caller
Read)

instance Aeson.ToJSON Caller where
    toJSON :: Caller -> Value
toJSON (Caller String
fname Int
line) = (String, Int) -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON (String
fname, Int
line)
    toJSON Caller
NoCaller = Value
Aeson.Null
instance Aeson.FromJSON Caller where
    parseJSON :: Value -> Parser Caller
parseJSON Value
val = case Value
val of
        Value
Aeson.Null -> Caller -> Parser Caller
forall (m :: * -> *) a. Monad m => a -> m a
return Caller
NoCaller
        Value
_ -> (String -> Int -> Caller) -> (String, Int) -> Caller
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> Int -> Caller
Caller ((String, Int) -> Caller) -> Parser (String, Int) -> Parser Caller
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (String, Int)
forall a. FromJSON a => Value -> Parser a
Aeson.parseJSON Value
val

caller :: Stack.CallStack -> Caller
caller :: CallStack -> Caller
caller CallStack
stack = case [(String, SrcLoc)] -> [(String, SrcLoc)]
forall a. [a] -> [a]
reverse (CallStack -> [(String, SrcLoc)]
Stack.getCallStack CallStack
stack) of
    (String
_, SrcLoc
srcloc) : [(String, SrcLoc)]
_ ->
        String -> Int -> Caller
Caller (ShowS
strip (SrcLoc -> String
Stack.srcLocFile SrcLoc
srcloc))
            (SrcLoc -> Int
Stack.srcLocStartLine SrcLoc
srcloc)
    [] -> Caller
NoCaller
    where
    strip :: ShowS
strip (Char
'.':Char
'/':String
s) = String
s
    strip String
s = String
s

showFrame :: (String, Stack.SrcLoc) -> String
showFrame :: (String, SrcLoc) -> String
showFrame (String
name, SrcLoc
srcloc) =
    String
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
strip (SrcLoc -> String
Stack.srcLocFile SrcLoc
srcloc) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (SrcLoc -> Int
Stack.srcLocStartLine SrcLoc
srcloc)
    where
    strip :: ShowS
strip (Char
'.':Char
'/':String
s) = String
s
    strip String
s = String
s

showCaller :: Caller -> Text
showCaller :: Caller -> Text
showCaller (Caller String
fname Int
line) = String -> Text
Text.pack String
fname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show Int
line)
showCaller Caller
NoCaller = Text
"<no-caller>"

-- | This is like 'Stack.prettyCallStack', except more compact.
getStack :: Stack => Text
getStack :: Stack => Text
getStack = Text -> [Text] -> Text
Text.intercalate Text
"; " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ((String, SrcLoc) -> Text) -> [(String, SrcLoc)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
Text.pack (String -> Text)
-> ((String, SrcLoc) -> String) -> (String, SrcLoc) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, SrcLoc) -> String
showFrame) ([(String, SrcLoc)] -> [Text]) -> [(String, SrcLoc)] -> [Text]
forall a b. (a -> b) -> a -> b
$ [(String, SrcLoc)] -> [(String, SrcLoc)]
forall a. [a] -> [a]
reverse ([(String, SrcLoc)] -> [(String, SrcLoc)])
-> [(String, SrcLoc)] -> [(String, SrcLoc)]
forall a b. (a -> b) -> a -> b
$
    CallStack -> [(String, SrcLoc)]
Stack.getCallStack CallStack
Stack => CallStack
Stack.callStack

-- | Get only the top of the stack.  More compact than 'getStack'.
getStack1 :: Stack => Text
getStack1 :: Stack => Text
getStack1 = Caller -> Text
showCaller (Caller -> Text) -> Caller -> Text
forall a b. (a -> b) -> a -> b
$ CallStack -> Caller
caller (CallStack -> Caller) -> CallStack -> Caller
forall a b. (a -> b) -> a -> b
$ CallStack
Stack => CallStack
Stack.callStack

-- | This is for internal errors, which are unexpected and should "never
-- happen."  It's basically like 'Exception.ErrorCall', except that it's
-- an app-specific type rather than a generic one.  I don't know if the
-- distinction will ever be relevant, but there it is.  At least it's
-- greppable.
--
-- I use 'error' in tests and non-core code, but try to use 'errorIO' or
-- 'errorStack' code run by App.Main.
newtype Error = Error Text
    deriving (Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
(Int -> Error -> ShowS)
-> (Error -> String) -> ([Error] -> ShowS) -> Show Error
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Error] -> ShowS
$cshowList :: [Error] -> ShowS
show :: Error -> String
$cshow :: Error -> String
showsPrec :: Int -> Error -> ShowS
$cshowsPrec :: Int -> Error -> ShowS
Show)

instance Exception.Exception Error where
    displayException :: Error -> String
displayException (Error Text
msg) = Text -> String
Text.unpack Text
msg

-- | Like 'error', use when forced.
errorStack :: Stack => Text -> a
errorStack :: forall a. Stack => Text -> a
errorStack = Error -> a
forall a e. Exception e => e -> a
Exception.throw (Error -> a) -> (Text -> Error) -> Text -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Error
Error (Text -> Error) -> (Text -> Text) -> Text -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text
Stack => Text
getStack Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": ") <>)

-- | Throw an error in IO, with a stack.
errorIO :: Stack => Trans.MonadIO m => Text -> m a
errorIO :: forall (m :: * -> *) a. (Stack, MonadIO m) => Text -> m a
errorIO = IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Trans.liftIO (IO a -> m a) -> (Text -> IO a) -> Text -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> IO a
forall e a. Exception e => e -> IO a
Exception.throwIO (Error -> IO a) -> (Text -> Error) -> Text -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Error
Error (Text -> Error) -> (Text -> Text) -> Text -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text
Stack => Text
getStack Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": ") <>)

throw :: (Stack, Exception.Exception e) => (Text -> e) -> Text -> a
throw :: forall e a. (Stack, Exception e) => (Text -> e) -> Text -> a
throw Text -> e
toExc Text
msg = e -> a
forall a e. Exception e => e -> a
Exception.throw (Text -> e
toExc (Text
Stack => Text
getStack Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg))