msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

refactor GF.Infra.CheckM and use the CheckM monad in the renamer as well

Browse Source
This commit is contained in:
krasimir
2009-10-02 22:52:14 +00:00
parent 8e79954861
commit d64419f2f2
5 changed files with 251 additions and 330 deletions
Download Patch File Download Diff File Expand all files Collapse all files

62
src/GF/Infra/CheckM.hs
View File

@@ -14,9 +14,8 @@
module GF.Infra.CheckM
(Check, Message, runCheck,
checkError, checkCond, checkWarn, checkUpdate, checkInContext,
checkUpdates, checkReset, checkResets, checkGetContext,
checkLookup, checkErr, checkIn, checkMap
checkError, checkCond, checkWarn,
checkErr, checkIn, checkMap
) where
import GF.Data.Operations
@@ -29,21 +28,21 @@ import Text.PrettyPrint
type Message = Doc
data CheckResult a
= Fail [Message]
| Success a Context [Message]
= Fail [Message]
| Success a [Message]
newtype Check a = Check {unCheck :: Context -> [Message] -> CheckResult a}
instance Monad Check where
return x = Check (\ctxt msgs -> Success x ctxt msgs)
return x = Check (\ctxt msgs -> Success x msgs)
f >>= g = Check (\ctxt msgs -> case unCheck f ctxt msgs of
Success x ctxt msgs -> unCheck (g x) ctxt msgs
Fail msgs -> Fail msgs)
Success x msgs -> unCheck (g x) ctxt msgs
Fail msgs -> Fail msgs)
instance ErrorMonad Check where
raise s = checkError (text s)
handle f h = Check (\ctxt msgs -> case unCheck f ctxt msgs of
Success x ctxt msgs -> Success x ctxt msgs
Fail (msg:msgs) -> unCheck (h (render msg)) ctxt msgs)
Success x msgs -> Success x msgs
Fail (msg:msgs) -> unCheck (h (render msg)) ctxt msgs)
checkError :: Message -> Check a
checkError msg = Check (\ctxt msgs -> Fail (msg : msgs))
@@ -53,42 +52,13 @@ checkCond s b = if b then return () else checkError s
-- | warnings should be reversed in the end
checkWarn :: Message -> Check ()
checkWarn msg = Check (\ctxt msgs -> Success () ctxt ((text "Warning:" <+> msg) : msgs))
checkWarn msg = Check (\ctxt msgs -> Success () ((text "Warning:" <+> msg) : msgs))
checkUpdate :: Hypo -> Check ()
checkUpdate d = Check (\ctxt msgs -> Success () (d:ctxt) msgs)
checkInContext :: [Hypo] -> Check r -> Check r
checkInContext g ch = do
i <- checkUpdates g
r <- ch
checkResets i
return r
checkUpdates :: [Hypo] -> Check Int
checkUpdates ds = mapM checkUpdate ds >> return (length ds)
checkReset :: Check ()
checkReset = checkResets 1
checkResets :: Int -> Check ()
checkResets i = Check (\ctxt msgs -> Success () (drop i ctxt) msgs)
checkGetContext :: Check Context
checkGetContext = Check (\ctxt msgs -> Success ctxt ctxt msgs)
checkLookup :: Ident -> Check Type
checkLookup x = do
co <- checkGetContext
case [ty | (b,y,ty) <- co, x == y] of
[] -> checkError (text "unknown variable" <+> ppIdent x)
(ty:_) -> return ty
runCheck :: Check a -> Either [Message] (a,Context,[Message])
runCheck :: Check a -> Err (a,String)
runCheck c =
case unCheck c [] [] of
Fail msgs -> Left msgs
Success v ctxt msgs -> Right (v,ctxt,msgs)
Fail msgs -> Bad ( render (vcat (reverse msgs)))
Success v msgs -> Ok (v, render (vcat (reverse msgs)))
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
@@ -102,6 +72,6 @@ checkErr (Bad err) = checkError (text err)
checkIn :: Doc -> Check a -> Check a
checkIn msg c = Check $ \ctxt msgs ->
case unCheck c ctxt [] of
Fail msgs' -> Fail ((msg $$ nest 3 (vcat (reverse msgs'))) : msgs)
Success v ctxt' msgs' | null msgs' -> Success v ctxt' msgs
| otherwise -> Success v ctxt' ((msg $$ nest 3 (vcat (reverse msgs'))) : msgs)
Fail msgs' -> Fail ((msg $$ nest 3 (vcat (reverse msgs'))) : msgs)
Success v msgs' | null msgs' -> Success v msgs
| otherwise -> Success v ((msg $$ nest 3 (vcat (reverse msgs'))) : msgs)