module State (
PreCST,
nop, yield, (+>=), (+>), fixCST,
throwExc, fatal, catchExc, fatalsHandledBy,
readCST, writeCST, transCST, run, runCST,
StateTrans.MVar,
newMV, readMV, assignMV,
module CIO,
liftIO,
getId,
raise, raiseWarning, raiseError, raiseFatal, showErrors,
errorsPresent,
readExtra, updExtra,
getNameSupply)
where
import Data.Ix
import Control.Monad (when)
import Data.List (sort)
import BaseVersion (version, copyright, disclaimer)
import Config (errorLimit)
import Position (Position)
import UNames (NameSupply,
rootSupply, splitSupply)
import StateTrans (STB,
readBase, transBase, runSTB)
import qualified
StateTrans (interleave, throwExc, fatal, catchExc, fatalsHandledBy,
MVar, newMV, readMV, assignMV)
import StateBase (PreCST(..), ErrorState(..), BaseState(..),
nop, yield, (+>=), (+>), fixCST,
unpackCST, readCST, writeCST, transCST,
liftIO)
import CIO
import Errors (ErrorLvl(..), Error, makeError, errorLvl, showError)
initialBaseState :: (String, String, String) -> e -> BaseState e
initialBaseState :: forall e. (String, String, String) -> e -> BaseState e
initialBaseState (String, String, String)
vcd e
es = BaseState {
idTKBS :: (String, String, String)
idTKBS = (String
version, String
copyright, String
disclaimer),
idBS :: (String, String, String)
idBS = (String, String, String)
vcd,
errorsBS :: ErrorState
errorsBS = ErrorState
initialErrorState,
suppliesBS :: [NameSupply]
suppliesBS = NameSupply -> [NameSupply]
splitSupply NameSupply
rootSupply,
extraBS :: e
extraBS = e
es
}
run :: (String, String, String) -> e -> PreCST e () a -> IO a
run :: forall e a. (String, String, String) -> e -> PreCST e () a -> IO a
run (String, String, String)
vcd e
es PreCST e () a
cst = STB (BaseState e) () a -> BaseState e -> () -> IO a
forall bs gs a. STB bs gs a -> bs -> gs -> IO a
runSTB STB (BaseState e) () a
m ((String, String, String) -> e -> BaseState e
forall e. (String, String, String) -> e -> BaseState e
initialBaseState (String, String, String)
vcd e
es) ()
where
m :: STB (BaseState e) () a
m = PreCST e () a -> STB (BaseState e) () a
forall e s a. PreCST e s a -> STB (BaseState e) s a
unpackCST (
PreCST e () a
cst
PreCST e () a -> (IOError -> PreCST e () a) -> PreCST e () a
forall e s a.
PreCST e s a -> (IOError -> PreCST e s a) -> PreCST e s a
`fatalsHandledBy` \IOError
err ->
String -> PreCST e () ()
forall e s. String -> PreCST e s ()
putStrCIO (String
"Uncaught fatal error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOError -> String
forall a. Show a => a -> String
show IOError
err) PreCST e () () -> PreCST e () a -> PreCST e () a
forall a b. PreCST e () a -> PreCST e () b -> PreCST e () b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
ExitCode -> PreCST e () a
forall e s a. ExitCode -> PreCST e s a
exitWithCIO (Int -> ExitCode
ExitFailure Int
1)
)
runCST :: PreCST e s a -> s -> PreCST e s' a
runCST :: forall e s a s'. PreCST e s a -> s -> PreCST e s' a
runCST PreCST e s a
m s
s = STB (BaseState e) s' a -> PreCST e s' a
forall e s a. STB (BaseState e) s a -> PreCST e s a
CST (STB (BaseState e) s' a -> PreCST e s' a)
-> STB (BaseState e) s' a -> PreCST e s' a
forall a b. (a -> b) -> a -> b
$ STB (BaseState e) s a -> s -> STB (BaseState e) s' a
forall bs gs' a gs. STB bs gs' a -> gs' -> STB bs gs a
StateTrans.interleave (PreCST e s a -> STB (BaseState e) s a
forall e s a. PreCST e s a -> STB (BaseState e) s a
unpackCST PreCST e s a
m) s
s
throwExc :: String -> String -> PreCST e s a
throwExc :: forall e s a. String -> String -> PreCST e s a
throwExc String
s1 String
s2 = STB (BaseState e) s a -> PreCST e s a
forall e s a. STB (BaseState e) s a -> PreCST e s a
CST (STB (BaseState e) s a -> PreCST e s a)
-> STB (BaseState e) s a -> PreCST e s a
forall a b. (a -> b) -> a -> b
$ String -> String -> STB (BaseState e) s a
forall bs gs a. String -> String -> STB bs gs a
StateTrans.throwExc String
s1 String
s2
fatal :: String -> PreCST e s a
fatal :: forall e s a. String -> PreCST e s a
fatal = STB (BaseState e) s a -> PreCST e s a
forall e s a. STB (BaseState e) s a -> PreCST e s a
CST (STB (BaseState e) s a -> PreCST e s a)
-> (String -> STB (BaseState e) s a) -> String -> PreCST e s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> STB (BaseState e) s a
forall bs gs a. String -> STB bs gs a
StateTrans.fatal
catchExc :: PreCST e s a
-> (String, String -> PreCST e s a)
-> PreCST e s a
catchExc :: forall e s a.
PreCST e s a -> (String, String -> PreCST e s a) -> PreCST e s a
catchExc PreCST e s a
m (String
s, String -> PreCST e s a
h) = STB (BaseState e) s a -> PreCST e s a
forall e s a. STB (BaseState e) s a -> PreCST e s a
CST (STB (BaseState e) s a -> PreCST e s a)
-> STB (BaseState e) s a -> PreCST e s a
forall a b. (a -> b) -> a -> b
$ STB (BaseState e) s a
-> (String, String -> STB (BaseState e) s a)
-> STB (BaseState e) s a
forall bs gs a.
STB bs gs a -> (String, String -> STB bs gs a) -> STB bs gs a
StateTrans.catchExc (PreCST e s a -> STB (BaseState e) s a
forall e s a. PreCST e s a -> STB (BaseState e) s a
unpackCST PreCST e s a
m) (String
s, PreCST e s a -> STB (BaseState e) s a
forall e s a. PreCST e s a -> STB (BaseState e) s a
unpackCST (PreCST e s a -> STB (BaseState e) s a)
-> (String -> PreCST e s a) -> String -> STB (BaseState e) s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> PreCST e s a
h)
fatalsHandledBy :: PreCST e s a -> (IOError -> PreCST e s a) -> PreCST e s a
fatalsHandledBy :: forall e s a.
PreCST e s a -> (IOError -> PreCST e s a) -> PreCST e s a
fatalsHandledBy PreCST e s a
m IOError -> PreCST e s a
h = STB (BaseState e) s a -> PreCST e s a
forall e s a. STB (BaseState e) s a -> PreCST e s a
CST (STB (BaseState e) s a -> PreCST e s a)
-> STB (BaseState e) s a -> PreCST e s a
forall a b. (a -> b) -> a -> b
$ STB (BaseState e) s a
-> (IOError -> STB (BaseState e) s a) -> STB (BaseState e) s a
forall bs gs a.
STB bs gs a -> (IOError -> STB bs gs a) -> STB bs gs a
StateTrans.fatalsHandledBy STB (BaseState e) s a
m' IOError -> STB (BaseState e) s a
h'
where
m' :: STB (BaseState e) s a
m' = PreCST e s a -> STB (BaseState e) s a
forall e s a. PreCST e s a -> STB (BaseState e) s a
unpackCST PreCST e s a
m
h' :: IOError -> STB (BaseState e) s a
h' = PreCST e s a -> STB (BaseState e) s a
forall e s a. PreCST e s a -> STB (BaseState e) s a
unpackCST (PreCST e s a -> STB (BaseState e) s a)
-> (IOError -> PreCST e s a) -> IOError -> STB (BaseState e) s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> PreCST e s a
h
newMV :: a -> PreCST e s (StateTrans.MVar a)
newMV :: forall a e s. a -> PreCST e s (MVar a)
newMV = STB (BaseState e) s (MVar a) -> PreCST e s (MVar a)
forall e s a. STB (BaseState e) s a -> PreCST e s a
CST (STB (BaseState e) s (MVar a) -> PreCST e s (MVar a))
-> (a -> STB (BaseState e) s (MVar a)) -> a -> PreCST e s (MVar a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> STB (BaseState e) s (MVar a)
forall a bs gs. a -> STB bs gs (MVar a)
StateTrans.newMV
readMV :: StateTrans.MVar a -> PreCST e s a
readMV :: forall a e s. MVar a -> PreCST e s a
readMV = STB (BaseState e) s a -> PreCST e s a
forall e s a. STB (BaseState e) s a -> PreCST e s a
CST (STB (BaseState e) s a -> PreCST e s a)
-> (MVar a -> STB (BaseState e) s a) -> MVar a -> PreCST e s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar a -> STB (BaseState e) s a
forall a bs gs. MVar a -> STB bs gs a
StateTrans.readMV
assignMV :: StateTrans.MVar a -> a -> PreCST e s ()
assignMV :: forall a e s. MVar a -> a -> PreCST e s ()
assignMV MVar a
m a
a = STB (BaseState e) s () -> PreCST e s ()
forall e s a. STB (BaseState e) s a -> PreCST e s a
CST (STB (BaseState e) s () -> PreCST e s ())
-> STB (BaseState e) s () -> PreCST e s ()
forall a b. (a -> b) -> a -> b
$ MVar a -> a -> STB (BaseState e) s ()
forall a bs gs. MVar a -> a -> STB bs gs ()
StateTrans.assignMV MVar a
m a
a
getId :: PreCST e s (String, String, String)
getId :: forall e s. PreCST e s (String, String, String)
getId = STB (BaseState e) s (String, String, String)
-> PreCST e s (String, String, String)
forall e s a. STB (BaseState e) s a -> PreCST e s a
CST (STB (BaseState e) s (String, String, String)
-> PreCST e s (String, String, String))
-> STB (BaseState e) s (String, String, String)
-> PreCST e s (String, String, String)
forall a b. (a -> b) -> a -> b
$
(BaseState e -> (String, String, String))
-> STB (BaseState e) s (String, String, String)
forall bs a gs. (bs -> a) -> STB bs gs a
readBase (BaseState e -> (String, String, String)
forall e. BaseState e -> (String, String, String)
idBS)
initialErrorState :: ErrorState
initialErrorState :: ErrorState
initialErrorState = ErrorLvl -> Int -> [Error] -> ErrorState
ErrorState ErrorLvl
WarningErr Int
0 []
raise :: Error -> PreCST e s ()
raise :: forall e s. Error -> PreCST e s ()
raise Error
err = case Error -> ErrorLvl
errorLvl Error
err of
ErrorLvl
WarningErr -> Error -> PreCST e s ()
forall e s. Error -> PreCST e s ()
raise0 Error
err
ErrorLvl
ErrorErr -> Error -> PreCST e s ()
forall e s. Error -> PreCST e s ()
raise0 Error
err
ErrorLvl
FatalErr -> String -> Error -> PreCST e s ()
forall e s a. String -> Error -> PreCST e s a
raiseFatal0 String
"Generic fatal error." Error
err
raiseWarning :: Position -> [String] -> PreCST e s ()
raiseWarning :: forall e s. Position -> [String] -> PreCST e s ()
raiseWarning Position
pos [String]
msg = Error -> PreCST e s ()
forall e s. Error -> PreCST e s ()
raise0 (ErrorLvl -> Position -> [String] -> Error
makeError ErrorLvl
WarningErr Position
pos [String]
msg)
raiseError :: Position -> [String] -> PreCST e s ()
raiseError :: forall e s. Position -> [String] -> PreCST e s ()
raiseError Position
pos [String]
msg = Error -> PreCST e s ()
forall e s. Error -> PreCST e s ()
raise0 (ErrorLvl -> Position -> [String] -> Error
makeError ErrorLvl
ErrorErr Position
pos [String]
msg)
raiseFatal :: String -> Position -> [String] -> PreCST e s a
raiseFatal :: forall e s a. String -> Position -> [String] -> PreCST e s a
raiseFatal String
short Position
pos [String]
long = String -> Error -> PreCST e s a
forall e s a. String -> Error -> PreCST e s a
raiseFatal0 String
short (ErrorLvl -> Position -> [String] -> Error
makeError ErrorLvl
FatalErr Position
pos [String]
long)
raiseFatal0 :: String -> Error -> PreCST e s a
raiseFatal0 :: forall e s a. String -> Error -> PreCST e s a
raiseFatal0 String
short Error
err = do
Error -> PreCST e s ()
forall e s. Error -> PreCST e s ()
raise0 Error
err
errmsgs <- PreCST e s String
forall e s. PreCST e s String
showErrors
fatal (short ++ "\n\n" ++ errmsgs)
raise0 :: Error -> PreCST e s ()
raise0 :: forall e s. Error -> PreCST e s ()
raise0 Error
err = do
noOfErrs <- STB (BaseState e) s Int -> PreCST e s Int
forall e s a. STB (BaseState e) s a -> PreCST e s a
CST (STB (BaseState e) s Int -> PreCST e s Int)
-> STB (BaseState e) s Int -> PreCST e s Int
forall a b. (a -> b) -> a -> b
$ (BaseState e -> (BaseState e, Int)) -> STB (BaseState e) s Int
forall bs a gs. (bs -> (bs, a)) -> STB bs gs a
transBase BaseState e -> (BaseState e, Int)
forall e. BaseState e -> (BaseState e, Int)
doRaise
when (noOfErrs >= errorLimit) $ do
errmsgs <- showErrors
fatal ("Error limit of " ++ show errorLimit
++ " errors has been reached.\n" ++ errmsgs)
where
doRaise :: BaseState e -> (BaseState e, Int)
doRaise :: forall e. BaseState e -> (BaseState e, Int)
doRaise BaseState e
bs = let
lvl :: ErrorLvl
lvl = Error -> ErrorLvl
errorLvl Error
err
ErrorState ErrorLvl
wlvl Int
no [Error]
errs = BaseState e -> ErrorState
forall e. BaseState e -> ErrorState
errorsBS BaseState e
bs
wlvl' :: ErrorLvl
wlvl' = ErrorLvl -> ErrorLvl -> ErrorLvl
forall a. Ord a => a -> a -> a
max ErrorLvl
wlvl ErrorLvl
lvl
no' :: Int
no' = Int
no Int -> Int -> Int
forall a. Num a => a -> a -> a
+ if ErrorLvl
lvl ErrorLvl -> ErrorLvl -> Bool
forall a. Ord a => a -> a -> Bool
> ErrorLvl
WarningErr
then Int
1 else Int
0
errs' :: [Error]
errs' = Error
err Error -> [Error] -> [Error]
forall a. a -> [a] -> [a]
: [Error]
errs
in
(BaseState e
bs {errorsBS = (ErrorState wlvl' no' errs')}, Int
no')
showErrors :: PreCST e s String
showErrors :: forall e s. PreCST e s String
showErrors = STB (BaseState e) s String -> PreCST e s String
forall e s a. STB (BaseState e) s a -> PreCST e s a
CST (STB (BaseState e) s String -> PreCST e s String)
-> STB (BaseState e) s String -> PreCST e s String
forall a b. (a -> b) -> a -> b
$ do
ErrorState wlvl no errs <- (BaseState e -> (BaseState e, ErrorState))
-> STB (BaseState e) s ErrorState
forall bs a gs. (bs -> (bs, a)) -> STB bs gs a
transBase BaseState e -> (BaseState e, ErrorState)
forall e. BaseState e -> (BaseState e, ErrorState)
extractErrs
return $ foldr (.) id (map showString (errsToStrs errs)) ""
where
extractErrs :: BaseState e -> (BaseState e, ErrorState)
extractErrs :: forall e. BaseState e -> (BaseState e, ErrorState)
extractErrs BaseState e
bs = (BaseState e
bs {errorsBS = initialErrorState},
BaseState e -> ErrorState
forall e. BaseState e -> ErrorState
errorsBS BaseState e
bs)
errsToStrs :: [Error] -> [String]
errsToStrs :: [Error] -> [String]
errsToStrs [Error]
errs = ((Error -> String) -> [Error] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Error -> String
showError ([Error] -> [String])
-> ([Error] -> [Error]) -> [Error] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Error] -> [Error]
forall a. Ord a => [a] -> [a]
sort) [Error]
errs
errorsPresent :: PreCST e s Bool
errorsPresent :: forall e s. PreCST e s Bool
errorsPresent = STB (BaseState e) s Bool -> PreCST e s Bool
forall e s a. STB (BaseState e) s a -> PreCST e s a
CST (STB (BaseState e) s Bool -> PreCST e s Bool)
-> STB (BaseState e) s Bool -> PreCST e s Bool
forall a b. (a -> b) -> a -> b
$ do
ErrorState wlvl no _ <- (BaseState e -> ErrorState) -> STB (BaseState e) s ErrorState
forall bs a gs. (bs -> a) -> STB bs gs a
readBase BaseState e -> ErrorState
forall e. BaseState e -> ErrorState
errorsBS
return $ wlvl >= ErrorErr
readExtra :: (e -> a) -> PreCST e s a
e -> a
rf = STB (BaseState e) s a -> PreCST e s a
forall e s a. STB (BaseState e) s a -> PreCST e s a
CST (STB (BaseState e) s a -> PreCST e s a)
-> STB (BaseState e) s a -> PreCST e s a
forall a b. (a -> b) -> a -> b
$ (BaseState e -> a) -> STB (BaseState e) s a
forall bs a gs. (bs -> a) -> STB bs gs a
readBase (\BaseState e
bs ->
(e -> a
rf (e -> a) -> (BaseState e -> e) -> BaseState e -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BaseState e -> e
forall e. BaseState e -> e
extraBS) BaseState e
bs
)
updExtra :: (e -> e) -> PreCST e s ()
e -> e
uf = STB (BaseState e) s () -> PreCST e s ()
forall e s a. STB (BaseState e) s a -> PreCST e s a
CST (STB (BaseState e) s () -> PreCST e s ())
-> STB (BaseState e) s () -> PreCST e s ()
forall a b. (a -> b) -> a -> b
$ (BaseState e -> (BaseState e, ())) -> STB (BaseState e) s ()
forall bs a gs. (bs -> (bs, a)) -> STB bs gs a
transBase (\BaseState e
bs ->
let
es :: e
es = BaseState e -> e
forall e. BaseState e -> e
extraBS BaseState e
bs
in
(BaseState e
bs {extraBS = uf es}, ())
)
getNameSupply :: PreCST e s NameSupply
getNameSupply :: forall e s. PreCST e s NameSupply
getNameSupply = STB (BaseState e) s NameSupply -> PreCST e s NameSupply
forall e s a. STB (BaseState e) s a -> PreCST e s a
CST (STB (BaseState e) s NameSupply -> PreCST e s NameSupply)
-> STB (BaseState e) s NameSupply -> PreCST e s NameSupply
forall a b. (a -> b) -> a -> b
$ (BaseState e -> (BaseState e, NameSupply))
-> STB (BaseState e) s NameSupply
forall bs a gs. (bs -> (bs, a)) -> STB bs gs a
transBase (\BaseState e
bs ->
let
NameSupply
supply : [NameSupply]
supplies = BaseState e -> [NameSupply]
forall e. BaseState e -> [NameSupply]
suppliesBS BaseState e
bs
in
(BaseState e
bs {suppliesBS = supplies}, NameSupply
supply)
)