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 :: (String, String, String) -> e -> BaseState e
initialBaseState (String, String, String)
vcd e
es = BaseState :: forall e.
(String, String, String)
-> (String, String, String)
-> ErrorState
-> [NameSupply]
-> e
-> BaseState e
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 :: (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 (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 :: 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 :: 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 :: 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 :: 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 :: 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 :: 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 :: 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 :: 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 :: 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 :: 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 :: 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 :: 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 :: 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 :: 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
String
errmsgs <- PreCST e s String
forall e s. PreCST e s String
showErrors
String -> PreCST e s a
forall e s a. String -> PreCST e s a
fatal (String
short String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
errmsgs)
raise0 :: Error -> PreCST e s ()
raise0 :: Error -> PreCST e s ()
raise0 Error
err = do
Int
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
Bool -> PreCST e s () -> PreCST e s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
noOfErrs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
errorLimit) (PreCST e s () -> PreCST e s ()) -> PreCST e s () -> PreCST e s ()
forall a b. (a -> b) -> a -> b
$ do
String
errmsgs <- PreCST e s String
forall e s. PreCST e s String
showErrors
String -> PreCST e s ()
forall e s a. String -> PreCST e s a
fatal (String
"Error limit of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
errorLimit
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" errors has been reached.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
errmsgs)
where
doRaise :: BaseState e -> (BaseState e, Int)
doRaise :: 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
errorsBS = (ErrorLvl -> Int -> [Error] -> ErrorState
ErrorState ErrorLvl
wlvl' Int
no' [Error]
errs')}, Int
no')
showErrors :: PreCST e s String
showErrors :: 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 ErrorLvl
wlvl Int
no [Error]
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
String -> STB (BaseState e) s String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> STB (BaseState e) s String)
-> String -> STB (BaseState e) s String
forall a b. (a -> b) -> a -> b
$ ((String -> String) -> (String -> String) -> String -> String)
-> (String -> String) -> [String -> String] -> String -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) String -> String
forall a. a -> a
id ((String -> String -> String) -> [String] -> [String -> String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String -> String
showString ([Error] -> [String]
errsToStrs [Error]
errs)) String
""
where
extractErrs :: BaseState e -> (BaseState e, ErrorState)
extractErrs :: BaseState e -> (BaseState e, ErrorState)
extractErrs BaseState e
bs = (BaseState e
bs {errorsBS :: ErrorState
errorsBS = ErrorState
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 :: 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 ErrorLvl
wlvl Int
no [Error]
_ <- (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
Bool -> STB (BaseState e) s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> STB (BaseState e) s Bool)
-> Bool -> STB (BaseState e) s Bool
forall a b. (a -> b) -> a -> b
$ ErrorLvl
wlvl ErrorLvl -> ErrorLvl -> Bool
forall a. Ord a => a -> a -> Bool
>= ErrorLvl
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 :: e
extraBS = e -> e
uf e
es}, ())
)
getNameSupply :: PreCST e s NameSupply
getNameSupply :: 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 :: [NameSupply]
suppliesBS = [NameSupply]
supplies}, NameSupply
supply)
)