{- 
 - mapException+SRCLOC with refinements/examples suggested by "finding the needle" paper 
 -
 - - we have none of the performance improvements
 - - we have essentially same information (without the enclosing function's name)
 - - all we need is a way to write things like
 -
 -   {-# RULES (ONCE)
 -   "mapError(fib)"   fib{SRCLOC}   = mapError SRCLOC fib  
 -   "mapError(odd_)"  odd_{SRCLOC}  = mapError SRCLOC odd_  
 -   "mapError(even_)" even_{SRCLOC} = mapError SRCLOC even_  
 -   "errorSrc"        error{SRCLOC} = errorSrc SRCLOC
 -     #-}
 -
 -   without looping, with SRCLOC taken from 'fib', 'error'.
 -
 - with plain RULES, we can copy the function definitions (fib->fib_) and use
 - fib_ on the right hand side, to avoid looping - a ONCE specifier would be helpful
 -
 - with plain RULES, there seems to be no way to refer to the source location of
 - the match for the left-hand side - a _{SRCLOC} binding (referring to the source
 - location info of _) would be great
 -}

{-# LANGUAGE CPP #-}
import Control.Exception

#define SRCLOC (show (__FILE__,__LINE__))
#define ERRORSRC (\msg->error $ msg++SRCLOC)

printE x = Control.Exception.catch (print x) (\(ErrorCall e)->putStrLn e)

main :: IO ()
main = do
  putStrLn "\n-- fib 5"
  printE $ mapError SRCLOC (fib 5)
  putStrLn "\n-- odd_ 5"
  printE $ mapError SRCLOC (odd_ 5)
  putStrLn "\n-- firstLetters2"
  printE $ mapError SRCLOC firstLetters2

-- direct recursion
fib :: Int -> Int
fib 1 = 1
fib n | n > 1 = mapError SRCLOC (fib (n - 1)) + mapError SRCLOC (fib (n - 2))
fib n = errorSrc SRCLOC $ "fib with non-positive number: "++ show n

-- mutual recursion
odd_ 2        = True
odd_ n  | n>1 = mapError SRCLOC $ even_ (n-1)
odd_ _        = errorSrc SRCLOC "odd_: no match"

even_ 1       = False
even_ n | n>1 = mapError SRCLOC $ odd_ (n-1)
even_ _       = errorSrc SRCLOC "even_: no match"

-- recursion with higher-order function
firstLetters2 = mapError SRCLOC $ map_ (mapError SRCLOC . head) ["hi", "world", "", "!"]

map_ f []    = []
map_ f (h:t) = f_ h : mapError SRCLOC (map_ f_ t)
  where f_ = mapError SRCLOC . f

-- variations of error message augmentation, choose one
#ifdef PLAIN
mapError = mapError1
#else
#ifdef DIRECT
mapError = mapError2
#else
mapError = mapError3
#endif
#endif

-- plain message augmentation
mapError1 src = mapException (\(ErrorCall e)->ErrorCall $ e++"\n"++src)
errorSrc src = error . (++"\n"++src)

-- elide immediate recursive calls to the same site
mapError2 src = mapException (\(ErrorCall e)->ErrorCall $ 
                  case reverse (lines e) of
                    (src':e') | src'==src -> 
                      case e' of
                       []        -> "...\n"++src
                       ("...":_) -> e
                       _         -> init $ unlines $ reverse (src:"...":e')
                    _ -> e++"\n"++src)

-- elide all recursive calls to the same site
mapError3 src = mapException (\(ErrorCall e)->ErrorCall $ 
                       init $ unlines $ reverse $ (src:) $ elide $ reverse $ lines e)
  where elide [] = []
        elide (src':e) | src'==src = merge $ ("...":e)
                       | otherwise = src':elide e
        merge ("...":"...":e) = ("...":e)
        merge e               = e