----------------------------------------------------------------------
-- |
-- 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, runCheck',
           checkError, checkCond, checkWarn, checkWarnings, checkAccumError,
           checkIn, checkInModule, checkMap, checkMapRecover,
           parallelCheck, accumulateError, commitCheck,
          ) where
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint

import GF.Data.Operations
--import GF.Infra.Ident
--import GF.Grammar.Grammar(msrc) -- ,Context
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
--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 {Check a -> Accumulate NonFatal (CheckResult a)
unCheck :: {-Context ->-} 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
$ \{-ctxt-} 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
$ \{-ctxt-} NonFatal
ws ->
               case Check a -> Accumulate NonFatal (CheckResult a)
forall a. Check a -> Accumulate NonFatal (CheckResult a)
unCheck Check a
f {-ctxt-} 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) {-ctxt-} 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 (\{-ctxt-} NonFatal
msgs -> case Check a -> Accumulate NonFatal (CheckResult a)
forall a. Check a -> Accumulate NonFatal (CheckResult a)
unCheck Check a
f {-ctxt-} 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) {-ctxt-} NonFatal
ws)

-- | Report a fatal error
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 (\{-ctxt-} 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

-- | warnings should be reversed in the end
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
$ \{-ctxt-} ([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

-- | Report a nonfatal (accumulated) error
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
$ \{-ctxt-} ([Error]
es,[Error]
ws) -> ((Error
msgError -> [Error] -> [Error]
forall a. a -> [a] -> [a]
:[Error]
es,[Error]
ws),() -> CheckResult ()
forall a. a -> CheckResult a
Success ())

-- | Turn a fatal error into a nonfatal (accumulated) error
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

-- |  Turn accumulated errors into a fatal error
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
$ \ {-ctxt-} 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 {-ctxt-} ([],[]) 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

-- | Run an error check, report errors and warnings
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

-- | Run an error check, report errors and (optionally) warnings
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
$ \ {-ctxt-} ([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)

{-
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)
-}

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
$ \{-ctxt-} NonFatal
msgs0 ->
    case Check a -> Accumulate NonFatal (CheckResult a)
forall a. Check a -> Accumulate NonFatal (CheckResult a)
unCheck Check a
c {-ctxt-} ([],[]) 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'

-- | Augment error messages with a relative path to the source module and
-- an contextual hint (which can be left 'empty')
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)