-- | 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 x = x

--------------------------------------------------------------------------------
-- | Source Span Representation
--------------------------------------------------------------------------------
data SourceSpan = SS
  { ssBegin :: !SourcePos
  , ssEnd   :: !SourcePos
  }
  deriving (Eq, Show)

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

instance Monoid SourceSpan where
  mempty  = junkSpan
  mappend = mappendSpan

mappendSpan :: SourceSpan -> SourceSpan -> SourceSpan
mappendSpan s1 s2
  | s1 == junkSpan = s2
  | s2 == junkSpan = s1
  | otherwise      = SS (ssBegin s1) (ssEnd s2)

instance PPrint SourceSpan where
  pprint = ppSourceSpan

ppSourceSpan :: SourceSpan -> String
ppSourceSpan s
  | l1 == l2  = printf "%s:%d:%d-%d"        f l1 c1 c2
  | otherwise = printf "%s:(%d:%d)-(%d:%d)" f l1 c1 l2 c2
  where
    (f, l1, c1, l2, c2) = spanInfo s

spanInfo :: SourceSpan -> (FilePath, Int, Int, Int, Int)
spanInfo s = (f s, l1 s, c1 s, l2 s, c2 s)
  where
    f      = spanFile
    l1     = unPos . sourceLine   . ssBegin
    c1     = unPos . sourceColumn . ssBegin
    l2     = unPos . sourceLine   . ssEnd
    c2     = unPos . sourceColumn . ssEnd

--------------------------------------------------------------------------------
-- | Source Span Extraction
--------------------------------------------------------------------------------
readFileSpan :: SourceSpan -> IO String
--------------------------------------------------------------------------------
readFileSpan sp = getSpan sp <$> readFile (spanFile sp)


spanFile :: SourceSpan -> FilePath
spanFile = sourceName . ssBegin

getSpan :: SourceSpan -> String -> String
getSpan sp
  | sameLine    = getSpanSingle l1 c1 c2
  | sameLineEnd = getSpanSingleEnd l1 c1
  | otherwise   = getSpanMulti  l1 l2
  where
    sameLine            = l1 == l2
    sameLineEnd         = l1 + 1 == l2 && c2 == 1
    (_, l1, c1, l2, c2) = spanInfo sp


getSpanSingleEnd :: Int -> Int -> String -> String
getSpanSingleEnd l c1
  = highlightEnd l c1
  . safeHead ""
  . getRange l l
  . lines

getSpanSingle :: Int -> Int -> Int -> String -> String
getSpanSingle l c1 c2
  = highlight l c1 c2
  . safeHead ""
  . getRange l l
  . lines

getSpanMulti :: Int -> Int -> String -> String
getSpanMulti l1 l2
  = highlights l1
  . getRange l1 l2
  . lines

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

highlightEnd :: Int -> Int -> String -> String
highlightEnd l c1 s = highlight l c1 (1 + length s') s'
  where
    s'              = trimEnd s

highlights :: Int -> [String] -> String
highlights i ls = unlines $ zipWith cursorLine [i..] ls

cursorLine :: Int -> String -> String
cursorLine l = printf "%s|  %s" (lineString l)

lineString :: Int -> String
lineString n = replicate (10 - nD) ' ' <> nS
  where
    nS       = show n
    nD       = length nS

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

junkSpan :: SourceSpan
junkSpan = posSpan (initialPos "unknown")

--------------------------------------------------------------------------------
-- | Usage Mode
--------------------------------------------------------------------------------
data Mode
  = Json
  | Cmdline
  | Server
  deriving (Eq, Show)

--------------------------------------------------------------------------------
-- | Representing (unrecoverable) failures
--------------------------------------------------------------------------------
data UserError = Error
  { eMsg  :: !Text
  , eSpan :: !SourceSpan
  }
  deriving (Show, Typeable)

instance Located UserError where
  sourceSpan = eSpan

instance Exception [UserError]

--------------------------------------------------------------------------------
panic :: String -> SourceSpan -> a
--------------------------------------------------------------------------------
panic msg sp = throw [Error msg sp]

--------------------------------------------------------------------------------
abort :: UserError -> b
--------------------------------------------------------------------------------
abort e = throw [e]

--------------------------------------------------------------------------------
mkError :: Text -> SourceSpan -> UserError
--------------------------------------------------------------------------------
mkError = Error

--------------------------------------------------------------------------------
renderErrors :: Mode -> [UserError] -> IO Text
--------------------------------------------------------------------------------
renderErrors Json    es = return (renderErrorsJson es)
renderErrors Server  es = return (renderResultJson es)
renderErrors Cmdline es = renderErrorsText es

renderErrorsText :: [UserError] -> IO Text
renderErrorsText [] =
  return ""
renderErrorsText es = do
  errs  <- mapM renderError es
  return $ L.intercalate "\n" ("Errors found!" : errs)

renderError :: UserError -> IO Text
renderError e = do
  let sp   = sourceSpan e
  snippet <- readFileSpan sp
  return   $ printf "%s: %s\n\n%s" (pprint sp) (eMsg e) snippet

renderErrorsJson :: [UserError] -> Text
renderErrorsJson es = "RESULT\n" ++ showJSValue' (showJSON es)

showJSValue'   :: JSValue -> Text
showJSValue' x = showJSValue x ""

renderResultJson :: [UserError] -> Text
renderResultJson es = showJSValue' $ jObj
                    [ ("types"  , jObj []    )
                    , ("status" , status   es)
                    , ("errors" , showJSON es)
                    ]
  where
    status []       = showJSON ("safe"   :: String)
    status _        = showJSON ("unsafe" :: String)


instance JSON UserError where
  readJSON     = undefined
  showJSON err = jObj [ ("start"  , showJSON $ start err)
                      , ("stop"   , showJSON $ stop err )
                      , ("message", showJSON $ eMsg err )
                      ]
    where
      start    = ssBegin . eSpan
      stop     = ssEnd   . eSpan

jObj = JSObject . toJSObject

instance JSON SourcePos where
  readJSON    = undefined
  showJSON sp = jObj [ ("line"  , showJSON (unPos l))
                     , ("column", showJSON (unPos c))
                     ]
    where
      l       = sourceLine   sp
      c       = sourceColumn sp