module GF.Infra.CheckM
(Check, CheckResult, Message, runCheck, runCheck',
checkError, checkCond, checkWarn, checkWarnings, checkAccumError,
checkIn, checkInModule, checkMap, checkMapRecover,
parallelCheck, accumulateError, commitCheck,
) where
import Prelude hiding ((<>))
import GF.Data.Operations
import GF.Infra.Location(ppLocation,sourcePath)
import GF.Infra.Option(Options,noOptions,verbAtLeast,Verbosity(..))
import qualified Data.Map as Map
import GF.Text.Pretty
import System.FilePath(makeRelative)
import Control.Parallel.Strategies(parList,rseq,using)
import Control.Monad(liftM,ap)
import Control.Applicative(Applicative(..))
import qualified Control.Monad.Fail as Fail
type Message = Doc
type Error = Message
type Warning = Message
type NonFatal = ([Error],[Warning])
type Accumulate acc ans = acc -> (acc,ans)
data CheckResult a = Fail Error | Success a
newtype Check a
= Check {Check a -> Accumulate NonFatal (CheckResult a)
unCheck :: Accumulate NonFatal (CheckResult a)}
instance Functor Check where fmap :: (a -> b) -> Check a -> Check b
fmap = (a -> b) -> Check a -> Check b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
instance Monad Check where
return :: a -> Check a
return a
x = Accumulate NonFatal (CheckResult a) -> Check a
forall a. Accumulate NonFatal (CheckResult a) -> Check a
Check (Accumulate NonFatal (CheckResult a) -> Check a)
-> Accumulate NonFatal (CheckResult a) -> Check a
forall a b. (a -> b) -> a -> b
$ \ NonFatal
ws -> (NonFatal
ws,a -> CheckResult a
forall a. a -> CheckResult a
Success a
x)
Check a
f >>= :: Check a -> (a -> Check b) -> Check b
>>= a -> Check b
g = Accumulate NonFatal (CheckResult b) -> Check b
forall a. Accumulate NonFatal (CheckResult a) -> Check a
Check (Accumulate NonFatal (CheckResult b) -> Check b)
-> Accumulate NonFatal (CheckResult b) -> Check b
forall a b. (a -> b) -> a -> b
$ \ NonFatal
ws ->
case Check a -> Accumulate NonFatal (CheckResult a)
forall a. Check a -> Accumulate NonFatal (CheckResult a)
unCheck Check a
f NonFatal
ws of
(NonFatal
ws,Success a
x) -> Check b -> Accumulate NonFatal (CheckResult b)
forall a. Check a -> Accumulate NonFatal (CheckResult a)
unCheck (a -> Check b
g a
x) NonFatal
ws
(NonFatal
ws,Fail Error
msg) -> (NonFatal
ws,Error -> CheckResult b
forall a. Error -> CheckResult a
Fail Error
msg)
instance Fail.MonadFail Check where
fail :: String -> Check a
fail = String -> Check a
forall (m :: * -> *) a. ErrorMonad m => String -> m a
raise
instance Applicative Check where
pure :: a -> Check a
pure = a -> Check a
forall (m :: * -> *) a. Monad m => a -> m a
return
<*> :: Check (a -> b) -> Check a -> Check b
(<*>) = Check (a -> b) -> Check a -> Check b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance ErrorMonad Check where
raise :: String -> Check a
raise String
s = Error -> Check a
forall a. Error -> Check a
checkError (String -> Error
forall a. Pretty a => a -> Error
pp String
s)
handle :: Check a -> (String -> Check a) -> Check a
handle Check a
f String -> Check a
h = Check a -> (Error -> Check a) -> Check a
forall a. Check a -> (Error -> Check a) -> Check a
handle' Check a
f (String -> Check a
h (String -> Check a) -> (Error -> String) -> Error -> Check a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> String
forall a. Pretty a => a -> String
render)
handle' :: Check a -> (Error -> Check a) -> Check a
handle' Check a
f Error -> Check a
h = Accumulate NonFatal (CheckResult a) -> Check a
forall a. Accumulate NonFatal (CheckResult a) -> Check a
Check (\ NonFatal
msgs -> case Check a -> Accumulate NonFatal (CheckResult a)
forall a. Check a -> Accumulate NonFatal (CheckResult a)
unCheck Check a
f NonFatal
msgs of
(NonFatal
ws,Success a
x) -> (NonFatal
ws,a -> CheckResult a
forall a. a -> CheckResult a
Success a
x)
(NonFatal
ws,Fail Error
msg) -> Check a -> Accumulate NonFatal (CheckResult a)
forall a. Check a -> Accumulate NonFatal (CheckResult a)
unCheck (Error -> Check a
h Error
msg) NonFatal
ws)
checkError :: Message -> Check a
checkError :: Error -> Check a
checkError Error
msg = Accumulate NonFatal (CheckResult a) -> Check a
forall a. Accumulate NonFatal (CheckResult a) -> Check a
Check (\ NonFatal
ws -> (NonFatal
ws,Error -> CheckResult a
forall a. Error -> CheckResult a
Fail Error
msg))
checkCond :: Message -> Bool -> Check ()
checkCond :: Error -> Bool -> Check ()
checkCond Error
s Bool
b = if Bool
b then () -> Check ()
forall (m :: * -> *) a. Monad m => a -> m a
return () else Error -> Check ()
forall a. Error -> Check a
checkError Error
s
checkWarn :: Message -> Check ()
checkWarn :: Error -> Check ()
checkWarn Error
msg = Accumulate NonFatal (CheckResult ()) -> Check ()
forall a. Accumulate NonFatal (CheckResult a) -> Check a
Check (Accumulate NonFatal (CheckResult ()) -> Check ())
-> Accumulate NonFatal (CheckResult ()) -> Check ()
forall a b. (a -> b) -> a -> b
$ \ ([Error]
es,[Error]
ws) -> (([Error]
es,(String
"Warning:" String -> Error -> Error
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Error
<+> Error
msg) Error -> [Error] -> [Error]
forall a. a -> [a] -> [a]
: [Error]
ws),() -> CheckResult ()
forall a. a -> CheckResult a
Success ())
checkWarnings :: t Error -> Check ()
checkWarnings t Error
ms = (Error -> Check ()) -> t Error -> Check ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Error -> Check ()
checkWarn t Error
ms
checkAccumError :: Message -> Check ()
checkAccumError :: Error -> Check ()
checkAccumError Error
msg = Accumulate NonFatal (CheckResult ()) -> Check ()
forall a. Accumulate NonFatal (CheckResult a) -> Check a
Check (Accumulate NonFatal (CheckResult ()) -> Check ())
-> Accumulate NonFatal (CheckResult ()) -> Check ()
forall a b. (a -> b) -> a -> b
$ \ ([Error]
es,[Error]
ws) -> ((Error
msgError -> [Error] -> [Error]
forall a. a -> [a] -> [a]
:[Error]
es,[Error]
ws),() -> CheckResult ()
forall a. a -> CheckResult a
Success ())
accumulateError :: (a -> Check a) -> a -> Check a
accumulateError :: (a -> Check a) -> a -> Check a
accumulateError a -> Check a
chk a
a =
Check a -> (Error -> Check a) -> Check a
forall a. Check a -> (Error -> Check a) -> Check a
handle' (a -> Check a
chk a
a) ((Error -> Check a) -> Check a) -> (Error -> Check a) -> Check a
forall a b. (a -> b) -> a -> b
$ \ Error
msg -> do Error -> Check ()
checkAccumError Error
msg; a -> Check a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
commitCheck :: Check a -> Check a
commitCheck :: Check a -> Check a
commitCheck Check a
c =
Accumulate NonFatal (CheckResult a) -> Check a
forall a. Accumulate NonFatal (CheckResult a) -> Check a
Check (Accumulate NonFatal (CheckResult a) -> Check a)
-> Accumulate NonFatal (CheckResult a) -> Check a
forall a b. (a -> b) -> a -> b
$ \ msgs0 :: NonFatal
msgs0@([Error]
es0,[Error]
ws0) ->
case Check a -> Accumulate NonFatal (CheckResult a)
forall a. Check a -> Accumulate NonFatal (CheckResult a)
unCheck Check a
c ([],[]) of
(([],[Error]
ws),Success a
v) -> (([Error]
es0,[Error]
ws[Error] -> [Error] -> [Error]
forall a. [a] -> [a] -> [a]
++[Error]
ws0),a -> CheckResult a
forall a. a -> CheckResult a
Success a
v)
(NonFatal
msgs ,Success a
_) -> NonFatal -> Accumulate NonFatal (CheckResult a)
forall a a a.
(a, [a]) -> ([Error], [a]) -> ((a, [a]), CheckResult a)
bad NonFatal
msgs0 NonFatal
msgs
(([Error]
es,[Error]
ws),Fail Error
e) -> NonFatal -> Accumulate NonFatal (CheckResult a)
forall a a a.
(a, [a]) -> ([Error], [a]) -> ((a, [a]), CheckResult a)
bad NonFatal
msgs0 ((Error
eError -> [Error] -> [Error]
forall a. a -> [a] -> [a]
:[Error]
es),[Error]
ws)
where
bad :: (a, [a]) -> ([Error], [a]) -> ((a, [a]), CheckResult a)
bad (a
es0,[a]
ws0) ([Error]
es,[a]
ws) = ((a
es0,[a]
ws[a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++[a]
ws0),Error -> CheckResult a
forall a. Error -> CheckResult a
Fail ([Error] -> Error
list [Error]
es))
list :: [Error] -> Error
list = [Error] -> Error
forall a. Pretty a => [a] -> Error
vcat ([Error] -> Error) -> ([Error] -> [Error]) -> [Error] -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Error] -> [Error]
forall a. [a] -> [a]
reverse
runCheck :: Check a -> m (a, String)
runCheck Check a
c = Options -> Check a -> m (a, String)
forall (m :: * -> *) a.
ErrorMonad m =>
Options -> Check a -> m (a, String)
runCheck' Options
noOptions Check a
c
runCheck' :: ErrorMonad m => Options -> Check a -> m (a,String)
runCheck' :: Options -> Check a -> m (a, String)
runCheck' Options
opts Check a
c =
case Check a -> Accumulate NonFatal (CheckResult a)
forall a. Check a -> Accumulate NonFatal (CheckResult a)
unCheck Check a
c ([],[]) of
(([],[Error]
ws),Success a
v) -> (a, String) -> m (a, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
v,Error -> String
forall a. Pretty a => a -> String
render ([Error] -> Error
wlist [Error]
ws))
(NonFatal
msgs ,Success a
v) -> NonFatal -> m (a, String)
forall (m :: * -> *) a. ErrorMonad m => NonFatal -> m a
bad NonFatal
msgs
(([Error]
es,[Error]
ws),Fail Error
e) -> NonFatal -> m (a, String)
forall (m :: * -> *) a. ErrorMonad m => NonFatal -> m a
bad ((Error
eError -> [Error] -> [Error]
forall a. a -> [a] -> [a]
:[Error]
es),[Error]
ws)
where
bad :: NonFatal -> m a
bad ([Error]
es,[Error]
ws) = String -> m a
forall (m :: * -> *) a. ErrorMonad m => String -> m a
raise (Error -> String
forall a. Pretty a => a -> String
render (Error -> String) -> Error -> String
forall a b. (a -> b) -> a -> b
$ [Error] -> Error
wlist [Error]
ws Error -> Error -> Error
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Error
$$ [Error] -> Error
list [Error]
es)
list :: [Error] -> Error
list = [Error] -> Error
forall a. Pretty a => [a] -> Error
vcat ([Error] -> Error) -> ([Error] -> [Error]) -> [Error] -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Error] -> [Error]
forall a. [a] -> [a]
reverse
wlist :: [Error] -> Error
wlist [Error]
ws = if Options -> Verbosity -> Bool
verbAtLeast Options
opts Verbosity
Normal then [Error] -> Error
list [Error]
ws else Error
empty
parallelCheck :: [Check a] -> Check [a]
parallelCheck :: [Check a] -> Check [a]
parallelCheck [Check a]
cs =
Accumulate NonFatal (CheckResult [a]) -> Check [a]
forall a. Accumulate NonFatal (CheckResult a) -> Check a
Check (Accumulate NonFatal (CheckResult [a]) -> Check [a])
-> Accumulate NonFatal (CheckResult [a]) -> Check [a]
forall a b. (a -> b) -> a -> b
$ \ ([Error]
es0,[Error]
ws0) ->
let os :: [(NonFatal, CheckResult a)]
os = [Check a -> Accumulate NonFatal (CheckResult a)
forall a. Check a -> Accumulate NonFatal (CheckResult a)
unCheck Check a
c ([],[])|Check a
c<-[Check a]
cs] [(NonFatal, CheckResult a)]
-> Strategy [(NonFatal, CheckResult a)]
-> [(NonFatal, CheckResult a)]
forall a. a -> Strategy a -> a
`using` Strategy (NonFatal, CheckResult a)
-> Strategy [(NonFatal, CheckResult a)]
forall a. Strategy a -> Strategy [a]
parList Strategy (NonFatal, CheckResult a)
forall a. Strategy a
rseq
([NonFatal]
msgs1,[CheckResult a]
crs) = [(NonFatal, CheckResult a)] -> ([NonFatal], [CheckResult a])
forall a b. [(a, b)] -> ([a], [b])
unzip [(NonFatal, CheckResult a)]
os
([[Error]]
ess,[[Error]]
wss) = [NonFatal] -> ([[Error]], [[Error]])
forall a b. [(a, b)] -> ([a], [b])
unzip [NonFatal]
msgs1
rs :: [a]
rs = [a
r | Success a
r<-[CheckResult a]
crs]
fs :: [Error]
fs = [Error
f | Fail Error
f<-[CheckResult a]
crs]
msgs :: NonFatal
msgs = ([[Error]] -> [Error]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Error]]
ess[Error] -> [Error] -> [Error]
forall a. [a] -> [a] -> [a]
++[Error]
es0,[[Error]] -> [Error]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Error]]
wss[Error] -> [Error] -> [Error]
forall a. [a] -> [a] -> [a]
++[Error]
ws0)
in if [Error] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Error]
fs
then (NonFatal
msgs,[a] -> CheckResult [a]
forall a. a -> CheckResult a
Success [a]
rs)
else (NonFatal
msgs,Error -> CheckResult [a]
forall a. Error -> CheckResult a
Fail ([Error] -> Error
forall a. Pretty a => [a] -> Error
vcat ([Error] -> Error) -> [Error] -> Error
forall a b. (a -> b) -> a -> b
$ [Error] -> [Error]
forall a. [a] -> [a]
reverse [Error]
fs))
checkMap :: (Ord a) => (a -> b -> Check b) -> Map.Map a b -> Check (Map.Map a b)
checkMap :: (a -> b -> Check b) -> Map a b -> Check (Map a b)
checkMap a -> b -> Check b
f Map a b
map = do [(a, b)]
xs <- ((a, b) -> Check (a, b)) -> [(a, b)] -> Check [(a, b)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(a
k,b
v) -> do b
v <- a -> b -> Check b
f a
k b
v
(a, b) -> Check (a, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
k,b
v)) (Map a b -> [(a, b)]
forall k a. Map k a -> [(k, a)]
Map.toList Map a b
map)
Map a b -> Check (Map a b)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(a, b)] -> Map a b
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList [(a, b)]
xs)
checkMapRecover :: (Ord a) => (a -> b -> Check b) -> Map.Map a b -> Check (Map.Map a b)
checkMapRecover :: (a -> b -> Check b) -> Map a b -> Check (Map a b)
checkMapRecover a -> b -> Check b
f = ([(a, b)] -> Map a b) -> Check [(a, b)] -> Check (Map a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(a, b)] -> Map a b
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (Check [(a, b)] -> Check (Map a b))
-> (Map a b -> Check [(a, b)]) -> Map a b -> Check (Map a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Check (a, b)] -> Check [(a, b)]
forall a. [Check a] -> Check [a]
parallelCheck ([Check (a, b)] -> Check [(a, b)])
-> (Map a b -> [Check (a, b)]) -> Map a b -> Check [(a, b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b) -> Check (a, b)) -> [(a, b)] -> [Check (a, b)]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> Check (a, b)
f' ([(a, b)] -> [Check (a, b)])
-> (Map a b -> [(a, b)]) -> Map a b -> [Check (a, b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map a b -> [(a, b)]
forall k a. Map k a -> [(k, a)]
Map.toList
where f' :: (a, b) -> Check (a, b)
f' (a
k,b
v) = (b -> (a, b)) -> Check b -> Check (a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,)a
k) (a -> b -> Check b
f a
k b
v)
checkIn :: Doc -> Check a -> Check a
checkIn :: Error -> Check a -> Check a
checkIn Error
msg Check a
c = Accumulate NonFatal (CheckResult a) -> Check a
forall a. Accumulate NonFatal (CheckResult a) -> Check a
Check (Accumulate NonFatal (CheckResult a) -> Check a)
-> Accumulate NonFatal (CheckResult a) -> Check a
forall a b. (a -> b) -> a -> b
$ \ NonFatal
msgs0 ->
case Check a -> Accumulate NonFatal (CheckResult a)
forall a. Check a -> Accumulate NonFatal (CheckResult a)
unCheck Check a
c ([],[]) of
(NonFatal
msgs,Fail Error
msg) -> (NonFatal -> NonFatal -> NonFatal
forall a a.
(Pretty a, Pretty a) =>
NonFatal -> ([a], [a]) -> NonFatal
augment NonFatal
msgs0 NonFatal
msgs,Error -> CheckResult a
forall a. Error -> CheckResult a
Fail (Error -> Error
forall a. Pretty a => a -> Error
augment1 Error
msg))
(NonFatal
msgs,Success a
v) -> (NonFatal -> NonFatal -> NonFatal
forall a a.
(Pretty a, Pretty a) =>
NonFatal -> ([a], [a]) -> NonFatal
augment NonFatal
msgs0 NonFatal
msgs,a -> CheckResult a
forall a. a -> CheckResult a
Success a
v)
where
augment :: NonFatal -> ([a], [a]) -> NonFatal
augment ([Error]
es0,[Error]
ws0) ([a]
es,[a]
ws) = ([Error] -> [a] -> [Error]
forall a. Pretty a => [Error] -> [a] -> [Error]
augment' [Error]
es0 [a]
es,[Error] -> [a] -> [Error]
forall a. Pretty a => [Error] -> [a] -> [Error]
augment' [Error]
ws0 [a]
ws)
augment' :: [Error] -> [a] -> [Error]
augment' [Error]
msgs0 [] = [Error]
msgs0
augment' [Error]
msgs0 [a]
msgs' = (Error
msg Error -> Error -> Error
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Error
$$ Int -> Error -> Error
forall a. Pretty a => Int -> a -> Error
nest Int
3 ([a] -> Error
forall a. Pretty a => [a] -> Error
vcat ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
msgs')))Error -> [Error] -> [Error]
forall a. a -> [a] -> [a]
:[Error]
msgs0
augment1 :: a -> Error
augment1 a
msg' = Error
msg Error -> Error -> Error
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Error
$$ Int -> a -> Error
forall a. Pretty a => Int -> a -> Error
nest Int
3 a
msg'
checkInModule :: String -> a -> Location -> a -> Check a -> Check a
checkInModule String
cwd a
mi Location
loc a
context =
Error -> Check a -> Check a
forall a. Error -> Check a -> Check a
checkIn (String -> Location -> Error
ppLocation String
relpath Location
loc Error -> Char -> Error
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Error
<> Char
':' Error -> Error -> Error
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Error
$$ Int -> a -> Error
forall a. Pretty a => Int -> a -> Error
nest Int
2 a
context)
where
relpath :: String
relpath = String -> String -> String
makeRelative String
cwd (a -> String
forall a. HasSourcePath a => a -> String
sourcePath a
mi)