Diagnostic.hs

module Editor.Diagnostic where

import Brick (EventM, get)
import Brick.Types (modify)
import Control.Monad.IO.Class (liftIO)
import Data.List (find)
import Editor.Core (Diagnostic (..), EditorState, esDiagnostics)
import Editor.Util
import Lens.Micro
import UI.Core (EditorEventEnv (..), Name, envEditorState)
import Zwirn.Language (Predicate (..), TypeError (..))
import Zwirn.Language.Compiler
import Zwirn.Language.LSP.Diagnostics (validateCode)
import Zwirn.Language.Location

diagnoseEvent :: EventM Name EditorEventEnv ()
diagnoseEvent = do
  (EditorEventEnv _ _ _ _ env es) <- get
  ds <- liftIO $ getDiagnostics es env
  modify $ envEditorState %~ esDiagnostics .~ ds

getDiagnostics :: EditorState -> Environment -> IO [Diagnostic]
getDiagnostics es env = toDiagnostic <$> validateCode env (getContent es)

toDiagnostic :: Maybe ErrorType -> [Diagnostic]
toDiagnostic (Just (ParseErr msg (RealSrcLoc _ sr sc er ec))) = [Diagnostic ((sr, sc - 1), (er, ec - 1)) msg]
toDiagnostic (Just err@(TypeErr (NoInstance (Located (SrcLoc (RealSrcLoc _ sr sc er ec)) (IsIn _ _))))) = [Diagnostic ((sr, sc - 1), (er, ec - 1)) (show err)]
toDiagnostic (Just err@(TypeErr (UnboundVariable (Located (SrcLoc (RealSrcLoc _ sr sc er ec)) _)))) = [Diagnostic ((sr, sc - 1), (er, ec - 2)) (show err)]
toDiagnostic (Just err@(TypeErr (UnificationFail (Located (SrcLoc (RealSrcLoc _ sr sc er ec)) _)))) = [Diagnostic ((sr, sc - 1), (er, ec - 1)) (show err)]
toDiagnostic (Just (ManyErr errs)) = concatMap (toDiagnostic . Just) errs
toDiagnostic _ = []

rowDiagnostics :: Int -> [Diagnostic] -> [Diagnostic]
rowDiagnostics row = filter (\(Diagnostic ((r1, _), (r2, _)) _) -> r1 <= row && row <= r2)

inDiagnostic :: (Int, Int) -> Diagnostic -> Bool
inDiagnostic p (Diagnostic (x, y) _) = inSpan p x y

inAnyDiagnostic :: (Int, Int) -> [Diagnostic] -> Bool
inAnyDiagnostic = any . inDiagnostic

getAnyDiagnostic :: (Int, Int) -> [Diagnostic] -> Maybe Diagnostic
getAnyDiagnostic p = find (inDiagnostic p)