{-# LANGUAGE NoImplicitPrelude #-}

-- |
-- Errors used in dead call elimination.
module Language.PureScript.DCE.Errors
  ( EntryPoint (..)
  , showEntryPoint
  , isEntryParseError
  , DCEError(..)
  , displayDCEError
  , displayDCEWarning
  , Level(..)
  , warnColor
  , errorColor
  , codeColor
  , colorString
  , colorText
  )
  where

import           Prelude hiding (mod)
import           Data.Char (isLower, isUpper, isSpace)
import           Data.List (dropWhileEnd, findIndex, intersperse)
import           Data.Text (Text)
import qualified Data.Text as T
import           Formatting (sformat, string, stext, (%))
import           Language.PureScript.AST.SourcePos
                  ( SourceSpan(..)
                  , displaySourceSpan
                  )
import           Language.PureScript.Names
import           Language.PureScript.PSString
import           Language.PureScript.CoreFn.Ann
import qualified Text.PrettyPrint.Boxes as Box
import qualified System.Console.ANSI as ANSI

data EntryPoint
  = EntryPoint (Qualified Ident)
  | EntryModule ModuleName
  | EntryParseError String
  deriving Int -> EntryPoint -> ShowS
[EntryPoint] -> ShowS
EntryPoint -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [EntryPoint] -> ShowS
$cshowList :: [EntryPoint] -> ShowS
show :: EntryPoint -> [Char]
$cshow :: EntryPoint -> [Char]
showsPrec :: Int -> EntryPoint -> ShowS
$cshowsPrec :: Int -> EntryPoint -> ShowS
Show

isEntryParseError :: EntryPoint -> Bool
isEntryParseError :: EntryPoint -> Bool
isEntryParseError (EntryParseError [Char]
_) = Bool
True
isEntryParseError EntryPoint
_                   = Bool
False

showEntryPoint :: EntryPoint -> Text
showEntryPoint :: EntryPoint -> Text
showEntryPoint (EntryPoint Qualified Ident
qi) = forall a. (a -> Text) -> Qualified a -> Text
showQualified Ident -> Text
showIdent Qualified Ident
qi
showEntryPoint (EntryModule ModuleName
mn) = ModuleName -> Text
runModuleName ModuleName
mn
showEntryPoint (EntryParseError [Char]
s) = [Char] -> Text
T.pack [Char]
s

instance Read EntryPoint where
  readsPrec :: Int -> ReadS EntryPoint
readsPrec Int
_ [Char]
s
    | Just Int
idx <- forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (forall a. Eq a => a -> a -> Bool
== Char
':') [Char]
s
    = case forall a. Int -> [a] -> [a]
take Int
idx [Char]
s of
      [Char]
"ident"
        -> case forall a. [a] -> Maybe ([a], a)
unsnoc (Text -> Text -> [Text]
T.splitOn Text
"." ([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop (Int
idx forall a. Num a => a -> a -> a
+ Int
1) [Char]
s)) of
          Just ([Text]
as, Text
a)
            | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
as)
            , Bool
True <- Bool -> Bool
not (Text -> Bool
T.null Text
a)
            -> [(Qualified Ident -> EntryPoint
EntryPoint (forall a. a -> ModuleName -> Qualified a
mkQualified (Text -> Ident
Ident Text
a) (Text -> ModuleName
ModuleName forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"." [Text]
as)), [Char]
"")]
          Maybe ([Text], Text)
_ -> [([Char] -> EntryPoint
EntryParseError [Char]
s, [Char]
"")]
      [Char]
"module"
        -> case forall a. [a] -> Maybe ([a], a)
unsnoc (Text -> Text -> [Text]
T.splitOn Text
"." ([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop (Int
idx forall a. Num a => a -> a -> a
+ Int
1) [Char]
s)) of
          Just ([Text]
as, Text
a)
            | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
as)
            , Bool
True <- Bool -> Bool
not (Text -> Bool
T.null Text
a)
            , Bool
True <- Char -> Bool
isUpper (Text -> Char
T.head Text
a)
            -> [(ModuleName -> EntryPoint
EntryModule forall a b. (a -> b) -> a -> b
$ Text -> ModuleName
ModuleName forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"." ([Text]
as forall a. [a] -> [a] -> [a]
++ [Text
a]), [Char]
"")]
          Maybe ([Text], Text)
_ -> [([Char] -> EntryPoint
EntryParseError [Char]
s, [Char]
"")]
      [Char]
_ -> [([Char] -> EntryPoint
EntryParseError [Char]
s, [Char]
"")]
  readsPrec Int
_ [Char]
s
    = case forall a. [a] -> Maybe ([a], a)
unsnoc (Text -> Text -> [Text]
T.splitOn Text
"." ([Char] -> Text
T.pack [Char]
s)) of
      Just ([Text]
as, Text
a)
        | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
as)
        , Bool
True <- Bool -> Bool
not (Text -> Bool
T.null Text
a)
        , Bool
True <- Char -> Bool
isLower (Text -> Char
T.head Text
a)
          -> [(Qualified Ident -> EntryPoint
EntryPoint (forall a. a -> ModuleName -> Qualified a
mkQualified (Text -> Ident
Ident Text
a) (Text -> ModuleName
ModuleName forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"." [Text]
as)), [Char]
"")]
        | Bool
True <- Bool -> Bool
not (Text -> Bool
T.null Text
a)
          -> [(ModuleName -> EntryPoint
EntryModule forall a b. (a -> b) -> a -> b
$ Text -> ModuleName
ModuleName forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"." ([Text]
as forall a. [a] -> [a] -> [a]
++ [Text
a]), [Char]
"")]
        | Bool
otherwise
        -> [([Char] -> EntryPoint
EntryParseError [Char]
s, [Char]
"")]
      Maybe ([Text], Text)
Nothing -> [([Char] -> EntryPoint
EntryParseError [Char]
s, [Char]
"")]

unsnoc :: [a] -> Maybe ([a], a)
unsnoc :: forall a. [a] -> Maybe ([a], a)
unsnoc [] = forall a. Maybe a
Nothing
unsnoc [a]
as = forall a. a -> Maybe a
Just (forall a. [a] -> [a]
init [a]
as, forall a. [a] -> a
last [a]
as)

-- |
-- Error type shared by `dce` and `dceEval`.
data DCEError (a :: Level)
  = IdentifierNotFound ModuleName Ann (Qualified Ident)
  | ArrayIdxOutOfBound ModuleName Ann Integer
  | AccessorNotFound ModuleName Ann PSString
  | NoEntryPoint
  | EntryPointsNotParsed [String]
  | EntryPointsNotFound [EntryPoint]
  deriving (Int -> DCEError a -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
forall (a :: Level). Int -> DCEError a -> ShowS
forall (a :: Level). [DCEError a] -> ShowS
forall (a :: Level). DCEError a -> [Char]
showList :: [DCEError a] -> ShowS
$cshowList :: forall (a :: Level). [DCEError a] -> ShowS
show :: DCEError a -> [Char]
$cshow :: forall (a :: Level). DCEError a -> [Char]
showsPrec :: Int -> DCEError a -> ShowS
$cshowsPrec :: forall (a :: Level). Int -> DCEError a -> ShowS
Show)

data Level = Error | Warning deriving (Int -> Level -> ShowS
[Level] -> ShowS
Level -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Level] -> ShowS
$cshowList :: [Level] -> ShowS
show :: Level -> [Char]
$cshow :: Level -> [Char]
showsPrec :: Int -> Level -> ShowS
$cshowsPrec :: Int -> Level -> ShowS
Show)

getAnn :: DCEError a -> Maybe (ModuleName, SourceSpan)
getAnn :: forall (a :: Level). DCEError a -> Maybe (ModuleName, SourceSpan)
getAnn (IdentifierNotFound ModuleName
mn (SourceSpan
ss, [Comment]
_, Maybe SourceType
_, Maybe Meta
_) Qualified Ident
_) = forall a. a -> Maybe a
Just (ModuleName
mn, SourceSpan
ss)
getAnn (ArrayIdxOutOfBound ModuleName
mn (SourceSpan
ss, [Comment]
_, Maybe SourceType
_, Maybe Meta
_) Integer
_) = forall a. a -> Maybe a
Just (ModuleName
mn, SourceSpan
ss)
getAnn (AccessorNotFound ModuleName
mn (SourceSpan
ss, [Comment]
_, Maybe SourceType
_, Maybe Meta
_) PSString
_) = forall a. a -> Maybe a
Just (ModuleName
mn, SourceSpan
ss)
getAnn DCEError a
_ = forall a. Maybe a
Nothing

formatDCEError :: DCEError a -> Box.Box
formatDCEError :: forall (a :: Level). DCEError a -> Box
formatDCEError (IdentifierNotFound ModuleName
_ Ann
_ Qualified Ident
qi) =
          [Char] -> Box
Box.text [Char]
"Unknown value "
  Box -> Box -> Box
Box.<+> (ColorIntensity, Color, ConsoleIntensity) -> [Char] -> Box
colorBox (ColorIntensity, Color, ConsoleIntensity)
codeColor (Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. (a -> Text) -> Qualified a -> Text
showQualified Ident -> Text
runIdent Qualified Ident
qi)
  Box -> Box -> Box
Box.<> Box
"."
formatDCEError (ArrayIdxOutOfBound ModuleName
_ Ann
_ Integer
i) =
          [Char] -> Box
Box.text [Char]
"Array literal lacks required index"
  Box -> Box -> Box
Box.<+> (ColorIntensity, Color, ConsoleIntensity) -> [Char] -> Box
colorBox (ColorIntensity, Color, ConsoleIntensity)
codeColor (forall a. Show a => a -> [Char]
show Integer
i)
  Box -> Box -> Box
Box.<> Box
"."
formatDCEError (AccessorNotFound ModuleName
_ Ann
_ PSString
acc) =
          [Char] -> Box
Box.text [Char]
"Object literal lacks required label"
  Box -> Box -> Box
Box.<+> (ColorIntensity, Color, ConsoleIntensity) -> [Char] -> Box
colorBox (ColorIntensity, Color, ConsoleIntensity)
codeColor (Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ PSString -> Text
prettyPrintString PSString
acc)
  Box -> Box -> Box
Box.<> Box
"."
formatDCEError DCEError a
NoEntryPoint = Box
"No entry point given."
formatDCEError (EntryPointsNotParsed [[Char]]
eps) =
          [Char] -> Box
Box.text ([Char]
"Parsing error for entry point" forall a. [a] -> [a] -> [a]
++ if forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]]
eps forall a. Ord a => a -> a -> Bool
> Int
1 then [Char]
"s:" else [Char]
"")
  Box -> Box -> Box
Box.<+> forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Box -> Box -> Box
(Box.<>) (forall a. a -> [a] -> [a]
intersperse ([Char] -> Box
Box.text [Char]
", ")
            forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((ColorIntensity, Color, ConsoleIntensity) -> [Char] -> Box
colorBox (ColorIntensity, Color, ConsoleIntensity)
codeColor) [[Char]]
eps)
formatDCEError (EntryPointsNotFound [EntryPoint]
eps) =
          [Char] -> Box
Box.text ([Char]
"Entry point" forall a. [a] -> [a] -> [a]
++ if forall (t :: * -> *) a. Foldable t => t a -> Int
length [EntryPoint]
eps forall a. Ord a => a -> a -> Bool
> Int
1 then [Char]
"s:" else [Char]
"")
  Box -> Box -> Box
Box.<+> forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Box -> Box -> Box
(Box.<>) (forall a. a -> [a] -> [a]
intersperse ([Char] -> Box
Box.text [Char]
", ")
            forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((ColorIntensity, Color, ConsoleIntensity) -> [Char] -> Box
colorBox (ColorIntensity, Color, ConsoleIntensity)
codeColor forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntryPoint -> Text
showEntryPoint) [EntryPoint]
eps)
  Box -> Box -> Box
Box.<+> Box
"not found."

renderDCEError :: FilePath -> DCEError a -> Box.Box
renderDCEError :: forall (a :: Level). [Char] -> DCEError a -> Box
renderDCEError [Char]
relPath DCEError a
err =
  case forall (a :: Level). DCEError a -> Maybe (ModuleName, SourceSpan)
getAnn DCEError a
err of
    Just (ModuleName
mn, SourceSpan
ss) -> [Box] -> Box
paras
      [ [Char] -> Box
Box.text [Char]
"in module"
          Box -> Box -> Box
Box.<+> (ColorIntensity, Color, ConsoleIntensity) -> [Char] -> Box
colorBox (ColorIntensity, Color, ConsoleIntensity)
codeColor (Text -> [Char]
T.unpack (ModuleName -> Text
runModuleName ModuleName
mn))
      , Text -> Box
line forall a b. (a -> b) -> a -> b
$ Text
"at " forall a. Semigroup a => a -> a -> a
<> [Char] -> SourceSpan -> Text
displaySourceSpan [Char]
relPath SourceSpan
ss
      , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (a :: Level). DCEError a -> Box
formatDCEError DCEError a
err
      ]
    Maybe (ModuleName, SourceSpan)
Nothing -> [Box] -> Box
paras [ forall (a :: Level). DCEError a -> Box
formatDCEError DCEError a
err ]

displayDCEError :: FilePath -> DCEError 'Error -> String
displayDCEError :: [Char] -> DCEError 'Error -> [Char]
displayDCEError [Char]
relPath DCEError 'Error
err = Box -> [Char]
renderBox forall a b. (a -> b) -> a -> b
$ [Box] -> Box
paras
  [ (ColorIntensity, Color, ConsoleIntensity) -> [Char] -> Box
colorBox (ColorIntensity, Color, ConsoleIntensity)
errorColor [Char]
"Error"
  , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (a :: Level). [Char] -> DCEError a -> Box
renderDCEError [Char]
relPath DCEError 'Error
err
  ]

displayDCEWarning :: FilePath -> (Int, Int) ->  DCEError 'Warning -> String
displayDCEWarning :: [Char] -> (Int, Int) -> DCEError 'Warning -> [Char]
displayDCEWarning [Char]
relPath (Int
idx, Int
count) DCEError 'Warning
err = Box -> [Char]
renderBox forall a b. (a -> b) -> a -> b
$ [Box] -> Box
paras
  [ (ColorIntensity, Color, ConsoleIntensity) -> [Char] -> Box
colorBox (ColorIntensity, Color, ConsoleIntensity)
warnColor [Char]
"Warning"
      Box -> Box -> Box
Box.<+> [Char] -> Box
Box.text (forall a. Show a => a -> [Char]
show Int
idx forall a. [a] -> [a] -> [a]
++ [Char]
" of " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
count)
  , Box -> Box
indent forall a b. (a -> b) -> a -> b
$ forall (a :: Level). [Char] -> DCEError a -> Box
renderDCEError [Char]
relPath DCEError 'Warning
err
  ]

paras :: [Box.Box] -> Box.Box
paras :: [Box] -> Box
paras = forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
Box.vcat Alignment
Box.left

line :: Text -> Box.Box
line :: Text -> Box
line = [Char] -> Box
Box.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack

renderBox :: Box.Box -> String
renderBox :: Box -> [Char]
renderBox = [[Char]] -> [Char]
unlines
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace)
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile [Char] -> Bool
whiteSpace
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd [Char] -> Bool
whiteSpace
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
lines
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. Box -> [Char]
Box.render
  where
  whiteSpace :: [Char] -> Bool
whiteSpace = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace

indent :: Box.Box -> Box.Box
indent :: Box -> Box
indent = Int -> Box -> Box
Box.moveUp Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Box -> Box
Box.moveDown Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Box -> Box
Box.moveRight Int
2

ansiColor :: (ANSI.ColorIntensity, ANSI.Color, ANSI.ConsoleIntensity) -> String
ansiColor :: (ColorIntensity, Color, ConsoleIntensity) -> [Char]
ansiColor (ColorIntensity
colorIntensity, Color
color, ConsoleIntensity
consoleIntensity) = [SGR] -> [Char]
ANSI.setSGRCode
  [ ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Foreground ColorIntensity
colorIntensity Color
color
  , ConsoleIntensity -> SGR
ANSI.SetConsoleIntensity ConsoleIntensity
consoleIntensity
  ]

ansiColorReset :: String
ansiColorReset :: [Char]
ansiColorReset = [SGR] -> [Char]
ANSI.setSGRCode [SGR
ANSI.Reset]

errorColor :: (ANSI.ColorIntensity, ANSI.Color, ANSI.ConsoleIntensity)
errorColor :: (ColorIntensity, Color, ConsoleIntensity)
errorColor = (ColorIntensity
ANSI.Dull, Color
ANSI.Red, ConsoleIntensity
ANSI.BoldIntensity)

warnColor :: (ANSI.ColorIntensity, ANSI.Color, ANSI.ConsoleIntensity)
warnColor :: (ColorIntensity, Color, ConsoleIntensity)
warnColor = (ColorIntensity
ANSI.Dull, Color
ANSI.Yellow, ConsoleIntensity
ANSI.BoldIntensity)

codeColor :: (ANSI.ColorIntensity, ANSI.Color, ANSI.ConsoleIntensity)
codeColor :: (ColorIntensity, Color, ConsoleIntensity)
codeColor = (ColorIntensity
ANSI.Dull, Color
ANSI.Yellow, ConsoleIntensity
ANSI.NormalIntensity)

colorString
  :: (ANSI.ColorIntensity, ANSI.Color, ANSI.ConsoleIntensity)
  -> String
  -> String
colorString :: (ColorIntensity, Color, ConsoleIntensity) -> ShowS
colorString (ColorIntensity, Color, ConsoleIntensity)
color [Char]
s = (ColorIntensity, Color, ConsoleIntensity) -> [Char]
ansiColor (ColorIntensity, Color, ConsoleIntensity)
color forall a. [a] -> [a] -> [a]
++ [Char]
s forall a. [a] -> [a] -> [a]
++ [Char]
ansiColorReset

colorText
  :: (ANSI.ColorIntensity, ANSI.Color, ANSI.ConsoleIntensity)
  -> Text
  -> Text
colorText :: (ColorIntensity, Color, ConsoleIntensity) -> Text -> Text
colorText (ColorIntensity, Color, ConsoleIntensity)
color Text
t = forall a. Format Text a -> a
sformat
  (forall r. Format r ([Char] -> r)
stringforall r a r'. Format r a -> Format r' r -> Format r' a
%forall r. Format r (Text -> r)
stextforall r a r'. Format r a -> Format r' r -> Format r' a
%forall r. Format r ([Char] -> r)
string) ((ColorIntensity, Color, ConsoleIntensity) -> [Char]
ansiColor (ColorIntensity, Color, ConsoleIntensity)
color) Text
t [Char]
ansiColorReset

colorBox
  :: (ANSI.ColorIntensity, ANSI.Color, ANSI.ConsoleIntensity)
  -> String
  -> Box.Box
colorBox :: (ColorIntensity, Color, ConsoleIntensity) -> [Char] -> Box
colorBox (ColorIntensity, Color, ConsoleIntensity)
color = [Char] -> Box
Box.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ColorIntensity, Color, ConsoleIntensity) -> ShowS
colorString (ColorIntensity, Color, ConsoleIntensity)
color