never executed always true always false
1 module Conjure.UI.ErrorDisplay where
2
3 import Conjure.Language.AST.ASTParser
4 import Conjure.Language.AST.Reformer
5 import Conjure.Language.AST.Syntax
6 import Conjure.Language.Lexemes
7 import Conjure.Language.Lexer
8 import Conjure.Language.Pretty
9 import Conjure.Language.Validator
10 import Conjure.Prelude
11 import Data.Data
12 import Data.Map.Strict (assocs)
13 import qualified Data.Set as Set
14 import qualified Data.Text
15 import qualified Data.Text as T
16 import Text.Megaparsec
17
18 type Parser t = Parsec DiagnosticForPrint Text t
19
20 data DiagnosticForPrint = DiagnosticForPrint
21 { dStart :: Int,
22 dLength :: Int,
23 dMessage :: Diagnostic
24 }
25 deriving (Show, Eq, Ord)
26
27 instance ShowErrorComponent DiagnosticForPrint where
28 errorComponentLen (DiagnosticForPrint {dLength = l}) = l
29
30 showErrorComponent DiagnosticForPrint {dMessage = message} = case message of
31 Error et -> displayError et
32 Warning wt -> displayWarning wt
33 Info it -> "Info: " ++ show it
34
35 tokenErrorToDisplay :: LToken -> String
36 tokenErrorToDisplay (RealToken _) = error "tokenError with valid token"
37 tokenErrorToDisplay (SkippedToken t) = "Unexpected " ++ lexemeFace (lexeme t)
38 tokenErrorToDisplay (MissingToken (lexeme -> l)) =
39 "Missing " ++ case l of
40 L_Missing s -> show s
41 LMissingIdentifier -> "<identifier>"
42 _ -> T.unpack $ lexemeText l
43
44 displayWarning :: WarningType -> String
45 displayWarning (UnclassifiedWarning txt) = "Warning: " ++ T.unpack txt
46 displayWarning AmbiguousTypeWarning = "Ambiguous type occurred"
47
48 displayError :: ErrorType -> String
49 displayError x = case x of
50 TokenError lt -> tokenErrorToDisplay lt
51 SyntaxError txt -> "Syntax Error: " ++ T.unpack txt
52 SemanticError txt -> "Error: " ++ T.unpack txt
53 CustomError txt -> "Error: " ++ T.unpack txt
54 TypeError expected got -> "Type error:\n\tExpected: " ++ show (pretty expected) ++ "\n\tGot: " ++ show (pretty got)
55 ComplexTypeError msg ty -> "Type error:\n\tExpected: " ++ show msg ++ "\n\tGot: " ++ show (pretty ty)
56 SkippedTokens -> "Skipped tokens"
57 UnexpectedArg -> "Unexpected argument"
58 MissingArgsError expected got -> "Insufficient args, expected " ++ show expected ++ " got " ++ show got
59 InternalError -> "Pattern match failiure"
60 InternalErrorS txt -> "Something went wrong: " ++ T.unpack txt
61 WithReplacements e alts -> displayError e ++ "\n\tValid alternatives: " ++ intercalate "," (show <$> alts)
62 KindError a b -> show $ "Tried to use a " <> pretty b <> " where " <> pretty a <> " was expected"
63 CategoryError categ reason -> show $ "Cannot use variable of category :" <+> pretty categ <+> "in the context of " <> pretty reason
64
65 showDiagnosticsForConsole :: [ValidatorDiagnostic] -> Maybe String -> Text -> String
66 showDiagnosticsForConsole errs fileName text =
67 case runParser (captureErrors errs) (fromMaybe "Errors" fileName) text of
68 Left peb -> errorBundlePretty peb
69 Right _ -> "No printable errors from :" ++ (show . length $ errs)
70
71 printSymbolTable :: SymbolTable -> IO ()
72 printSymbolTable tab = putStrLn "Symbol table" >> mapM_ printEntry (assocs tab)
73 where
74 printEntry :: (Text, SymbolTableValue) -> IO ()
75 printEntry (a, (_, c, t)) = putStrLn $ T.unpack a ++ ":" ++ show (pretty t) ++ if c then " Enum" else ""
76
77 captureErrors :: [ValidatorDiagnostic] -> Parser ()
78 captureErrors = mapM_ captureError . collapseSkipped . removeAmbiguousTypeWarning
79
80 -- Remove these warnings from a console print of errors as they are just clutter
81 removeAmbiguousTypeWarning :: [ValidatorDiagnostic] -> [ValidatorDiagnostic]
82 removeAmbiguousTypeWarning =
83 filter
84 ( \(ValidatorDiagnostic _ x) ->
85 case x of
86 Warning AmbiguousTypeWarning -> False
87 _ -> True
88 )
89
90 collapseSkipped :: [ValidatorDiagnostic] -> [ValidatorDiagnostic]
91 collapseSkipped [] = []
92 collapseSkipped [x] = [x]
93 collapseSkipped ((ValidatorDiagnostic regx ex) : (ValidatorDiagnostic regy ey) : rs)
94 | isSkipped ex && isSkipped ey && sameLine (drSourcePos regx) (drSourcePos regy) =
95 collapseSkipped $ ValidatorDiagnostic (catDr regx regy) (Error $ SkippedTokens) : rs
96 where
97 isSkipped (Error (TokenError (SkippedToken _))) = True
98 isSkipped (Error SkippedTokens) = True
99 isSkipped _ = False
100 sameLine :: SourcePos -> SourcePos -> Bool
101 sameLine (SourcePos _ l1 _) (SourcePos _ l2 _) = l1 == l2
102 catDr :: DiagnosticRegion -> DiagnosticRegion -> DiagnosticRegion
103 catDr (DiagnosticRegion sp _ o _) (DiagnosticRegion _ en _ _) = DiagnosticRegion sp en o (unPos (sourceColumn en) - unPos (sourceColumn sp))
104 collapseSkipped (x : xs) = x : collapseSkipped xs
105
106 captureError :: ValidatorDiagnostic -> Parser ()
107 captureError (ValidatorDiagnostic reg message) | reg == global = do
108 let printError = DiagnosticForPrint 0 0 message
109 registerFancyFailure (Set.singleton (ErrorCustom printError))
110 captureError (ValidatorDiagnostic area message) = do
111 setOffset $ drOffset area
112 let printError = DiagnosticForPrint (drOffset area) (drLength area) message
113 registerFancyFailure (Set.singleton (ErrorCustom printError))
114
115 val :: String -> String -> IO ()
116 val path s = do
117 let str = s
118 let other = []
119 let txt = Data.Text.pack str
120 let lexed = runLexer txt (Just path)
121 let stream = fromRight (ETokenStream txt other) lexed
122 let (ETokenStream _ toks) = stream
123 putStrLn $ concatMap (T.unpack . capture) toks
124
125 -- parseTest parseProgram stream
126 let progStruct = runParser parseProgram "TEST" stream
127
128 case progStruct of
129 Left _ -> putStrLn "error"
130 Right p@(ProgramTree {}) ->
131 let qpr = runValidator (validateModel p) (initialState p (Just txt)) {typeChecking = True}
132 in case qpr of
133 (model, vds, st) -> do
134 print (show model)
135 print vds
136 printSymbolTable $ symbolTable st
137 print (regionInfo st)
138 putStrLn $ showDiagnosticsForConsole vds Nothing txt
139 print (reformList $ flatten p)
140 print p
141
142 valFile :: String -> IO ()
143 valFile p = do
144 path <- readFileIfExists p
145 case path of
146 Nothing -> putStrLn "NO such file"
147 Just s -> val p s
148 return ()
149
150
151 withParseTree :: String -> (ProgramTree -> IO ()) -> IO ()
152 withParseTree pa f = do
153 fil <- readFileIfExists pa
154 case runParser parseProgram "TEST" (fromRight (error "bad") $ runLexer (maybe "" T.pack fil) Nothing) of
155 Left _ -> error "bad"
156 Right pt -> void $ f pt
157
158 listBounds :: Int -> Int -> ProgramTree -> IO ()
159 listBounds a b t = do
160 let hlt = makeTree t
161 sequence_ [print $ toConstr t' | x@(HLTagged t' _) <- universe hlt, contains (SourcePos "" (mkPos a) (mkPos b)) x]