~jojo/Carth

ref: 749208029494a7c48ce04444a513424f4b998416 Carth/src/Err.hs -rw-r--r-- 5.1 KiB
74920802JoJo update TODO 6 months ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
{-# LANGUAGE DataKinds #-}

module Err (module Err, TypeErr(..), GenErr(..)) where

import Text.Megaparsec (match)

import Misc
import SrcPos
import TypeAst
import qualified Parsed
import Inferred
import Pretty
import Lex
import Gen


type Message = String

printMacroErr :: (SrcPos, String) -> IO ()
printMacroErr (p, msg) = posd p msg

printParseErr :: (SrcPos, String) -> IO ()
printParseErr (p, msg) = posd p msg

printTypeErr :: TypeErr -> IO ()
printTypeErr = \case
    MainNotDefined -> putStrLn "Error: main not defined"
    InvalidUserTypeSig p s1 s2 ->
        posd p
            $ ("Invalid user type signature " ++ pretty s1)
            ++ (", expected " ++ pretty s2)
    CtorArityMismatch p c arity nArgs ->
        posd p
            $ ("Arity mismatch for constructor `" ++ c)
            ++ ("` in pattern.\nExpected " ++ show arity)
            ++ (", found " ++ show nArgs)
    ConflictingPatVarDefs p v ->
        posd p $ "Conflicting definitions for variable `" ++ v ++ "` in pattern."
    UndefCtor p c -> posd p $ "Undefined constructor `" ++ c ++ "`"
    UndefVar p v -> posd p $ "Undefined variable `" ++ v ++ "`"
    InfType p t1 t2 a t ->
        posd p
            $ "Infinite type: "
            ++ (pretty a ++ " ~ " ++ pretty t)
            ++ ("\nExpected type: " ++ pretty t1)
            ++ ("\nFound type: " ++ pretty t2)
    UnificationFailed p t1 t2 t'1 t'2 ->
        posd p
            $ ("Couldn't match type " ++ pretty t'2 ++ " with " ++ pretty t'1)
            ++ (".\nExpected type: " ++ pretty t1)
            ++ (".\nFound type: " ++ pretty t2 ++ ".")
    ConflictingTypeDef p x -> posd p $ "Conflicting definitions for type `" ++ x ++ "`."
    ConflictingCtorDef p x ->
        posd p $ "Conflicting definitions for constructor `" ++ x ++ "`."
    RedundantCase p -> posd p $ "Redundant case in pattern match."
    InexhaustivePats p patStr ->
        posd p $ "Inexhaustive patterns: " ++ patStr ++ " not covered."
    ExternNotMonomorphic name tv -> case tv of
        TVExplicit (Parsed.Id (WithPos p tv')) ->
            posd p
                $ ("Extern " ++ pretty name ++ " is not monomorphic. ")
                ++ ("Type variable " ++ tv' ++ " encountered in type signature")
        TVImplicit _ -> ice "TVImplicit in prettyErr ExternNotMonomorphic"
    FoundHole p -> posd p $ "Found hole"
    RecTypeDef x p ->
        posd p
            $ ("Type `" ++ x ++ "` ")
            ++ "has infinite size due to recursion without indirection.\n"
            ++ "Insert a pointer at some point to make it representable."
    UndefType p x -> posd p $ "Undefined type `" ++ x ++ "`."
    UnboundTVar p ->
        posd p
            $ "Could not fully infer type of expression.\n"
            ++ "Type annotations needed."
    WrongMainType p s ->
        posd p
            $ "Incorrect type of `main`.\n"
            ++ ("Expected: " ++ pretty (mainType :: Type))
            ++ ("\nFound: " ++ pretty s)
    RecursiveVarDef (WithPos p x) ->
        posd p $ ("Non-function variable definition `" ++ x ++ "` is recursive.")
    TypeInstArityMismatch p t expected found ->
        posd p
            $ ("Arity mismatch for instantiation of type `" ++ t)
            ++ ("`.\nExpected " ++ show expected)
            ++ (", found " ++ show found)
    ConflictingVarDef p x ->
        posd p $ "Conflicting definitions for variable `" ++ x ++ "`."

printGenErr :: GenErr -> IO ()
printGenErr = \case
    TransmuteErr p (t, sizet) (u, sizeu) ->
        posd p
            $ "Cannot transmute between types of different sizes."
            ++ ("\nSource type: " ++ pretty t)
            ++ (" (" ++ show sizet ++ " bytes)")
            ++ ("\nTarget type: " ++ pretty u)
            ++ (" (" ++ show sizeu ++ " bytes)")
    CastErr p t u -> posd p $ "Cannot cast " ++ pretty t ++ " to " ++ pretty u
    NoBuiltinVirtualInstance p x t ->
        posd p
            $ ("Builtin virtual function " ++ x)
            ++ (" cannot be instantiated to type " ++ pretty t)

posd :: SrcPos -> Message -> IO ()
posd = posd' "Error"

posd' :: String -> SrcPos -> Message -> IO ()
posd' kind (pos@(SrcPos f lineN colN inExp)) msg = do
    src <- readFile f
    let (lineN', colN') = (fromIntegral lineN, fromIntegral colN)
        lines' = lines src
        line = if (lineN' <= length lines')
            then lines' !! (lineN' - 1)
            else ice "line num in SourcePos is greater than num of lines in src"
        rest = if (colN' <= length line)
            then drop (colN' - 1) line
            else
                ice $ "col num in SourcePos is greater than " ++ "num of cols in src line"
        lineNS = show lineN'
        pad = length lineNS + 1
        s = either (const rest) fst (parse' (match tokentree) "" rest)
    putStrLn $ unlines
        [ prettySrcPos pos ++ ": " ++ kind ++ ":"
        , indent pad ++ "|"
        , lineNS ++ " | " ++ line
        -- Find the span (end-pos) of the item in the source by applying the same
        -- parser that gave the item, starting at its SourcePos
        , indent pad ++ "|" ++ indent (colN') ++ replicate (length s) '^'
        , msg
        ]
    maybe (pure ()) (\pos2 -> posd' "Note" pos2 "In expansion of macro.") inExp