{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleContexts,FlexibleInstances,
PatternGuards, RankNTypes, ScopedTypeVariables, LambdaCase #-}
module Language.C.Analysis.TravMonad (
MonadName(..),
MonadSymtab(..),
MonadCError(..),
MonadTrav(..),
handleTagDecl, handleTagDef, handleEnumeratorDef, handleTypeDef,
handleObjectDef,handleFunDef,handleVarDecl,handleParamDecl,
handleAsmBlock,
enterPrototypeScope,leavePrototypeScope,
enterFunctionScope,leaveFunctionScope,
enterBlockScope,leaveBlockScope,
lookupTypeDef, lookupObject,
createSUERef,
hadHardErrors,handleTravError,throwOnLeft,
astError, warn,
Trav, TravT,
runTravT, runTravTWithTravState, runTrav, runTrav_,
TravState,initTravState,withExtDeclHandler,modifyUserState,userState,
getUserState,
TravOptions(..),modifyOptions,
travErrors,
CLanguage(..),
mapMaybeM,maybeM,mapSndM,concatMapM,
)
where
import Language.C.Data
import Language.C.Data.RList as RList
import Language.C.Analysis.Builtins
import Language.C.Analysis.SemError
import Language.C.Analysis.SemRep
import Language.C.Analysis.TypeUtils (sameType)
import Language.C.Analysis.DefTable hiding (enterBlockScope,leaveBlockScope,
enterFunctionScope,leaveFunctionScope)
import qualified Language.C.Analysis.DefTable as ST
import Data.IntMap (insert)
import Data.Maybe
import Control.Applicative (Applicative(..))
import Control.Monad (liftM, ap)
import Control.Monad.Identity
import Control.Monad.State.Class
import Control.Monad.Trans
import Prelude hiding (lookup)
class (Monad m) => MonadName m where
genName :: m Name
class (Monad m) => MonadSymtab m where
getDefTable :: m DefTable
withDefTable :: (DefTable -> (a, DefTable)) -> m a
class (Monad m) => MonadCError m where
throwTravError :: Error e => e -> m a
catchTravError :: m a -> (CError -> m a) -> m a
recordError :: Error e => e -> m ()
getErrors :: m [CError]
class (MonadName m, MonadSymtab m, MonadCError m) => MonadTrav m where
handleDecl :: DeclEvent -> m ()
checkRedef :: (MonadCError m, CNode t, CNode t1) => String -> t -> (DeclarationStatus t1) -> m ()
checkRedef :: forall (m :: * -> *) t t1.
(MonadCError m, CNode t, CNode t1) =>
String -> t -> DeclarationStatus t1 -> m ()
checkRedef String
subject t
new_decl DeclarationStatus t1
redecl_status =
case DeclarationStatus t1
redecl_status of
DeclarationStatus t1
NewDecl -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Redeclared t1
old_def -> forall (m :: * -> *) e a. (MonadCError m, Error e) => e -> m a
throwTravError forall a b. (a -> b) -> a -> b
$
ErrorLevel
-> String -> RedefKind -> NodeInfo -> NodeInfo -> RedefError
redefinition ErrorLevel
LevelError String
subject RedefKind
DuplicateDef (forall a. CNode a => a -> NodeInfo
nodeInfo t
new_decl) (forall a. CNode a => a -> NodeInfo
nodeInfo t1
old_def)
KindMismatch t1
old_def -> forall (m :: * -> *) e a. (MonadCError m, Error e) => e -> m a
throwTravError forall a b. (a -> b) -> a -> b
$
ErrorLevel
-> String -> RedefKind -> NodeInfo -> NodeInfo -> RedefError
redefinition ErrorLevel
LevelError String
subject RedefKind
DiffKindRedecl (forall a. CNode a => a -> NodeInfo
nodeInfo t
new_decl) (forall a. CNode a => a -> NodeInfo
nodeInfo t1
old_def)
Shadowed t1
_old_def -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
KeepDef t1
_old_def -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
handleTagDecl :: (MonadCError m, MonadSymtab m) => TagFwdDecl -> m ()
handleTagDecl :: forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
TagFwdDecl -> m ()
handleTagDecl TagFwdDecl
decl = do
DeclarationStatus TagEntry
redecl <- forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable forall a b. (a -> b) -> a -> b
$ SUERef
-> TagFwdDecl -> DefTable -> (DeclarationStatus TagEntry, DefTable)
declareTag (forall a. HasSUERef a => a -> SUERef
sueRef TagFwdDecl
decl) TagFwdDecl
decl
forall (m :: * -> *) t t1.
(MonadCError m, CNode t, CNode t1) =>
String -> t -> DeclarationStatus t1 -> m ()
checkRedef (SUERef -> String
sueRefToString forall a b. (a -> b) -> a -> b
$ forall a. HasSUERef a => a -> SUERef
sueRef TagFwdDecl
decl) TagFwdDecl
decl DeclarationStatus TagEntry
redecl
handleTagDef :: (MonadTrav m) => TagDef -> m ()
handleTagDef :: forall (m :: * -> *). MonadTrav m => TagDef -> m ()
handleTagDef TagDef
def = do
DeclarationStatus TagEntry
redecl <- forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable forall a b. (a -> b) -> a -> b
$ SUERef
-> TagDef -> DefTable -> (DeclarationStatus TagEntry, DefTable)
defineTag (forall a. HasSUERef a => a -> SUERef
sueRef TagDef
def) TagDef
def
forall (m :: * -> *) t t1.
(MonadCError m, CNode t, CNode t1) =>
String -> t -> DeclarationStatus t1 -> m ()
checkRedef (SUERef -> String
sueRefToString forall a b. (a -> b) -> a -> b
$ forall a. HasSUERef a => a -> SUERef
sueRef TagDef
def) TagDef
def DeclarationStatus TagEntry
redecl
forall (m :: * -> *). MonadTrav m => DeclEvent -> m ()
handleDecl (TagDef -> DeclEvent
TagEvent TagDef
def)
handleEnumeratorDef :: (MonadCError m, MonadSymtab m) => Enumerator -> m ()
handleEnumeratorDef :: forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Enumerator -> m ()
handleEnumeratorDef Enumerator
enumerator = do
let ident :: Ident
ident = forall n. Declaration n => n -> Ident
declIdent Enumerator
enumerator
DeclarationStatus IdentEntry
redecl <- forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable forall a b. (a -> b) -> a -> b
$ Ident
-> IdentDecl
-> DefTable
-> (DeclarationStatus IdentEntry, DefTable)
defineScopedIdent Ident
ident (Enumerator -> IdentDecl
EnumeratorDef Enumerator
enumerator)
forall (m :: * -> *) t t1.
(MonadCError m, CNode t, CNode t1) =>
String -> t -> DeclarationStatus t1 -> m ()
checkRedef (Ident -> String
identToString Ident
ident) Ident
ident DeclarationStatus IdentEntry
redecl
forall (m :: * -> *) a. Monad m => a -> m a
return ()
handleTypeDef :: (MonadTrav m) => TypeDef -> m ()
handleTypeDef :: forall (m :: * -> *). MonadTrav m => TypeDef -> m ()
handleTypeDef typeDef :: TypeDef
typeDef@(TypeDef Ident
ident Type
t1 Attributes
_ NodeInfo
_) = do
DeclarationStatus IdentEntry
redecl <- forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable forall a b. (a -> b) -> a -> b
$ Ident
-> TypeDef -> DefTable -> (DeclarationStatus IdentEntry, DefTable)
defineTypeDef Ident
ident TypeDef
typeDef
case DeclarationStatus IdentEntry
redecl of
Redeclared (Left (TypeDef Ident
_ Type
t2 Attributes
_ NodeInfo
_)) | Type -> Type -> Bool
sameType Type
t1 Type
t2 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
DeclarationStatus IdentEntry
_ -> forall (m :: * -> *) t t1.
(MonadCError m, CNode t, CNode t1) =>
String -> t -> DeclarationStatus t1 -> m ()
checkRedef (Ident -> String
identToString Ident
ident) TypeDef
typeDef DeclarationStatus IdentEntry
redecl
forall (m :: * -> *). MonadTrav m => DeclEvent -> m ()
handleDecl (TypeDef -> DeclEvent
TypeDefEvent TypeDef
typeDef)
forall (m :: * -> *) a. Monad m => a -> m a
return ()
handleAsmBlock :: (MonadTrav m) => AsmBlock -> m ()
handleAsmBlock :: forall (m :: * -> *). MonadTrav m => AsmBlock -> m ()
handleAsmBlock AsmBlock
asm = forall (m :: * -> *). MonadTrav m => DeclEvent -> m ()
handleDecl (AsmBlock -> DeclEvent
AsmEvent AsmBlock
asm)
redefErr :: (MonadCError m, CNode old, CNode new) =>
Ident -> ErrorLevel -> new -> old -> RedefKind -> m ()
redefErr :: forall (m :: * -> *) old new.
(MonadCError m, CNode old, CNode new) =>
Ident -> ErrorLevel -> new -> old -> RedefKind -> m ()
redefErr Ident
name ErrorLevel
lvl new
new old
old RedefKind
kind =
forall (m :: * -> *) e a. (MonadCError m, Error e) => e -> m a
throwTravError forall a b. (a -> b) -> a -> b
$ ErrorLevel
-> String -> RedefKind -> NodeInfo -> NodeInfo -> RedefError
redefinition ErrorLevel
lvl (Ident -> String
identToString Ident
name) RedefKind
kind (forall a. CNode a => a -> NodeInfo
nodeInfo new
new) (forall a. CNode a => a -> NodeInfo
nodeInfo old
old)
_checkIdentTyRedef :: (MonadCError m) => IdentEntry -> (DeclarationStatus IdentEntry) -> m ()
_checkIdentTyRedef :: forall (m :: * -> *).
MonadCError m =>
IdentEntry -> DeclarationStatus IdentEntry -> m ()
_checkIdentTyRedef (Right IdentDecl
decl) DeclarationStatus IdentEntry
status = forall (m :: * -> *).
MonadCError m =>
IdentDecl -> DeclarationStatus IdentEntry -> m ()
checkVarRedef IdentDecl
decl DeclarationStatus IdentEntry
status
_checkIdentTyRedef (Left TypeDef
tydef) (KindMismatch IdentEntry
old_def) =
forall (m :: * -> *) old new.
(MonadCError m, CNode old, CNode new) =>
Ident -> ErrorLevel -> new -> old -> RedefKind -> m ()
redefErr (TypeDef -> Ident
identOfTypeDef TypeDef
tydef) ErrorLevel
LevelError TypeDef
tydef IdentEntry
old_def RedefKind
DiffKindRedecl
_checkIdentTyRedef (Left TypeDef
tydef) (Redeclared IdentEntry
old_def) =
forall (m :: * -> *) old new.
(MonadCError m, CNode old, CNode new) =>
Ident -> ErrorLevel -> new -> old -> RedefKind -> m ()
redefErr (TypeDef -> Ident
identOfTypeDef TypeDef
tydef) ErrorLevel
LevelError TypeDef
tydef IdentEntry
old_def RedefKind
DuplicateDef
_checkIdentTyRedef (Left TypeDef
_tydef) DeclarationStatus IdentEntry
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkVarRedef :: (MonadCError m) => IdentDecl -> (DeclarationStatus IdentEntry) -> m ()
checkVarRedef :: forall (m :: * -> *).
MonadCError m =>
IdentDecl -> DeclarationStatus IdentEntry -> m ()
checkVarRedef IdentDecl
def DeclarationStatus IdentEntry
redecl =
case DeclarationStatus IdentEntry
redecl of
KindMismatch IdentEntry
old_def -> forall {m :: * -> *} {old}.
(MonadCError m, CNode old) =>
old -> RedefKind -> m ()
redefVarErr IdentEntry
old_def RedefKind
DiffKindRedecl
KeepDef (Right IdentDecl
old_def) | Bool -> Bool
not (forall {d} {d}. (Declaration d, Declaration d) => d -> d -> Bool
agreeOnLinkage IdentDecl
def IdentDecl
old_def) -> forall {new} {old} {m :: * -> *}.
(Declaration new, Declaration old, MonadCError m, CNode old,
CNode new) =>
new -> old -> m ()
linkageErr IdentDecl
def IdentDecl
old_def
| Bool
otherwise -> forall (m :: * -> *) e a.
(MonadCError m, Error e) =>
Either e a -> m a
throwOnLeft forall a b. (a -> b) -> a -> b
$ Type -> Type -> Either TypeMismatch ()
checkCompatibleTypes Type
new_ty (forall n. Declaration n => n -> Type
declType IdentDecl
old_def)
Redeclared (Right IdentDecl
old_def) | Bool -> Bool
not (forall {d} {d}. (Declaration d, Declaration d) => d -> d -> Bool
agreeOnLinkage IdentDecl
def IdentDecl
old_def) -> forall {new} {old} {m :: * -> *}.
(Declaration new, Declaration old, MonadCError m, CNode old,
CNode new) =>
new -> old -> m ()
linkageErr IdentDecl
def IdentDecl
old_def
| Bool -> Bool
not(IdentDecl -> Bool
canBeOverwritten IdentDecl
old_def) -> forall {m :: * -> *} {old}.
(MonadCError m, CNode old) =>
old -> RedefKind -> m ()
redefVarErr IdentDecl
old_def RedefKind
DuplicateDef
| Bool
otherwise -> forall (m :: * -> *) e a.
(MonadCError m, Error e) =>
Either e a -> m a
throwOnLeft forall a b. (a -> b) -> a -> b
$ Type -> Type -> Either TypeMismatch ()
checkCompatibleTypes Type
new_ty (forall n. Declaration n => n -> Type
declType IdentDecl
old_def)
DeclarationStatus IdentEntry
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
redefVarErr :: old -> RedefKind -> m ()
redefVarErr old
old_def RedefKind
kind = forall (m :: * -> *) old new.
(MonadCError m, CNode old, CNode new) =>
Ident -> ErrorLevel -> new -> old -> RedefKind -> m ()
redefErr (forall n. Declaration n => n -> Ident
declIdent IdentDecl
def) ErrorLevel
LevelError IdentDecl
def old
old_def RedefKind
kind
linkageErr :: new -> old -> m ()
linkageErr new
new_def old
old_def =
case (forall d. Declaration d => d -> Linkage
declLinkage new
new_def, forall d. Declaration d => d -> Linkage
declLinkage old
old_def) of
(Linkage
NoLinkage, Linkage
_) -> forall (m :: * -> *) old new.
(MonadCError m, CNode old, CNode new) =>
Ident -> ErrorLevel -> new -> old -> RedefKind -> m ()
redefErr (forall n. Declaration n => n -> Ident
declIdent new
new_def) ErrorLevel
LevelError new
new_def old
old_def RedefKind
NoLinkageOld
(Linkage, Linkage)
_ -> forall (m :: * -> *) old new.
(MonadCError m, CNode old, CNode new) =>
Ident -> ErrorLevel -> new -> old -> RedefKind -> m ()
redefErr (forall n. Declaration n => n -> Ident
declIdent new
new_def) ErrorLevel
LevelError new
new_def old
old_def RedefKind
DisagreeLinkage
new_ty :: Type
new_ty = forall n. Declaration n => n -> Type
declType IdentDecl
def
canBeOverwritten :: IdentDecl -> Bool
canBeOverwritten (Declaration Decl
_) = Bool
True
canBeOverwritten (ObjectDef ObjDef
od) = ObjDef -> Bool
isTentative ObjDef
od
canBeOverwritten IdentDecl
_ = Bool
False
agreeOnLinkage :: d -> d -> Bool
agreeOnLinkage d
new_def d
old_def
| forall d. Declaration d => d -> Storage
declStorage d
old_def forall a. Eq a => a -> a -> Bool
== Linkage -> Storage
FunLinkage Linkage
InternalLinkage = Bool
True
| Bool -> Bool
not (Storage -> Bool
hasLinkage forall a b. (a -> b) -> a -> b
$ forall d. Declaration d => d -> Storage
declStorage d
new_def) Bool -> Bool -> Bool
|| Bool -> Bool
not (Storage -> Bool
hasLinkage forall a b. (a -> b) -> a -> b
$ forall d. Declaration d => d -> Storage
declStorage d
old_def) = Bool
False
| (forall d. Declaration d => d -> Linkage
declLinkage d
new_def) forall a. Eq a => a -> a -> Bool
/= (forall d. Declaration d => d -> Linkage
declLinkage d
old_def) = Bool
False
| Bool
otherwise = Bool
True
handleVarDecl :: (MonadTrav m) => Bool -> Decl -> m ()
handleVarDecl :: forall (m :: * -> *). MonadTrav m => Bool -> Decl -> m ()
handleVarDecl Bool
is_local Decl
decl = do
IdentDecl
def <- forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Decl -> (IdentDecl -> Bool) -> m IdentDecl
enterDecl Decl
decl (forall a b. a -> b -> a
const Bool
False)
forall (m :: * -> *). MonadTrav m => DeclEvent -> m ()
handleDecl ((if Bool
is_local then IdentDecl -> DeclEvent
LocalEvent else IdentDecl -> DeclEvent
DeclEvent) IdentDecl
def)
handleParamDecl :: (MonadTrav m) => ParamDecl -> m ()
handleParamDecl :: forall (m :: * -> *). MonadTrav m => ParamDecl -> m ()
handleParamDecl pd :: ParamDecl
pd@(AbstractParamDecl VarDecl
_ NodeInfo
_) = forall (m :: * -> *). MonadTrav m => DeclEvent -> m ()
handleDecl (ParamDecl -> DeclEvent
ParamEvent ParamDecl
pd)
handleParamDecl pd :: ParamDecl
pd@(ParamDecl VarDecl
vardecl NodeInfo
node) = do
let def :: IdentDecl
def = ObjDef -> IdentDecl
ObjectDef (VarDecl -> Maybe Initializer -> NodeInfo -> ObjDef
ObjDef VarDecl
vardecl forall a. Maybe a
Nothing NodeInfo
node)
DeclarationStatus IdentEntry
redecl <- forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable forall a b. (a -> b) -> a -> b
$ Ident
-> IdentDecl
-> DefTable
-> (DeclarationStatus IdentEntry, DefTable)
defineScopedIdent (forall n. Declaration n => n -> Ident
declIdent IdentDecl
def) IdentDecl
def
forall (m :: * -> *).
MonadCError m =>
IdentDecl -> DeclarationStatus IdentEntry -> m ()
checkVarRedef IdentDecl
def DeclarationStatus IdentEntry
redecl
forall (m :: * -> *). MonadTrav m => DeclEvent -> m ()
handleDecl (ParamDecl -> DeclEvent
ParamEvent ParamDecl
pd)
enterDecl :: (MonadCError m, MonadSymtab m) => Decl -> (IdentDecl -> Bool) -> m IdentDecl
enterDecl :: forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Decl -> (IdentDecl -> Bool) -> m IdentDecl
enterDecl Decl
decl IdentDecl -> Bool
cond = do
let def :: IdentDecl
def = Decl -> IdentDecl
Declaration Decl
decl
DeclarationStatus IdentEntry
redecl <- forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable forall a b. (a -> b) -> a -> b
$
(IdentDecl -> Bool)
-> Ident
-> IdentDecl
-> DefTable
-> (DeclarationStatus IdentEntry, DefTable)
defineScopedIdentWhen IdentDecl -> Bool
cond (forall n. Declaration n => n -> Ident
declIdent IdentDecl
def) IdentDecl
def
forall (m :: * -> *).
MonadCError m =>
IdentDecl -> DeclarationStatus IdentEntry -> m ()
checkVarRedef IdentDecl
def DeclarationStatus IdentEntry
redecl
forall (m :: * -> *) a. Monad m => a -> m a
return IdentDecl
def
handleFunDef :: (MonadTrav m) => Ident -> FunDef -> m ()
handleFunDef :: forall (m :: * -> *). MonadTrav m => Ident -> FunDef -> m ()
handleFunDef Ident
ident FunDef
fun_def = do
let def :: IdentDecl
def = FunDef -> IdentDecl
FunctionDef FunDef
fun_def
DeclarationStatus IdentEntry
redecl <- forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable forall a b. (a -> b) -> a -> b
$
(IdentDecl -> Bool)
-> Ident
-> IdentDecl
-> DefTable
-> (DeclarationStatus IdentEntry, DefTable)
defineScopedIdentWhen IdentDecl -> Bool
isDeclaration Ident
ident IdentDecl
def
forall (m :: * -> *).
MonadCError m =>
IdentDecl -> DeclarationStatus IdentEntry -> m ()
checkVarRedef IdentDecl
def DeclarationStatus IdentEntry
redecl
forall (m :: * -> *). MonadTrav m => DeclEvent -> m ()
handleDecl (IdentDecl -> DeclEvent
DeclEvent IdentDecl
def)
isDeclaration :: IdentDecl -> Bool
isDeclaration :: IdentDecl -> Bool
isDeclaration (Declaration Decl
_) = Bool
True
isDeclaration IdentDecl
_ = Bool
False
checkCompatibleTypes :: Type -> Type -> Either TypeMismatch ()
checkCompatibleTypes :: Type -> Type -> Either TypeMismatch ()
checkCompatibleTypes Type
_ Type
_ = forall a b. b -> Either a b
Right ()
handleObjectDef :: (MonadTrav m) => Bool -> Ident -> ObjDef -> m ()
handleObjectDef :: forall (m :: * -> *).
MonadTrav m =>
Bool -> Ident -> ObjDef -> m ()
handleObjectDef Bool
local Ident
ident ObjDef
obj_def = do
let def :: IdentDecl
def = ObjDef -> IdentDecl
ObjectDef ObjDef
obj_def
DeclarationStatus IdentEntry
redecl <- forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable forall a b. (a -> b) -> a -> b
$
(IdentDecl -> Bool)
-> Ident
-> IdentDecl
-> DefTable
-> (DeclarationStatus IdentEntry, DefTable)
defineScopedIdentWhen (IdentDecl -> IdentDecl -> Bool
shouldOverride IdentDecl
def) Ident
ident IdentDecl
def
forall (m :: * -> *).
MonadCError m =>
IdentDecl -> DeclarationStatus IdentEntry -> m ()
checkVarRedef IdentDecl
def DeclarationStatus IdentEntry
redecl
forall (m :: * -> *). MonadTrav m => DeclEvent -> m ()
handleDecl ((if Bool
local then IdentDecl -> DeclEvent
LocalEvent else IdentDecl -> DeclEvent
DeclEvent) IdentDecl
def)
where
isTentativeDef :: IdentDecl -> Bool
isTentativeDef (ObjectDef ObjDef
object_def) = ObjDef -> Bool
isTentative ObjDef
object_def
isTentativeDef IdentDecl
_ = Bool
False
shouldOverride :: IdentDecl -> IdentDecl -> Bool
shouldOverride IdentDecl
def IdentDecl
old | IdentDecl -> Bool
isDeclaration IdentDecl
old = Bool
True
| Bool -> Bool
not (IdentDecl -> Bool
isTentativeDef IdentDecl
def) = Bool
True
| IdentDecl -> Bool
isTentativeDef IdentDecl
old = Bool
True
| Bool
otherwise = Bool
False
updDefTable :: (MonadSymtab m) => (DefTable -> DefTable) -> m ()
updDefTable :: forall (m :: * -> *).
MonadSymtab m =>
(DefTable -> DefTable) -> m ()
updDefTable DefTable -> DefTable
f = forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable (\DefTable
st -> ((),DefTable -> DefTable
f DefTable
st))
enterPrototypeScope :: (MonadSymtab m) => m ()
enterPrototypeScope :: forall (m :: * -> *). MonadSymtab m => m ()
enterPrototypeScope = forall (m :: * -> *).
MonadSymtab m =>
(DefTable -> DefTable) -> m ()
updDefTable (DefTable -> DefTable
ST.enterBlockScope)
leavePrototypeScope :: (MonadSymtab m) => m ()
leavePrototypeScope :: forall (m :: * -> *). MonadSymtab m => m ()
leavePrototypeScope = forall (m :: * -> *).
MonadSymtab m =>
(DefTable -> DefTable) -> m ()
updDefTable (DefTable -> DefTable
ST.leaveBlockScope)
enterFunctionScope :: (MonadSymtab m) => m ()
enterFunctionScope :: forall (m :: * -> *). MonadSymtab m => m ()
enterFunctionScope = forall (m :: * -> *).
MonadSymtab m =>
(DefTable -> DefTable) -> m ()
updDefTable (DefTable -> DefTable
ST.enterFunctionScope)
leaveFunctionScope :: (MonadSymtab m) => m ()
leaveFunctionScope :: forall (m :: * -> *). MonadSymtab m => m ()
leaveFunctionScope = forall (m :: * -> *).
MonadSymtab m =>
(DefTable -> DefTable) -> m ()
updDefTable (DefTable -> DefTable
ST.leaveFunctionScope)
enterBlockScope :: (MonadSymtab m) => m ()
enterBlockScope :: forall (m :: * -> *). MonadSymtab m => m ()
enterBlockScope = forall (m :: * -> *).
MonadSymtab m =>
(DefTable -> DefTable) -> m ()
updDefTable (DefTable -> DefTable
ST.enterBlockScope)
leaveBlockScope :: (MonadSymtab m) => m ()
leaveBlockScope :: forall (m :: * -> *). MonadSymtab m => m ()
leaveBlockScope = forall (m :: * -> *).
MonadSymtab m =>
(DefTable -> DefTable) -> m ()
updDefTable (DefTable -> DefTable
ST.leaveBlockScope)
lookupTypeDef :: (MonadCError m, MonadSymtab m) => Ident -> m Type
lookupTypeDef :: forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Ident -> m Type
lookupTypeDef Ident
ident =
forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \DefTable
symt ->
case Ident -> DefTable -> Maybe IdentEntry
lookupIdent Ident
ident DefTable
symt of
Maybe IdentEntry
Nothing ->
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError (forall a. CNode a => a -> NodeInfo
nodeInfo Ident
ident) forall a b. (a -> b) -> a -> b
$ String
"unbound typeDef: " forall a. [a] -> [a] -> [a]
++ Ident -> String
identToString Ident
ident
Just (Left (TypeDef Ident
def_ident Type
ty Attributes
_ NodeInfo
_)) -> forall (m :: * -> *) u d.
(MonadCError m, MonadSymtab m, CNode u, CNode d) =>
u -> d -> m ()
addRef Ident
ident Ident
def_ident forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty
Just (Right IdentDecl
d) -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError (forall a. CNode a => a -> NodeInfo
nodeInfo Ident
ident) (IdentDecl -> String
wrongKindErrMsg IdentDecl
d)
where
wrongKindErrMsg :: IdentDecl -> String
wrongKindErrMsg IdentDecl
d = String
"wrong kind of object: expected typedef but found "forall a. [a] -> [a] -> [a]
++ (IdentDecl -> String
objKindDescr IdentDecl
d)
forall a. [a] -> [a] -> [a]
++ String
" (for identifier `" forall a. [a] -> [a] -> [a]
++ Ident -> String
identToString Ident
ident forall a. [a] -> [a] -> [a]
++ String
"')"
lookupObject :: (MonadCError m, MonadSymtab m) => Ident -> m (Maybe IdentDecl)
lookupObject :: forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Ident -> m (Maybe IdentDecl)
lookupObject Ident
ident = do
Maybe IdentEntry
old_decl <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Ident -> DefTable -> Maybe IdentEntry
lookupIdent Ident
ident) forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable
forall (m :: * -> *) a b.
Monad m =>
Maybe a -> (a -> m b) -> m (Maybe b)
mapMaybeM Maybe IdentEntry
old_decl forall a b. (a -> b) -> a -> b
$ \IdentEntry
obj ->
case IdentEntry
obj of
Right IdentDecl
objdef -> forall (m :: * -> *) u d.
(MonadCError m, MonadSymtab m, CNode u, CNode d) =>
u -> d -> m ()
addRef Ident
ident IdentDecl
objdef forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return IdentDecl
objdef
Left TypeDef
_tydef -> forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError (forall a. CNode a => a -> NodeInfo
nodeInfo Ident
ident) (String -> String -> String -> String
mismatchErr String
"lookupObject" String
"an object" String
"a typeDef")
addRef :: (MonadCError m, MonadSymtab m, CNode u, CNode d) => u -> d -> m ()
addRef :: forall (m :: * -> *) u d.
(MonadCError m, MonadSymtab m, CNode u, CNode d) =>
u -> d -> m ()
addRef u
use d
def =
case (forall a. CNode a => a -> NodeInfo
nodeInfo u
use, forall a. CNode a => a -> NodeInfo
nodeInfo d
def) of
(NodeInfo Position
_ PosLength
_ Name
useName, NodeInfo Position
_ PosLength
_ Name
defName) ->
forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable
(\DefTable
dt ->
((),
DefTable
dt { refTable :: IntMap Name
refTable = forall a. Key -> a -> IntMap a -> IntMap a
insert (Name -> Key
nameId Name
useName) Name
defName (DefTable -> IntMap Name
refTable DefTable
dt) }
)
)
(NodeInfo
_, NodeInfo
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
mismatchErr :: String -> String -> String -> String
mismatchErr :: String -> String -> String -> String
mismatchErr String
ctx String
expect String
found = String
ctx forall a. [a] -> [a] -> [a]
++ String
": Expected " forall a. [a] -> [a] -> [a]
++ String
expect forall a. [a] -> [a] -> [a]
++ String
", but found: " forall a. [a] -> [a] -> [a]
++ String
found
createSUERef :: (MonadCError m, MonadSymtab m) => NodeInfo -> Maybe Ident -> m SUERef
createSUERef :: forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
NodeInfo -> Maybe Ident -> m SUERef
createSUERef NodeInfo
_node_info (Just Ident
ident) = forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$ Ident -> SUERef
NamedRef Ident
ident
createSUERef NodeInfo
node_info Maybe Ident
Nothing | (Just Name
name) <- NodeInfo -> Maybe Name
nameOfNode NodeInfo
node_info = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> SUERef
AnonymousRef Name
name
| Bool
otherwise = forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node_info String
"struct/union/enum definition without unique name"
handleTravError :: (MonadCError m) => m a -> m (Maybe a)
handleTravError :: forall (m :: * -> *) a. MonadCError m => m a -> m (Maybe a)
handleTravError m a
a = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. a -> Maybe a
Just m a
a forall (m :: * -> *) a.
MonadCError m =>
m a -> (CError -> m a) -> m a
`catchTravError` (\CError
e -> forall (m :: * -> *) e. (MonadCError m, Error e) => e -> m ()
recordError CError
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
hadHardErrors :: [CError] -> Bool
hadHardErrors :: [CError] -> Bool
hadHardErrors = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall ex. Error ex => ex -> Bool
isHardError
astError :: (MonadCError m) => NodeInfo -> String -> m a
astError :: forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node String
msg = forall (m :: * -> *) e a. (MonadCError m, Error e) => e -> m a
throwTravError forall a b. (a -> b) -> a -> b
$ NodeInfo -> String -> InvalidASTError
invalidAST NodeInfo
node String
msg
throwOnLeft :: (MonadCError m, Error e) => Either e a -> m a
throwOnLeft :: forall (m :: * -> *) e a.
(MonadCError m, Error e) =>
Either e a -> m a
throwOnLeft (Left e
err) = forall (m :: * -> *) e a. (MonadCError m, Error e) => e -> m a
throwTravError e
err
throwOnLeft (Right a
v) = forall (m :: * -> *) a. Monad m => a -> m a
return a
v
warn :: (Error e, MonadCError m) => e -> m ()
warn :: forall e (m :: * -> *). (Error e, MonadCError m) => e -> m ()
warn e
err = forall (m :: * -> *) e. (MonadCError m, Error e) => e -> m ()
recordError (forall e. Error e => e -> ErrorLevel -> e
changeErrorLevel e
err ErrorLevel
LevelWarn)
newtype TravT s m a = TravT { forall s (m :: * -> *) a.
TravT s m a
-> TravState m s -> m (Either CError (a, TravState m s))
unTravT :: TravState m s -> m (Either CError (a, TravState m s)) }
instance Monad m => MonadState (TravState m s) (TravT s m) where
get :: TravT s m (TravState m s)
get = forall s (m :: * -> *) a.
(TravState m s -> m (Either CError (a, TravState m s)))
-> TravT s m a
TravT (\TravState m s
s -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (TravState m s
s,TravState m s
s)))
put :: TravState m s -> TravT s m ()
put TravState m s
s = forall s (m :: * -> *) a.
(TravState m s -> m (Either CError (a, TravState m s)))
-> TravT s m a
TravT (\TravState m s
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right ((),TravState m s
s)))
runTravT :: forall m s a. Monad m => s -> TravT s m a -> m (Either [CError] (a, TravState m s))
runTravT :: forall (m :: * -> *) s a.
Monad m =>
s -> TravT s m a -> m (Either [CError] (a, TravState m s))
runTravT s
state TravT s m a
traversal =
forall s (m :: * -> *) a.
Monad m =>
TravState m s
-> TravT s m a -> m (Either [CError] (a, TravState m s))
runTravTWithTravState (forall (m :: * -> *) s. Monad m => s -> TravState m s
initTravState s
state) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable (forall a b. a -> b -> a
const ((), DefTable
builtins))
TravT s m a
traversal
runTravTWithTravState :: forall s m a. Monad m => TravState m s -> TravT s m a -> m (Either [CError] (a, TravState m s))
runTravTWithTravState :: forall s (m :: * -> *) a.
Monad m =>
TravState m s
-> TravT s m a -> m (Either [CError] (a, TravState m s))
runTravTWithTravState TravState m s
state TravT s m a
traversal =
forall s (m :: * -> *) a.
TravT s m a
-> TravState m s -> m (Either CError (a, TravState m s))
unTravT TravT s m a
traversal TravState m s
state forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
Left CError
trav_err -> forall a b. a -> Either a b
Left [CError
trav_err]
Right (a
v, TravState m s
ts) | [CError] -> Bool
hadHardErrors (forall (m :: * -> *) s. TravState m s -> [CError]
travErrors TravState m s
ts) -> forall a b. a -> Either a b
Left (forall (m :: * -> *) s. TravState m s -> [CError]
travErrors TravState m s
ts)
| Bool
otherwise -> forall a b. b -> Either a b
Right (a
v,TravState m s
ts)
runTrav :: forall s a. s -> Trav s a -> Either [CError] (a, TravState Identity s)
runTrav :: forall s a.
s -> Trav s a -> Either [CError] (a, TravState Identity s)
runTrav s
state Trav s a
traversal = forall a. Identity a -> a
runIdentity (forall (m :: * -> *) s a.
Monad m =>
s -> TravT s m a -> m (Either [CError] (a, TravState m s))
runTravT s
state (forall s a. Trav s a -> Trav s a
unTrav Trav s a
traversal))
runTrav_ :: Trav () a -> Either [CError] (a,[CError])
runTrav_ :: forall a. Trav () a -> Either [CError] (a, [CError])
runTrav_ Trav () a
t = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a.
s -> Trav s a -> Either [CError] (a, TravState Identity s)
runTrav () forall a b. (a -> b) -> a -> b
$
do a
r <- Trav () a
t
[CError]
es <- forall (m :: * -> *). MonadCError m => m [CError]
getErrors
forall (m :: * -> *) a. Monad m => a -> m a
return (a
r,[CError]
es)
withExtDeclHandler :: Monad m => TravT s m a -> (DeclEvent -> TravT s m ()) -> TravT s m a
withExtDeclHandler :: forall (m :: * -> *) s a.
Monad m =>
TravT s m a -> (DeclEvent -> TravT s m ()) -> TravT s m a
withExtDeclHandler TravT s m a
action DeclEvent -> TravT s m ()
handler =
do forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \TravState m s
st -> TravState m s
st { doHandleExtDecl :: DeclEvent -> TravT s m ()
doHandleExtDecl = DeclEvent -> TravT s m ()
handler }
TravT s m a
action
instance Monad f => Functor (TravT s f) where
fmap :: forall a b. (a -> b) -> TravT s f a -> TravT s f b
fmap = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
instance Monad f => Applicative (TravT s f) where
pure :: forall a. a -> TravT s f a
pure = forall (m :: * -> *) a. Monad m => a -> m a
return
<*> :: forall a b. TravT s f (a -> b) -> TravT s f a -> TravT s f b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad m => Monad (TravT s m) where
return :: forall a. a -> TravT s m a
return a
x = forall s (m :: * -> *) a.
(TravState m s -> m (Either CError (a, TravState m s)))
-> TravT s m a
TravT (\TravState m s
s -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (a
x,TravState m s
s)))
TravT s m a
m >>= :: forall a b. TravT s m a -> (a -> TravT s m b) -> TravT s m b
>>= a -> TravT s m b
k = forall s (m :: * -> *) a.
(TravState m s -> m (Either CError (a, TravState m s)))
-> TravT s m a
TravT (\TravState m s
s -> forall s (m :: * -> *) a.
TravT s m a
-> TravState m s -> m (Either CError (a, TravState m s))
unTravT TravT s m a
m TravState m s
s forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Either CError (a, TravState m s)
y -> case Either CError (a, TravState m s)
y of
Right (a
x,TravState m s
s1) -> forall s (m :: * -> *) a.
TravT s m a
-> TravState m s -> m (Either CError (a, TravState m s))
unTravT (a -> TravT s m b
k a
x) TravState m s
s1
Left CError
e -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left CError
e))
instance MonadTrans (TravT s) where
lift :: forall (m :: * -> *) a. Monad m => m a -> TravT s m a
lift m a
m = forall s (m :: * -> *) a.
(TravState m s -> m (Either CError (a, TravState m s)))
-> TravT s m a
TravT (\TravState m s
s -> (\a
x -> forall a b. b -> Either a b
Right (a
x, TravState m s
s)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
m)
instance MonadIO m => MonadIO (TravT s m) where
liftIO :: forall a. IO a -> TravT s m a
liftIO = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
instance Monad m => MonadName (TravT s m) where
genName :: TravT s m Name
genName = forall (m :: * -> *) s. Monad m => TravT s m Name
generateName
instance Monad m => MonadSymtab (TravT s m) where
getDefTable :: TravT s m DefTable
getDefTable = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall (m :: * -> *) s. TravState m s -> DefTable
symbolTable
withDefTable :: forall a. (DefTable -> (a, DefTable)) -> TravT s m a
withDefTable DefTable -> (a, DefTable)
f = do
TravState m s
ts <- forall s (m :: * -> *). MonadState s m => m s
get
let (a
r,DefTable
symt') = DefTable -> (a, DefTable)
f (forall (m :: * -> *) s. TravState m s -> DefTable
symbolTable TravState m s
ts)
forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ TravState m s
ts { symbolTable :: DefTable
symbolTable = DefTable
symt' }
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
instance Monad m => MonadCError (TravT s m) where
throwTravError :: forall e a. Error e => e -> TravT s m a
throwTravError e
e = forall s (m :: * -> *) a.
(TravState m s -> m (Either CError (a, TravState m s)))
-> TravT s m a
TravT (\TravState m s
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (forall e. Error e => e -> CError
toError e
e)))
catchTravError :: forall a. TravT s m a -> (CError -> TravT s m a) -> TravT s m a
catchTravError TravT s m a
a CError -> TravT s m a
handler = forall s (m :: * -> *) a.
(TravState m s -> m (Either CError (a, TravState m s)))
-> TravT s m a
TravT (\TravState m s
s -> forall s (m :: * -> *) a.
TravT s m a
-> TravState m s -> m (Either CError (a, TravState m s))
unTravT TravT s m a
a TravState m s
s forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Either CError (a, TravState m s)
x -> case Either CError (a, TravState m s)
x of
Left CError
e -> forall s (m :: * -> *) a.
TravT s m a
-> TravState m s -> m (Either CError (a, TravState m s))
unTravT (CError -> TravT s m a
handler CError
e) TravState m s
s
Right (a, TravState m s)
r -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (a, TravState m s)
r))
recordError :: forall e. Error e => e -> TravT s m ()
recordError e
e = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \TravState m s
st -> TravState m s
st { rerrors :: RList CError
rerrors = (forall (m :: * -> *) s. TravState m s -> RList CError
rerrors TravState m s
st) forall a. Reversed [a] -> a -> Reversed [a]
`snoc` forall e. Error e => e -> CError
toError e
e }
getErrors :: TravT s m [CError]
getErrors = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall a. Reversed [a] -> [a]
RList.reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) s. TravState m s -> RList CError
rerrors)
instance Monad m => MonadTrav (TravT s m) where
handleDecl :: DeclEvent -> TravT s m ()
handleDecl DeclEvent
d = (forall a b. (a -> b) -> a -> b
$ DeclEvent
d) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall (m :: * -> *) s. TravState m s -> DeclEvent -> TravT s m ()
doHandleExtDecl
type Trav s a = TravT s Identity a
unTrav :: Trav s a -> TravT s Identity a
unTrav :: forall s a. Trav s a -> Trav s a
unTrav = forall a. a -> a
id
data CLanguage = C89 | C99 | GNU89 | GNU99
data TravOptions =
TravOptions {
TravOptions -> CLanguage
language :: CLanguage
}
data TravState m s =
TravState {
forall (m :: * -> *) s. TravState m s -> DefTable
symbolTable :: DefTable,
forall (m :: * -> *) s. TravState m s -> RList CError
rerrors :: RList CError,
forall (m :: * -> *) s. TravState m s -> [Name]
nameGenerator :: [Name],
forall (m :: * -> *) s. TravState m s -> DeclEvent -> TravT s m ()
doHandleExtDecl :: (DeclEvent -> TravT s m ()),
forall (m :: * -> *) s. TravState m s -> s
userState :: s,
forall (m :: * -> *) s. TravState m s -> TravOptions
options :: TravOptions
}
travErrors :: TravState m s -> [CError]
travErrors :: forall (m :: * -> *) s. TravState m s -> [CError]
travErrors = forall a. Reversed [a] -> [a]
RList.reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) s. TravState m s -> RList CError
rerrors
initTravState :: Monad m => s -> TravState m s
initTravState :: forall (m :: * -> *) s. Monad m => s -> TravState m s
initTravState s
userst =
TravState {
symbolTable :: DefTable
symbolTable = DefTable
emptyDefTable,
rerrors :: RList CError
rerrors = forall a. Reversed [a]
RList.empty,
nameGenerator :: [Name]
nameGenerator = [Name]
newNameSupply,
doHandleExtDecl :: DeclEvent -> TravT s m ()
doHandleExtDecl = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ()),
userState :: s
userState = s
userst,
options :: TravOptions
options = TravOptions { language :: CLanguage
language = CLanguage
C99 }
}
modifyUserState :: (s -> s) -> Trav s ()
modifyUserState :: forall s. (s -> s) -> Trav s ()
modifyUserState s -> s
f = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \TravState Identity s
ts -> TravState Identity s
ts { userState :: s
userState = s -> s
f (forall (m :: * -> *) s. TravState m s -> s
userState TravState Identity s
ts) }
getUserState :: Trav s s
getUserState :: forall s. Trav s s
getUserState = forall (m :: * -> *) s. TravState m s -> s
userState forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall s (m :: * -> *). MonadState s m => m s
get
modifyOptions :: (TravOptions -> TravOptions) -> Trav s ()
modifyOptions :: forall s. (TravOptions -> TravOptions) -> Trav s ()
modifyOptions TravOptions -> TravOptions
f = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \TravState Identity s
ts -> TravState Identity s
ts { options :: TravOptions
options = TravOptions -> TravOptions
f (forall (m :: * -> *) s. TravState m s -> TravOptions
options TravState Identity s
ts) }
generateName :: Monad m => TravT s m Name
generateName :: forall (m :: * -> *) s. Monad m => TravT s m Name
generateName =
forall s (m :: * -> *). MonadState s m => m s
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TravState m s
ts ->
do let (Name
new_name : [Name]
gen') = forall (m :: * -> *) s. TravState m s -> [Name]
nameGenerator TravState m s
ts
forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ TravState m s
ts { nameGenerator :: [Name]
nameGenerator = [Name]
gen'}
forall (m :: * -> *) a. Monad m => a -> m a
return Name
new_name
mapMaybeM :: (Monad m) => (Maybe a) -> (a -> m b) -> m (Maybe b)
mapMaybeM :: forall (m :: * -> *) a b.
Monad m =>
Maybe a -> (a -> m b) -> m (Maybe b)
mapMaybeM Maybe a
m a -> m b
f = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m b
f) Maybe a
m
maybeM :: (Monad m) => (Maybe a) -> (a -> m ()) -> m ()
maybeM :: forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
maybeM Maybe a
m a -> m ()
f = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) a -> m ()
f Maybe a
m
mapSndM :: (Monad m) => (b -> m c) -> (a,b) -> m (a,c)
mapSndM :: forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a, b) -> m (a, c)
mapSndM b -> m c
f (a
a,b
b) = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((,) a
a) (b -> m c
f b
b)
concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]
concatMapM :: forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM a -> m [b]
f = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> m [b]
f