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 = forall bs gs a. STB bs gs a -> bs -> gs -> IO a
runSTB STB (BaseState e) () a
m (forall e. (String, String, String) -> e -> BaseState e
initialBaseState (String, String, String)
vcd e
es) ()
where
m :: STB (BaseState e) () a
m = forall e s a. PreCST e s a -> STB (BaseState e) s a
unpackCST (
PreCST e () a
cst
forall e s a.
PreCST e s a -> (IOError -> PreCST e s a) -> PreCST e s a
`fatalsHandledBy` \IOError
err ->
forall e s. String -> PreCST e s ()
putStrCIO (String
"Uncaught fatal error: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show IOError
err) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
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 = forall e s a. STB (BaseState e) s a -> PreCST e s a
CST forall a b. (a -> b) -> a -> b
$ forall bs gs' a gs. STB bs gs' a -> gs' -> STB bs gs a
StateTrans.interleave (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 = forall e s a. STB (BaseState e) s a -> PreCST e s a
CST forall a b. (a -> b) -> a -> b
$ 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 = forall e s a. STB (BaseState e) s a -> PreCST e s a
CST forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = forall e s a. STB (BaseState e) s a -> PreCST e s a
CST forall a b. (a -> b) -> a -> b
$ forall bs gs a.
STB bs gs a -> (String, String -> STB bs gs a) -> STB bs gs a
StateTrans.catchExc (forall e s a. PreCST e s a -> STB (BaseState e) s a
unpackCST PreCST e s a
m) (String
s, forall e s a. PreCST e s a -> STB (BaseState e) s a
unpackCST 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 = forall e s a. STB (BaseState e) s a -> PreCST e s a
CST forall a b. (a -> b) -> a -> b
$ 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' = 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' = forall e s a. PreCST e s a -> STB (BaseState e) s a
unpackCST 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 = forall e s a. STB (BaseState e) s a -> PreCST e s a
CST forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall e s a. STB (BaseState e) s a -> PreCST e s a
CST forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall e s a. STB (BaseState e) s a -> PreCST e s a
CST forall a b. (a -> b) -> a -> b
$ 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 = forall e s a. STB (BaseState e) s a -> PreCST e s a
CST forall a b. (a -> b) -> a -> b
$
forall bs a gs. (bs -> a) -> STB bs gs a
readBase (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 -> forall e s. Error -> PreCST e s ()
raise0 Error
err
ErrorLvl
ErrorErr -> forall e s. Error -> PreCST e s ()
raise0 Error
err
ErrorLvl
FatalErr -> 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 = 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 = 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 = 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
forall e s. Error -> PreCST e s ()
raise0 Error
err
String
errmsgs <- forall e s. PreCST e s String
showErrors
forall e s a. String -> PreCST e s a
fatal (String
short forall a. [a] -> [a] -> [a]
++ String
"\n\n" forall a. [a] -> [a] -> [a]
++ String
errmsgs)
raise0 :: Error -> PreCST e s ()
raise0 :: forall e s. Error -> PreCST e s ()
raise0 Error
err = do
Int
noOfErrs <- forall e s a. STB (BaseState e) s a -> PreCST e s a
CST forall a b. (a -> b) -> a -> b
$ forall bs a gs. (bs -> (bs, a)) -> STB bs gs a
transBase forall e. BaseState e -> (BaseState e, Int)
doRaise
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
noOfErrs forall a. Ord a => a -> a -> Bool
>= Int
errorLimit) forall a b. (a -> b) -> a -> b
$ do
String
errmsgs <- forall e s. PreCST e s String
showErrors
forall e s a. String -> PreCST e s a
fatal (String
"Error limit of " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
errorLimit
forall a. [a] -> [a] -> [a]
++ String
" errors has been reached.\n" forall a. [a] -> [a] -> [a]
++ String
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 = forall e. BaseState e -> ErrorState
errorsBS BaseState e
bs
wlvl' :: ErrorLvl
wlvl' = forall a. Ord a => a -> a -> a
max ErrorLvl
wlvl ErrorLvl
lvl
no' :: Int
no' = Int
no forall a. Num a => a -> a -> a
+ if ErrorLvl
lvl forall a. Ord a => a -> a -> Bool
> ErrorLvl
WarningErr
then Int
1 else Int
0
errs' :: [Error]
errs' = Error
err forall a. a -> [a] -> [a]
: [Error]
errs
in
(BaseState e
bs {errorsBS :: ErrorState
errorsBS = (ErrorLvl -> Int -> [Error] -> ErrorState
ErrorState ErrorLvl
wlvl' Int
no' [Error]
errs')}, Int
no')
showErrors :: PreCST e s String
showErrors :: forall e s. PreCST e s String
showErrors = forall e s a. STB (BaseState e) s a -> PreCST e s a
CST forall a b. (a -> b) -> a -> b
$ do
ErrorState ErrorLvl
wlvl Int
no [Error]
errs <- forall bs a gs. (bs -> (bs, a)) -> STB bs gs a
transBase forall e. BaseState e -> (BaseState e, ErrorState)
extractErrs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id (forall a b. (a -> b) -> [a] -> [b]
map String -> ShowS
showString ([Error] -> [String]
errsToStrs [Error]
errs)) String
""
where
extractErrs :: BaseState e -> (BaseState e, ErrorState)
extractErrs :: forall e. BaseState e -> (BaseState e, ErrorState)
extractErrs BaseState e
bs = (BaseState e
bs {errorsBS :: ErrorState
errorsBS = ErrorState
initialErrorState},
forall e. BaseState e -> ErrorState
errorsBS BaseState e
bs)
errsToStrs :: [Error] -> [String]
errsToStrs :: [Error] -> [String]
errsToStrs [Error]
errs = (forall a b. (a -> b) -> [a] -> [b]
map Error -> String
showError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort) [Error]
errs
errorsPresent :: PreCST e s Bool
errorsPresent :: forall e s. PreCST e s Bool
errorsPresent = forall e s a. STB (BaseState e) s a -> PreCST e s a
CST forall a b. (a -> b) -> a -> b
$ do
ErrorState ErrorLvl
wlvl Int
no [Error]
_ <- forall bs a gs. (bs -> a) -> STB bs gs a
readBase forall e. BaseState e -> ErrorState
errorsBS
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ErrorLvl
wlvl forall a. Ord a => a -> a -> Bool
>= ErrorLvl
ErrorErr
readExtra :: (e -> a) -> PreCST e s a
e -> a
rf = forall e s a. STB (BaseState e) s a -> PreCST e s a
CST forall a b. (a -> b) -> a -> b
$ forall bs a gs. (bs -> a) -> STB bs gs a
readBase (\BaseState e
bs ->
(e -> a
rf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. BaseState e -> e
extraBS) BaseState e
bs
)
updExtra :: (e -> e) -> PreCST e s ()
e -> e
uf = forall e s a. STB (BaseState e) s a -> PreCST e s a
CST forall a b. (a -> b) -> a -> b
$ forall bs a gs. (bs -> (bs, a)) -> STB bs gs a
transBase (\BaseState e
bs ->
let
es :: e
es = forall e. BaseState e -> e
extraBS BaseState e
bs
in
(BaseState e
bs {extraBS :: e
extraBS = e -> e
uf e
es}, ())
)
getNameSupply :: PreCST e s NameSupply
getNameSupply :: forall e s. PreCST e s NameSupply
getNameSupply = forall e s a. STB (BaseState e) s a -> PreCST e s a
CST forall a b. (a -> b) -> a -> b
$ forall bs a gs. (bs -> (bs, a)) -> STB bs gs a
transBase (\BaseState e
bs ->
let
NameSupply
supply : [NameSupply]
supplies = forall e. BaseState e -> [NameSupply]
suppliesBS BaseState e
bs
in
(BaseState e
bs {suppliesBS :: [NameSupply]
suppliesBS = [NameSupply]
supplies}, NameSupply
supply)
)