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
|
----------------------------------------------------------------------
-- |
-- Module : CheckM
-- Maintainer : (Maintainer)
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:22:33 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.5 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module GF.Infra.CheckM
(Check, CheckResult, Message, runCheck,
checkError, checkCond, checkWarn, checkWarnings, checkAccumError,
checkErr, checkIn, checkMap, checkMapRecover,
accumulateError
) where
import GF.Data.Operations
import GF.Infra.Ident
import GF.Grammar.Grammar(Context)
import GF.Grammar.Printer
import qualified Data.Map as Map
import Text.PrettyPrint
type Message = Doc
type Error = Message
type Warning = Message
--data Severity = Warning | Error
--type NonFatal = ([Severity,Message]) -- preserves order
type NonFatal = ([Error],[Warning])
type Accumulate acc ans = acc -> (acc,ans)
data CheckResult a = Fail Error | Success a
newtype Check a
= Check {unCheck :: Context -> Accumulate NonFatal (CheckResult a)}
instance Monad Check where
return x = Check $ \ctxt ws -> (ws,Success x)
f >>= g = Check $ \ctxt ws ->
case unCheck f ctxt ws of
(ws,Success x) -> unCheck (g x) ctxt ws
(ws,Fail msg) -> (ws,Fail msg)
instance ErrorMonad Check where
raise s = checkError (text s)
handle f h = handle' f (h . render)
handle' f h = Check (\ctxt msgs -> case unCheck f ctxt msgs of
(ws,Success x) -> (ws,Success x)
(ws,Fail msg) -> unCheck (h msg) ctxt ws)
-- | Report a fatal error
checkError :: Message -> Check a
checkError msg = Check (\ctxt ws -> (ws,Fail msg))
checkCond :: Message -> Bool -> Check ()
checkCond s b = if b then return () else checkError s
-- | warnings should be reversed in the end
checkWarn :: Message -> Check ()
checkWarn msg = Check $ \ctxt (es,ws) -> ((es,(text "Warning:" <+> msg) : ws),Success ())
checkWarnings = mapM_ checkWarn
-- | Report a nonfatal (accumulated) error
checkAccumError :: Message -> Check ()
checkAccumError msg = Check $ \ctxt (es,ws) -> ((msg:es,ws),Success ())
-- | Turn a fatal error into a nonfatal (accumulated) error
accumulateError :: (a -> Check a) -> a -> Check a
accumulateError chk a =
handle' (chk a) $ \ msg -> do checkAccumError msg; return a
-- | Run an error check, report errors and warnings
runCheck :: Check a -> Err (a,String)
runCheck c =
case unCheck c [] ([],[]) of
(([],ws),Success v) -> Ok (v, render (vcat (reverse ws)))
((es,ws),Success v) -> Bad ( render (vcat (reverse (es++ws))))
((es,ws),Fail msg) -> Bad ( render (vcat (reverse (msg:es++ws))))
checkMap :: (Ord a) => (a -> b -> Check b) -> Map.Map a b -> Check (Map.Map a b)
checkMap f map = do xs <- mapM (\(k,v) -> do v <- f k v
return (k,v)) (Map.toList map)
return (Map.fromAscList xs)
checkMapRecover :: (Ord a) => (a -> b -> Check b) -> Map.Map a b -> Check (Map.Map a b)
checkMapRecover f mp = do
let xs = map (\ (k,v) -> (k,runCheck (f k v))) (Map.toList mp)
case [s | (_,Bad s) <- xs] of
ss@(_:_) -> checkError (text (unlines ss))
_ -> do
let (kx,ss) = unzip [((k,x),s) | (k, Ok (x,s)) <- xs]
if not (all null ss) then checkWarn (text (unlines ss)) else return ()
return (Map.fromAscList kx)
checkErr :: Err a -> Check a
checkErr (Ok x) = return x
checkErr (Bad err) = checkError (text err)
checkIn :: Doc -> Check a -> Check a
checkIn msg c = Check $ \ctxt msgs0 ->
case unCheck c ctxt ([],[]) of
(msgs,Fail msg) -> (augment msgs0 msgs,Fail (augment1 msg))
(msgs,Success v) -> (augment msgs0 msgs,Success v)
where
augment (es0,ws0) (es,ws) = (augment' es0 es,augment' ws0 ws)
augment' msgs0 [] = msgs0
augment' msgs0 msgs' = (msg $$ nest 3 (vcat (reverse msgs'))):msgs0
augment1 msg' = msg $$ nest 3 msg'
|
