-- | This module contains the code for all the user (programmer) facing
--   aspects, i.e. error messages, source-positions, overall results.

{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances    #-}

module Language.Elsa.UX
  (
  -- * Representation
    SourceSpan (..)
  , Located (..)

  -- * Usage Mode
  , Mode (..)

  -- * Extraction from Source file
  , readFileSpan

  -- * Constructing spans
  , posSpan, junkSpan

  -- * Success and Failure
  , UserError
  , eMsg
  , eSpan
  -- , Result

  -- * Throwing & Handling Errors
  , mkError
  , abort
  , panic
  , renderErrors

  -- * Pretty Printing
  , Text
  , PPrint (..)
  ) where

import           Control.Exception
import           Data.Typeable
import qualified Data.List as L
import           Text.Printf (printf)
import           Text.Megaparsec
import           Text.JSON hiding (Error)
import           Language.Elsa.Utils

type Text = String

class PPrint a where
  pprint :: a -> Text

--------------------------------------------------------------------------------
-- | Accessing SourceSpan
--------------------------------------------------------------------------------
class Located a where
  sourceSpan :: a -> SourceSpan

instance Located SourceSpan where
  sourceSpan :: SourceSpan -> SourceSpan
sourceSpan SourceSpan
x = SourceSpan
x

--------------------------------------------------------------------------------
-- | Source Span Representation
--------------------------------------------------------------------------------
data SourceSpan = SS
  { SourceSpan -> SourcePos
ssBegin :: !SourcePos
  , SourceSpan -> SourcePos
ssEnd   :: !SourcePos
  }
  deriving (SourceSpan -> SourceSpan -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SourceSpan -> SourceSpan -> Bool
$c/= :: SourceSpan -> SourceSpan -> Bool
== :: SourceSpan -> SourceSpan -> Bool
$c== :: SourceSpan -> SourceSpan -> Bool
Eq, Int -> SourceSpan -> [Char] -> [Char]
[SourceSpan] -> [Char] -> [Char]
SourceSpan -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [SourceSpan] -> [Char] -> [Char]
$cshowList :: [SourceSpan] -> [Char] -> [Char]
show :: SourceSpan -> [Char]
$cshow :: SourceSpan -> [Char]
showsPrec :: Int -> SourceSpan -> [Char] -> [Char]
$cshowsPrec :: Int -> SourceSpan -> [Char] -> [Char]
Show)

instance Semigroup SourceSpan where
  SourceSpan
x <> :: SourceSpan -> SourceSpan -> SourceSpan
<> SourceSpan
y = SourceSpan -> SourceSpan -> SourceSpan
mappendSpan SourceSpan
x SourceSpan
y 

instance Monoid SourceSpan where
  mempty :: SourceSpan
mempty  = SourceSpan
junkSpan
  mappend :: SourceSpan -> SourceSpan -> SourceSpan
mappend = SourceSpan -> SourceSpan -> SourceSpan
mappendSpan

mappendSpan :: SourceSpan -> SourceSpan -> SourceSpan
mappendSpan :: SourceSpan -> SourceSpan -> SourceSpan
mappendSpan SourceSpan
s1 SourceSpan
s2
  | SourceSpan
s1 forall a. Eq a => a -> a -> Bool
== SourceSpan
junkSpan = SourceSpan
s2
  | SourceSpan
s2 forall a. Eq a => a -> a -> Bool
== SourceSpan
junkSpan = SourceSpan
s1
  | Bool
otherwise      = SourcePos -> SourcePos -> SourceSpan
SS (SourceSpan -> SourcePos
ssBegin SourceSpan
s1) (SourceSpan -> SourcePos
ssEnd SourceSpan
s2)

instance PPrint SourceSpan where
  pprint :: SourceSpan -> [Char]
pprint = SourceSpan -> [Char]
ppSourceSpan

ppSourceSpan :: SourceSpan -> String
ppSourceSpan :: SourceSpan -> [Char]
ppSourceSpan SourceSpan
s
  | Int
l1 forall a. Eq a => a -> a -> Bool
== Int
l2  = forall r. PrintfType r => [Char] -> r
printf [Char]
"%s:%d:%d-%d"        [Char]
f Int
l1 Int
c1 Int
c2
  | Bool
otherwise = forall r. PrintfType r => [Char] -> r
printf [Char]
"%s:(%d:%d)-(%d:%d)" [Char]
f Int
l1 Int
c1 Int
l2 Int
c2
  where
    ([Char]
f, Int
l1, Int
c1, Int
l2, Int
c2) = SourceSpan -> ([Char], Int, Int, Int, Int)
spanInfo SourceSpan
s

spanInfo :: SourceSpan -> (FilePath, Int, Int, Int, Int)
spanInfo :: SourceSpan -> ([Char], Int, Int, Int, Int)
spanInfo SourceSpan
s = (SourceSpan -> [Char]
f SourceSpan
s, SourceSpan -> Int
l1 SourceSpan
s, SourceSpan -> Int
c1 SourceSpan
s, SourceSpan -> Int
l2 SourceSpan
s, SourceSpan -> Int
c2 SourceSpan
s)
  where
    f :: SourceSpan -> [Char]
f      = SourceSpan -> [Char]
spanFile
    l1 :: SourceSpan -> Int
l1     = Pos -> Int
unPos forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcePos -> Pos
sourceLine   forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SourcePos
ssBegin
    c1 :: SourceSpan -> Int
c1     = Pos -> Int
unPos forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcePos -> Pos
sourceColumn forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SourcePos
ssBegin
    l2 :: SourceSpan -> Int
l2     = Pos -> Int
unPos forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcePos -> Pos
sourceLine   forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SourcePos
ssEnd
    c2 :: SourceSpan -> Int
c2     = Pos -> Int
unPos forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcePos -> Pos
sourceColumn forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SourcePos
ssEnd

--------------------------------------------------------------------------------
-- | Source Span Extraction
--------------------------------------------------------------------------------
readFileSpan :: SourceSpan -> IO String
--------------------------------------------------------------------------------
readFileSpan :: SourceSpan -> IO [Char]
readFileSpan SourceSpan
sp = SourceSpan -> [Char] -> [Char]
getSpan SourceSpan
sp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [Char]
readFile (SourceSpan -> [Char]
spanFile SourceSpan
sp)


spanFile :: SourceSpan -> FilePath
spanFile :: SourceSpan -> [Char]
spanFile = SourcePos -> [Char]
sourceName forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SourcePos
ssBegin

getSpan :: SourceSpan -> String -> String
getSpan :: SourceSpan -> [Char] -> [Char]
getSpan SourceSpan
sp
  | Bool
sameLine    = Int -> Int -> Int -> [Char] -> [Char]
getSpanSingle Int
l1 Int
c1 Int
c2
  | Bool
sameLineEnd = Int -> Int -> [Char] -> [Char]
getSpanSingleEnd Int
l1 Int
c1
  | Bool
otherwise   = Int -> Int -> [Char] -> [Char]
getSpanMulti  Int
l1 Int
l2
  where
    sameLine :: Bool
sameLine            = Int
l1 forall a. Eq a => a -> a -> Bool
== Int
l2
    sameLineEnd :: Bool
sameLineEnd         = Int
l1 forall a. Num a => a -> a -> a
+ Int
1 forall a. Eq a => a -> a -> Bool
== Int
l2 Bool -> Bool -> Bool
&& Int
c2 forall a. Eq a => a -> a -> Bool
== Int
1
    ([Char]
_, Int
l1, Int
c1, Int
l2, Int
c2) = SourceSpan -> ([Char], Int, Int, Int, Int)
spanInfo SourceSpan
sp


getSpanSingleEnd :: Int -> Int -> String -> String
getSpanSingleEnd :: Int -> Int -> [Char] -> [Char]
getSpanSingleEnd Int
l Int
c1
  = Int -> Int -> [Char] -> [Char]
highlightEnd Int
l Int
c1
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> a
safeHead [Char]
""
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> Int -> [a] -> [a]
getRange Int
l Int
l
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
lines

getSpanSingle :: Int -> Int -> Int -> String -> String
getSpanSingle :: Int -> Int -> Int -> [Char] -> [Char]
getSpanSingle Int
l Int
c1 Int
c2
  = Int -> Int -> Int -> [Char] -> [Char]
highlight Int
l Int
c1 Int
c2
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> a
safeHead [Char]
""
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> Int -> [a] -> [a]
getRange Int
l Int
l
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
lines

getSpanMulti :: Int -> Int -> String -> String
getSpanMulti :: Int -> Int -> [Char] -> [Char]
getSpanMulti Int
l1 Int
l2
  = Int -> [[Char]] -> [Char]
highlights Int
l1
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> Int -> [a] -> [a]
getRange Int
l1 Int
l2
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
lines

highlight :: Int -> Int -> Int -> String -> String
highlight :: Int -> Int -> Int -> [Char] -> [Char]
highlight Int
l Int
c1 Int
c2 [Char]
s = [[Char]] -> [Char]
unlines
  [ Int -> [Char] -> [Char]
cursorLine Int
l [Char]
s
  , forall a. Int -> a -> [a]
replicate (Int
12 forall a. Num a => a -> a -> a
+ Int
c1) Char
' ' forall a. Semigroup a => a -> a -> a
<> forall a. Int -> a -> [a]
replicate (Int
c2 forall a. Num a => a -> a -> a
- Int
c1) Char
'^'
  ]

highlightEnd :: Int -> Int -> String -> String
highlightEnd :: Int -> Int -> [Char] -> [Char]
highlightEnd Int
l Int
c1 [Char]
s = Int -> Int -> Int -> [Char] -> [Char]
highlight Int
l Int
c1 (Int
1 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
s') [Char]
s'
  where
    s' :: [Char]
s'              = [Char] -> [Char]
trimEnd [Char]
s

highlights :: Int -> [String] -> String
highlights :: Int -> [[Char]] -> [Char]
highlights Int
i [[Char]]
ls = [[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> [Char] -> [Char]
cursorLine [Int
i..] [[Char]]
ls

cursorLine :: Int -> String -> String
cursorLine :: Int -> [Char] -> [Char]
cursorLine Int
l = forall r. PrintfType r => [Char] -> r
printf [Char]
"%s|  %s" (Int -> [Char]
lineString Int
l)

lineString :: Int -> String
lineString :: Int -> [Char]
lineString Int
n = forall a. Int -> a -> [a]
replicate (Int
10 forall a. Num a => a -> a -> a
- Int
nD) Char
' ' forall a. Semigroup a => a -> a -> a
<> [Char]
nS
  where
    nS :: [Char]
nS       = forall a. Show a => a -> [Char]
show Int
n
    nD :: Int
nD       = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
nS

--------------------------------------------------------------------------------
-- | Source Span Construction
--------------------------------------------------------------------------------
posSpan :: SourcePos -> SourceSpan
--------------------------------------------------------------------------------
posSpan :: SourcePos -> SourceSpan
posSpan SourcePos
p = SourcePos -> SourcePos -> SourceSpan
SS SourcePos
p SourcePos
p

junkSpan :: SourceSpan
junkSpan :: SourceSpan
junkSpan = SourcePos -> SourceSpan
posSpan ([Char] -> SourcePos
initialPos [Char]
"unknown")

--------------------------------------------------------------------------------
-- | Usage Mode
--------------------------------------------------------------------------------
data Mode
  = Json
  | Cmdline
  | Server
  deriving (Mode -> Mode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Mode -> Mode -> Bool
$c/= :: Mode -> Mode -> Bool
== :: Mode -> Mode -> Bool
$c== :: Mode -> Mode -> Bool
Eq, Int -> Mode -> [Char] -> [Char]
[Mode] -> [Char] -> [Char]
Mode -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [Mode] -> [Char] -> [Char]
$cshowList :: [Mode] -> [Char] -> [Char]
show :: Mode -> [Char]
$cshow :: Mode -> [Char]
showsPrec :: Int -> Mode -> [Char] -> [Char]
$cshowsPrec :: Int -> Mode -> [Char] -> [Char]
Show)

--------------------------------------------------------------------------------
-- | Representing (unrecoverable) failures
--------------------------------------------------------------------------------
data UserError = Error
  { UserError -> [Char]
eMsg  :: !Text
  , UserError -> SourceSpan
eSpan :: !SourceSpan
  }
  deriving (Int -> UserError -> [Char] -> [Char]
[UserError] -> [Char] -> [Char]
UserError -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [UserError] -> [Char] -> [Char]
$cshowList :: [UserError] -> [Char] -> [Char]
show :: UserError -> [Char]
$cshow :: UserError -> [Char]
showsPrec :: Int -> UserError -> [Char] -> [Char]
$cshowsPrec :: Int -> UserError -> [Char] -> [Char]
Show, Typeable)

instance Located UserError where
  sourceSpan :: UserError -> SourceSpan
sourceSpan = UserError -> SourceSpan
eSpan

instance Exception [UserError]

--------------------------------------------------------------------------------
panic :: String -> SourceSpan -> a
--------------------------------------------------------------------------------
panic :: forall a. [Char] -> SourceSpan -> a
panic [Char]
msg SourceSpan
sp = forall a e. Exception e => e -> a
throw [[Char] -> SourceSpan -> UserError
Error [Char]
msg SourceSpan
sp]

--------------------------------------------------------------------------------
abort :: UserError -> b
--------------------------------------------------------------------------------
abort :: forall b. UserError -> b
abort UserError
e = forall a e. Exception e => e -> a
throw [UserError
e]

--------------------------------------------------------------------------------
mkError :: Text -> SourceSpan -> UserError
--------------------------------------------------------------------------------
mkError :: [Char] -> SourceSpan -> UserError
mkError = [Char] -> SourceSpan -> UserError
Error

--------------------------------------------------------------------------------
renderErrors :: Mode -> [UserError] -> IO Text
--------------------------------------------------------------------------------
renderErrors :: Mode -> [UserError] -> IO [Char]
renderErrors Mode
Json    [UserError]
es = forall (m :: * -> *) a. Monad m => a -> m a
return ([UserError] -> [Char]
renderErrorsJson [UserError]
es)
renderErrors Mode
Server  [UserError]
es = forall (m :: * -> *) a. Monad m => a -> m a
return ([UserError] -> [Char]
renderResultJson [UserError]
es)
renderErrors Mode
Cmdline [UserError]
es = [UserError] -> IO [Char]
renderErrorsText [UserError]
es

renderErrorsText :: [UserError] -> IO Text
renderErrorsText :: [UserError] -> IO [Char]
renderErrorsText [] =
  forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
""
renderErrorsText [UserError]
es = do
  [[Char]]
errs  <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM UserError -> IO [Char]
renderError [UserError]
es
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
L.intercalate [Char]
"\n" ([Char]
"Errors found!" forall a. a -> [a] -> [a]
: [[Char]]
errs)

renderError :: UserError -> IO Text
renderError :: UserError -> IO [Char]
renderError UserError
e = do
  let sp :: SourceSpan
sp   = forall a. Located a => a -> SourceSpan
sourceSpan UserError
e
  [Char]
snippet <- SourceSpan -> IO [Char]
readFileSpan SourceSpan
sp
  forall (m :: * -> *) a. Monad m => a -> m a
return   forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => [Char] -> r
printf [Char]
"%s: %s\n\n%s" (forall a. PPrint a => a -> [Char]
pprint SourceSpan
sp) (UserError -> [Char]
eMsg UserError
e) [Char]
snippet

renderErrorsJson :: [UserError] -> Text
renderErrorsJson :: [UserError] -> [Char]
renderErrorsJson [UserError]
es = [Char]
"RESULT\n" forall a. [a] -> [a] -> [a]
++ JSValue -> [Char]
showJSValue' (forall a. JSON a => a -> JSValue
showJSON [UserError]
es)

showJSValue'   :: JSValue -> Text
showJSValue' :: JSValue -> [Char]
showJSValue' JSValue
x = JSValue -> [Char] -> [Char]
showJSValue JSValue
x [Char]
""

renderResultJson :: [UserError] -> Text
renderResultJson :: [UserError] -> [Char]
renderResultJson [UserError]
es = JSValue -> [Char]
showJSValue' forall a b. (a -> b) -> a -> b
$ [([Char], JSValue)] -> JSValue
jObj
                    [ ([Char]
"types"  , [([Char], JSValue)] -> JSValue
jObj []    )
                    , ([Char]
"status" , forall {a}. [a] -> JSValue
status   [UserError]
es)
                    , ([Char]
"errors" , forall a. JSON a => a -> JSValue
showJSON [UserError]
es)
                    ]
  where
    status :: [a] -> JSValue
status []       = forall a. JSON a => a -> JSValue
showJSON ([Char]
"safe"   :: String)
    status [a]
_        = forall a. JSON a => a -> JSValue
showJSON ([Char]
"unsafe" :: String)


instance JSON UserError where
  readJSON :: JSValue -> Result UserError
readJSON     = forall a. HasCallStack => a
undefined
  showJSON :: UserError -> JSValue
showJSON UserError
err = [([Char], JSValue)] -> JSValue
jObj [ ([Char]
"start"  , forall a. JSON a => a -> JSValue
showJSON forall a b. (a -> b) -> a -> b
$ UserError -> SourcePos
start UserError
err)
                      , ([Char]
"stop"   , forall a. JSON a => a -> JSValue
showJSON forall a b. (a -> b) -> a -> b
$ UserError -> SourcePos
stop UserError
err )
                      , ([Char]
"message", forall a. JSON a => a -> JSValue
showJSON forall a b. (a -> b) -> a -> b
$ UserError -> [Char]
eMsg UserError
err )
                      ]
    where
      start :: UserError -> SourcePos
start    = SourceSpan -> SourcePos
ssBegin forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserError -> SourceSpan
eSpan
      stop :: UserError -> SourcePos
stop     = SourceSpan -> SourcePos
ssEnd   forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserError -> SourceSpan
eSpan

jObj :: [([Char], JSValue)] -> JSValue
jObj = JSObject JSValue -> JSValue
JSObject forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [([Char], a)] -> JSObject a
toJSObject

instance JSON SourcePos where
  readJSON :: JSValue -> Result SourcePos
readJSON    = forall a. HasCallStack => a
undefined
  showJSON :: SourcePos -> JSValue
showJSON SourcePos
sp = [([Char], JSValue)] -> JSValue
jObj [ ([Char]
"line"  , forall a. JSON a => a -> JSValue
showJSON (Pos -> Int
unPos Pos
l))
                     , ([Char]
"column", forall a. JSON a => a -> JSValue
showJSON (Pos -> Int
unPos Pos
c))
                     ]
    where
      l :: Pos
l       = SourcePos -> Pos
sourceLine   SourcePos
sp
      c :: Pos
c       = SourcePos -> Pos
sourceColumn SourcePos
sp