{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleContexts,FlexibleInstances,
             PatternGuards, RankNTypes, ScopedTypeVariables, LambdaCase #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Language.C.Analysis.TravMonad
-- Copyright   :  (c) 2008 Benedikt Huber
-- License     :  BSD-style
-- Maintainer  :  benedikt.huber@gmail.com
-- Stability   :  alpha
-- Portability :  ghc
--
-- Monad for Traversals of the C AST.
--
-- For the traversal, we maintain a symboltable and need MonadError and unique
-- name generation facilities.
-- Furthermore, the user may provide callbacks to handle declarations and definitions.
-----------------------------------------------------------------------------
module Language.C.Analysis.TravMonad (
    -- * Name generation monad
    MonadName(..),
    -- * Symbol table monad
    MonadSymtab(..),
    -- * Specialized C error-handling monad
    MonadCError(..),
    -- * AST traversal monad
    MonadTrav(..),
    -- * Handling declarations
    handleTagDecl, handleTagDef, handleEnumeratorDef, handleTypeDef,
    handleObjectDef,handleFunDef,handleVarDecl,handleParamDecl,
    handleAsmBlock,
    -- * Symbol table scope modification
    enterPrototypeScope,leavePrototypeScope,
    enterFunctionScope,leaveFunctionScope,
    enterBlockScope,leaveBlockScope,
    -- * Symbol table lookup (delegate)
    lookupTypeDef, lookupObject,
    -- * Symbol table modification
    createSUERef,
    -- * Additional error handling facilities
    hadHardErrors,handleTravError,throwOnLeft,
    astError, warn,
    -- * Trav - default MonadTrav implementation
    Trav, TravT,
    runTravT, runTravTWithTravState, runTrav, runTrav_,
    TravState,initTravState,withExtDeclHandler,modifyUserState,userState,
    getUserState,
    TravOptions(..),modifyOptions,
    travErrors,
    -- * Language options
    CLanguage(..),
    -- * Helpers
    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
    -- | unique name generation
    genName :: m Name

class (Monad m) => MonadSymtab m where
    -- symbol table handling
    -- | return the definition table
    getDefTable :: m DefTable
    -- | perform an action modifying the definition table
    withDefTable :: (DefTable -> (a, DefTable)) -> m a

class (Monad m) => MonadCError m where
    -- error handling facilities

    -- | throw an 'Error'
    throwTravError :: Error e => e -> m a
    -- | catch an 'Error' (we could implement dynamically-typed catch here)
    catchTravError :: m a -> (CError -> m a) -> m a
    -- | remember that an 'Error' occurred (without throwing it)
    recordError    :: Error e => e -> m ()
    -- | return the list of recorded errors
    getErrors      :: m [CError]

-- | Traversal monad
class (MonadName m, MonadSymtab m, MonadCError m) => MonadTrav m where
    -- | handling declarations and definitions
    handleDecl :: DeclEvent -> m ()

-- * handling declarations

-- check wheter a redefinition is ok
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 -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Redeclared t1
old_def   -> RedefError -> m ()
forall e a. Error e => e -> m a
forall (m :: * -> *) e a. (MonadCError m, Error e) => e -> m a
throwTravError (RedefError -> m ()) -> RedefError -> m ()
forall a b. (a -> b) -> a -> b
$
            ErrorLevel
-> String -> RedefKind -> NodeInfo -> NodeInfo -> RedefError
redefinition ErrorLevel
LevelError String
subject RedefKind
DuplicateDef (t -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo t
new_decl) (t1 -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo t1
old_def)
        KindMismatch t1
old_def -> RedefError -> m ()
forall e a. Error e => e -> m a
forall (m :: * -> *) e a. (MonadCError m, Error e) => e -> m a
throwTravError (RedefError -> m ()) -> RedefError -> m ()
forall a b. (a -> b) -> a -> b
$
            ErrorLevel
-> String -> RedefKind -> NodeInfo -> NodeInfo -> RedefError
redefinition ErrorLevel
LevelError String
subject RedefKind
DiffKindRedecl (t -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo t
new_decl) (t1 -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo t1
old_def)
        Shadowed t1
_old_def     ->  () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            -- warn $
            -- redefinition LevelWarn subject ShadowedDef (nodeInfo new_decl) (nodeInfo old_def)
        KeepDef t1
_old_def      -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | forward declaration of a tag. Only necessary for name analysis, but otherwise no semantic
-- consequences.
handleTagDecl :: (MonadCError m, MonadSymtab m) => TagFwdDecl -> m ()
handleTagDecl :: forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
TagFwdDecl -> m ()
handleTagDecl TagFwdDecl
decl = do
    DeclarationStatus TagEntry
redecl <- (DefTable -> (DeclarationStatus TagEntry, DefTable))
-> m (DeclarationStatus TagEntry)
forall a. (DefTable -> (a, DefTable)) -> m a
forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable ((DefTable -> (DeclarationStatus TagEntry, DefTable))
 -> m (DeclarationStatus TagEntry))
-> (DefTable -> (DeclarationStatus TagEntry, DefTable))
-> m (DeclarationStatus TagEntry)
forall a b. (a -> b) -> a -> b
$ SUERef
-> TagFwdDecl -> DefTable -> (DeclarationStatus TagEntry, DefTable)
declareTag (TagFwdDecl -> SUERef
forall a. HasSUERef a => a -> SUERef
sueRef TagFwdDecl
decl) TagFwdDecl
decl
    String -> TagFwdDecl -> DeclarationStatus TagEntry -> m ()
forall (m :: * -> *) t t1.
(MonadCError m, CNode t, CNode t1) =>
String -> t -> DeclarationStatus t1 -> m ()
checkRedef (SUERef -> String
sueRefToString (SUERef -> String) -> SUERef -> String
forall a b. (a -> b) -> a -> b
$ TagFwdDecl -> SUERef
forall a. HasSUERef a => a -> SUERef
sueRef TagFwdDecl
decl) TagFwdDecl
decl DeclarationStatus TagEntry
redecl

-- | define the given composite type or enumeration
-- If there is a declaration visible, overwrite it with the definition.
-- Otherwise, enter a new definition in the current namespace.
-- If there is already a definition present, yield an error (redeclaration).
handleTagDef :: (MonadTrav m) => TagDef -> m ()
handleTagDef :: forall (m :: * -> *). MonadTrav m => TagDef -> m ()
handleTagDef TagDef
def = do
    DeclarationStatus TagEntry
redecl <- (DefTable -> (DeclarationStatus TagEntry, DefTable))
-> m (DeclarationStatus TagEntry)
forall a. (DefTable -> (a, DefTable)) -> m a
forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable ((DefTable -> (DeclarationStatus TagEntry, DefTable))
 -> m (DeclarationStatus TagEntry))
-> (DefTable -> (DeclarationStatus TagEntry, DefTable))
-> m (DeclarationStatus TagEntry)
forall a b. (a -> b) -> a -> b
$ SUERef
-> TagDef -> DefTable -> (DeclarationStatus TagEntry, DefTable)
defineTag (TagDef -> SUERef
forall a. HasSUERef a => a -> SUERef
sueRef TagDef
def) TagDef
def
    String -> TagDef -> DeclarationStatus TagEntry -> m ()
forall (m :: * -> *) t t1.
(MonadCError m, CNode t, CNode t1) =>
String -> t -> DeclarationStatus t1 -> m ()
checkRedef (SUERef -> String
sueRefToString (SUERef -> String) -> SUERef -> String
forall a b. (a -> b) -> a -> b
$ TagDef -> SUERef
forall a. HasSUERef a => a -> SUERef
sueRef TagDef
def) TagDef
def DeclarationStatus TagEntry
redecl
    DeclEvent -> m ()
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 = Enumerator -> Ident
forall n. Declaration n => n -> Ident
declIdent Enumerator
enumerator
    DeclarationStatus IdentEntry
redecl <- (DefTable -> (DeclarationStatus IdentEntry, DefTable))
-> m (DeclarationStatus IdentEntry)
forall a. (DefTable -> (a, DefTable)) -> m a
forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable ((DefTable -> (DeclarationStatus IdentEntry, DefTable))
 -> m (DeclarationStatus IdentEntry))
-> (DefTable -> (DeclarationStatus IdentEntry, DefTable))
-> m (DeclarationStatus IdentEntry)
forall a b. (a -> b) -> a -> b
$ Ident
-> IdentDecl
-> DefTable
-> (DeclarationStatus IdentEntry, DefTable)
defineScopedIdent Ident
ident (Enumerator -> IdentDecl
EnumeratorDef Enumerator
enumerator)
    String -> Ident -> DeclarationStatus IdentEntry -> m ()
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
    () -> m ()
forall a. a -> m a
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 <- (DefTable -> (DeclarationStatus IdentEntry, DefTable))
-> m (DeclarationStatus IdentEntry)
forall a. (DefTable -> (a, DefTable)) -> m a
forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable ((DefTable -> (DeclarationStatus IdentEntry, DefTable))
 -> m (DeclarationStatus IdentEntry))
-> (DefTable -> (DeclarationStatus IdentEntry, DefTable))
-> m (DeclarationStatus IdentEntry)
forall a b. (a -> b) -> a -> b
$ Ident
-> TypeDef -> DefTable -> (DeclarationStatus IdentEntry, DefTable)
defineTypeDef Ident
ident TypeDef
typeDef
    -- C11 6.7/3 If an identifier has no linkage, there shall be no more than
    -- one declaration of the identifier (in a declarator or type specifier)
    -- with the same scope and in the same name space, except that: a typedef
    -- name may be redefined to denote the same type as it currently does,
    -- provided that type is not a variably modified type;
    case DeclarationStatus IdentEntry
redecl of
      Redeclared (Left (TypeDef Ident
_ Type
t2 Attributes
_ NodeInfo
_)) | Type -> Type -> Bool
sameType Type
t1 Type
t2 -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      DeclarationStatus IdentEntry
_ -> String -> TypeDef -> DeclarationStatus IdentEntry -> m ()
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
    DeclEvent -> m ()
forall (m :: * -> *). MonadTrav m => DeclEvent -> m ()
handleDecl (TypeDef -> DeclEvent
TypeDefEvent TypeDef
typeDef)
    () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

handleAsmBlock :: (MonadTrav m) => AsmBlock -> m ()
handleAsmBlock :: forall (m :: * -> *). MonadTrav m => AsmBlock -> m ()
handleAsmBlock AsmBlock
asm = DeclEvent -> m ()
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 =
  RedefError -> m ()
forall e a. Error e => e -> m a
forall (m :: * -> *) e a. (MonadCError m, Error e) => e -> m a
throwTravError (RedefError -> m ()) -> RedefError -> m ()
forall a b. (a -> b) -> a -> b
$ ErrorLevel
-> String -> RedefKind -> NodeInfo -> NodeInfo -> RedefError
redefinition ErrorLevel
lvl (Ident -> String
identToString Ident
name) RedefKind
kind (new -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo new
new) (old -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo old
old)

-- TODO: unused
_checkIdentTyRedef :: (MonadCError m) => IdentEntry -> (DeclarationStatus IdentEntry) -> m ()
_checkIdentTyRedef :: forall (m :: * -> *).
MonadCError m =>
IdentEntry -> DeclarationStatus IdentEntry -> m ()
_checkIdentTyRedef (Right IdentDecl
decl) DeclarationStatus IdentEntry
status = IdentDecl -> DeclarationStatus IdentEntry -> m ()
forall (m :: * -> *).
MonadCError m =>
IdentDecl -> DeclarationStatus IdentEntry -> m ()
checkVarRedef IdentDecl
decl DeclarationStatus IdentEntry
status
_checkIdentTyRedef (Left TypeDef
tydef) (KindMismatch IdentEntry
old_def) =
  Ident -> ErrorLevel -> TypeDef -> IdentEntry -> RedefKind -> m ()
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) =
  Ident -> ErrorLevel -> TypeDef -> IdentEntry -> RedefKind -> m ()
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
_ = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- Check whether it is ok to declare a variable already in scope
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
        -- always an error
        KindMismatch IdentEntry
old_def -> IdentEntry -> RedefKind -> m ()
forall {m :: * -> *} {old}.
(MonadCError m, CNode old) =>
old -> RedefKind -> m ()
redefVarErr IdentEntry
old_def RedefKind
DiffKindRedecl
        -- Declaration referencing definition:
        --   * new entry has to be a declaration
        --   * old entry and new entry have to have linkage and agree on linkage
        --   * types have to match
        KeepDef (Right IdentDecl
old_def) | Bool -> Bool
not (IdentDecl -> IdentDecl -> Bool
forall {d} {d}. (Declaration d, Declaration d) => d -> d -> Bool
agreeOnLinkage IdentDecl
def IdentDecl
old_def) -> IdentDecl -> IdentDecl -> m ()
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 -> Either TypeMismatch () -> m ()
forall (m :: * -> *) e a.
(MonadCError m, Error e) =>
Either e a -> m a
throwOnLeft (Either TypeMismatch () -> m ()) -> Either TypeMismatch () -> m ()
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Either TypeMismatch ()
checkCompatibleTypes Type
new_ty (IdentDecl -> Type
forall n. Declaration n => n -> Type
declType IdentDecl
old_def)
        -- redefinition:
        --   * old entry has to be a declaration or tentative definition
        --   * old entry and new entry have to have linkage and agree on linkage
        --   * types have to match
        Redeclared (Right IdentDecl
old_def) | Bool -> Bool
not (IdentDecl -> IdentDecl -> Bool
forall {d} {d}. (Declaration d, Declaration d) => d -> d -> Bool
agreeOnLinkage IdentDecl
def IdentDecl
old_def) -> IdentDecl -> IdentDecl -> m ()
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) -> IdentDecl -> RedefKind -> m ()
forall {m :: * -> *} {old}.
(MonadCError m, CNode old) =>
old -> RedefKind -> m ()
redefVarErr IdentDecl
old_def RedefKind
DuplicateDef
                                   | Bool
otherwise -> Either TypeMismatch () -> m ()
forall (m :: * -> *) e a.
(MonadCError m, Error e) =>
Either e a -> m a
throwOnLeft (Either TypeMismatch () -> m ()) -> Either TypeMismatch () -> m ()
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Either TypeMismatch ()
checkCompatibleTypes Type
new_ty (IdentDecl -> Type
forall n. Declaration n => n -> Type
declType IdentDecl
old_def)
        -- NewDecl/Shadowed is ok
        DeclarationStatus IdentEntry
_ -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    where
    redefVarErr :: old -> RedefKind -> m ()
redefVarErr old
old_def RedefKind
kind = Ident -> ErrorLevel -> IdentDecl -> old -> RedefKind -> m ()
forall (m :: * -> *) old new.
(MonadCError m, CNode old, CNode new) =>
Ident -> ErrorLevel -> new -> old -> RedefKind -> m ()
redefErr (IdentDecl -> Ident
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 (new -> Linkage
forall d. Declaration d => d -> Linkage
declLinkage new
new_def, old -> Linkage
forall d. Declaration d => d -> Linkage
declLinkage old
old_def) of
            (Linkage
NoLinkage, Linkage
_) -> Ident -> ErrorLevel -> new -> old -> RedefKind -> m ()
forall (m :: * -> *) old new.
(MonadCError m, CNode old, CNode new) =>
Ident -> ErrorLevel -> new -> old -> RedefKind -> m ()
redefErr (new -> Ident
forall n. Declaration n => n -> Ident
declIdent new
new_def) ErrorLevel
LevelError new
new_def old
old_def RedefKind
NoLinkageOld
            (Linkage, Linkage)
_              -> Ident -> ErrorLevel -> new -> old -> RedefKind -> m ()
forall (m :: * -> *) old new.
(MonadCError m, CNode old, CNode new) =>
Ident -> ErrorLevel -> new -> old -> RedefKind -> m ()
redefErr (new -> Ident
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 = IdentDecl -> Type
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
        | d -> Storage
forall d. Declaration d => d -> Storage
declStorage d
old_def Storage -> Storage -> Bool
forall a. Eq a => a -> a -> Bool
== Linkage -> Storage
FunLinkage Linkage
InternalLinkage = Bool
True
        | Bool -> Bool
not (Storage -> Bool
hasLinkage (Storage -> Bool) -> Storage -> Bool
forall a b. (a -> b) -> a -> b
$ d -> Storage
forall d. Declaration d => d -> Storage
declStorage d
new_def) Bool -> Bool -> Bool
|| Bool -> Bool
not (Storage -> Bool
hasLinkage (Storage -> Bool) -> Storage -> Bool
forall a b. (a -> b) -> a -> b
$ d -> Storage
forall d. Declaration d => d -> Storage
declStorage d
old_def) = Bool
False
        | (d -> Linkage
forall d. Declaration d => d -> Linkage
declLinkage d
new_def) Linkage -> Linkage -> Bool
forall a. Eq a => a -> a -> Bool
/= (d -> Linkage
forall d. Declaration d => d -> Linkage
declLinkage d
old_def) = Bool
False
        | Bool
otherwise = Bool
True

-- | handle variable declarations (external object declarations and function prototypes)
-- variable declarations are either function prototypes, or external declarations, and not very
-- interesting on their own. we only put them in the symbol table and call the handle.
-- declarations never override definitions
handleVarDecl :: (MonadTrav m) => Bool -> Decl -> m ()
handleVarDecl :: forall (m :: * -> *). MonadTrav m => Bool -> Decl -> m ()
handleVarDecl Bool
is_local Decl
decl = do
    IdentDecl
def <- Decl -> (IdentDecl -> Bool) -> m IdentDecl
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Decl -> (IdentDecl -> Bool) -> m IdentDecl
enterDecl Decl
decl (Bool -> IdentDecl -> Bool
forall a b. a -> b -> a
const Bool
False)
    DeclEvent -> m ()
forall (m :: * -> *). MonadTrav m => DeclEvent -> m ()
handleDecl ((if Bool
is_local then IdentDecl -> DeclEvent
LocalEvent else IdentDecl -> DeclEvent
DeclEvent) IdentDecl
def)

-- | handle parameter declaration. The interesting part is that parameters can be abstract
-- (if they are part of a type). If they have a name, we enter the name (usually in function prototype or function scope),
-- checking if there are duplicate definitions.
-- FIXME: I think it would be more transparent to handle parameter declarations in a special way
handleParamDecl :: (MonadTrav m) => ParamDecl -> m ()
handleParamDecl :: forall (m :: * -> *). MonadTrav m => ParamDecl -> m ()
handleParamDecl pd :: ParamDecl
pd@(AbstractParamDecl VarDecl
_ NodeInfo
_) = DeclEvent -> m ()
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 Maybe Initializer
forall a. Maybe a
Nothing NodeInfo
node)
    DeclarationStatus IdentEntry
redecl <- (DefTable -> (DeclarationStatus IdentEntry, DefTable))
-> m (DeclarationStatus IdentEntry)
forall a. (DefTable -> (a, DefTable)) -> m a
forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable ((DefTable -> (DeclarationStatus IdentEntry, DefTable))
 -> m (DeclarationStatus IdentEntry))
-> (DefTable -> (DeclarationStatus IdentEntry, DefTable))
-> m (DeclarationStatus IdentEntry)
forall a b. (a -> b) -> a -> b
$ Ident
-> IdentDecl
-> DefTable
-> (DeclarationStatus IdentEntry, DefTable)
defineScopedIdent (IdentDecl -> Ident
forall n. Declaration n => n -> Ident
declIdent IdentDecl
def) IdentDecl
def
    IdentDecl -> DeclarationStatus IdentEntry -> m ()
forall (m :: * -> *).
MonadCError m =>
IdentDecl -> DeclarationStatus IdentEntry -> m ()
checkVarRedef IdentDecl
def DeclarationStatus IdentEntry
redecl
    DeclEvent -> m ()
forall (m :: * -> *). MonadTrav m => DeclEvent -> m ()
handleDecl (ParamDecl -> DeclEvent
ParamEvent ParamDecl
pd)

-- shared impl
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 <- (DefTable -> (DeclarationStatus IdentEntry, DefTable))
-> m (DeclarationStatus IdentEntry)
forall a. (DefTable -> (a, DefTable)) -> m a
forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable ((DefTable -> (DeclarationStatus IdentEntry, DefTable))
 -> m (DeclarationStatus IdentEntry))
-> (DefTable -> (DeclarationStatus IdentEntry, DefTable))
-> m (DeclarationStatus IdentEntry)
forall a b. (a -> b) -> a -> b
$
              (IdentDecl -> Bool)
-> Ident
-> IdentDecl
-> DefTable
-> (DeclarationStatus IdentEntry, DefTable)
defineScopedIdentWhen IdentDecl -> Bool
cond (IdentDecl -> Ident
forall n. Declaration n => n -> Ident
declIdent IdentDecl
def) IdentDecl
def
    IdentDecl -> DeclarationStatus IdentEntry -> m ()
forall (m :: * -> *).
MonadCError m =>
IdentDecl -> DeclarationStatus IdentEntry -> m ()
checkVarRedef IdentDecl
def DeclarationStatus IdentEntry
redecl
    IdentDecl -> m IdentDecl
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return IdentDecl
def

-- | handle function definitions
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 <- (DefTable -> (DeclarationStatus IdentEntry, DefTable))
-> m (DeclarationStatus IdentEntry)
forall a. (DefTable -> (a, DefTable)) -> m a
forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable ((DefTable -> (DeclarationStatus IdentEntry, DefTable))
 -> m (DeclarationStatus IdentEntry))
-> (DefTable -> (DeclarationStatus IdentEntry, DefTable))
-> m (DeclarationStatus IdentEntry)
forall a b. (a -> b) -> a -> b
$
              (IdentDecl -> Bool)
-> Ident
-> IdentDecl
-> DefTable
-> (DeclarationStatus IdentEntry, DefTable)
defineScopedIdentWhen IdentDecl -> Bool
isDeclaration Ident
ident IdentDecl
def
    IdentDecl -> DeclarationStatus IdentEntry -> m ()
forall (m :: * -> *).
MonadCError m =>
IdentDecl -> DeclarationStatus IdentEntry -> m ()
checkVarRedef IdentDecl
def DeclarationStatus IdentEntry
redecl
    DeclEvent -> m ()
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
_ = () -> Either TypeMismatch ()
forall a b. b -> Either a b
Right ()

-- | handle object defintions (maybe tentative)
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 <- (DefTable -> (DeclarationStatus IdentEntry, DefTable))
-> m (DeclarationStatus IdentEntry)
forall a. (DefTable -> (a, DefTable)) -> m a
forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable ((DefTable -> (DeclarationStatus IdentEntry, DefTable))
 -> m (DeclarationStatus IdentEntry))
-> (DefTable -> (DeclarationStatus IdentEntry, DefTable))
-> m (DeclarationStatus IdentEntry)
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
    IdentDecl -> DeclarationStatus IdentEntry -> m ()
forall (m :: * -> *).
MonadCError m =>
IdentDecl -> DeclarationStatus IdentEntry -> m ()
checkVarRedef IdentDecl
def DeclarationStatus IdentEntry
redecl
    DeclEvent -> m ()
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

-- * scope manipulation
--
--  * file scope: outside of parameter lists and blocks (outermost)
--
--  * function prototype scope
--
--  * function scope: labels are visible within the entire function, and declared implicitely
--
--  * block scope
updDefTable :: (MonadSymtab m) => (DefTable -> DefTable) -> m ()
updDefTable :: forall (m :: * -> *).
MonadSymtab m =>
(DefTable -> DefTable) -> m ()
updDefTable DefTable -> DefTable
f = (DefTable -> ((), DefTable)) -> m ()
forall a. (DefTable -> (a, DefTable)) -> m a
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 = (DefTable -> DefTable) -> m ()
forall (m :: * -> *).
MonadSymtab m =>
(DefTable -> DefTable) -> m ()
updDefTable (DefTable -> DefTable
ST.enterBlockScope)

leavePrototypeScope :: (MonadSymtab m) => m ()
leavePrototypeScope :: forall (m :: * -> *). MonadSymtab m => m ()
leavePrototypeScope = (DefTable -> DefTable) -> m ()
forall (m :: * -> *).
MonadSymtab m =>
(DefTable -> DefTable) -> m ()
updDefTable (DefTable -> DefTable
ST.leaveBlockScope)

enterFunctionScope :: (MonadSymtab m) => m ()
enterFunctionScope :: forall (m :: * -> *). MonadSymtab m => m ()
enterFunctionScope = (DefTable -> DefTable) -> m ()
forall (m :: * -> *).
MonadSymtab m =>
(DefTable -> DefTable) -> m ()
updDefTable (DefTable -> DefTable
ST.enterFunctionScope)

leaveFunctionScope :: (MonadSymtab m) => m ()
leaveFunctionScope :: forall (m :: * -> *). MonadSymtab m => m ()
leaveFunctionScope = (DefTable -> DefTable) -> m ()
forall (m :: * -> *).
MonadSymtab m =>
(DefTable -> DefTable) -> m ()
updDefTable (DefTable -> DefTable
ST.leaveFunctionScope)

enterBlockScope :: (MonadSymtab m) => m ()
enterBlockScope :: forall (m :: * -> *). MonadSymtab m => m ()
enterBlockScope = (DefTable -> DefTable) -> m ()
forall (m :: * -> *).
MonadSymtab m =>
(DefTable -> DefTable) -> m ()
updDefTable (DefTable -> DefTable
ST.enterBlockScope)

leaveBlockScope :: (MonadSymtab m) => m ()
leaveBlockScope :: forall (m :: * -> *). MonadSymtab m => m ()
leaveBlockScope = (DefTable -> DefTable) -> m ()
forall (m :: * -> *).
MonadSymtab m =>
(DefTable -> DefTable) -> m ()
updDefTable (DefTable -> DefTable
ST.leaveBlockScope)

-- * Lookup

-- | lookup a type definition
-- the 'wrong kind of object' is an internal error here,
-- because the parser should distinguish typeDefs and other
-- objects
lookupTypeDef :: (MonadCError m, MonadSymtab m) => Ident -> m Type
lookupTypeDef :: forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Ident -> m Type
lookupTypeDef Ident
ident =
    m DefTable
forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable m DefTable -> (DefTable -> m Type) -> m Type
forall a b. m a -> (a -> m b) -> m b
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                             ->
          NodeInfo -> String -> m Type
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError (Ident -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo Ident
ident) (String -> m Type) -> String -> m Type
forall a b. (a -> b) -> a -> b
$ String
"unbound typeDef: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
identToString Ident
ident
        Just (Left (TypeDef Ident
def_ident Type
ty Attributes
_ NodeInfo
_)) -> Ident -> Ident -> m ()
forall (m :: * -> *) u d.
(MonadCError m, MonadSymtab m, CNode u, CNode d) =>
u -> d -> m ()
addRef Ident
ident Ident
def_ident m () -> m Type -> m Type
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> m Type
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty
        Just (Right IdentDecl
d)                      -> NodeInfo -> String -> m Type
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError (Ident -> NodeInfo
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 "String -> String -> String
forall a. [a] -> [a] -> [a]
++ (IdentDecl -> String
objKindDescr IdentDecl
d)
                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (for identifier `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
identToString Ident
ident String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"')"


-- | lookup an object, function or enumerator
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 <- (DefTable -> Maybe IdentEntry)
-> m DefTable -> m (Maybe IdentEntry)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Ident -> DefTable -> Maybe IdentEntry
lookupIdent Ident
ident) m DefTable
forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable
    Maybe IdentEntry
-> (IdentEntry -> m IdentDecl) -> m (Maybe IdentDecl)
forall (m :: * -> *) a b.
Monad m =>
Maybe a -> (a -> m b) -> m (Maybe b)
mapMaybeM Maybe IdentEntry
old_decl ((IdentEntry -> m IdentDecl) -> m (Maybe IdentDecl))
-> (IdentEntry -> m IdentDecl) -> m (Maybe IdentDecl)
forall a b. (a -> b) -> a -> b
$ \IdentEntry
obj ->
        case IdentEntry
obj of
        Right IdentDecl
objdef -> Ident -> IdentDecl -> m ()
forall (m :: * -> *) u d.
(MonadCError m, MonadSymtab m, CNode u, CNode d) =>
u -> d -> m ()
addRef Ident
ident IdentDecl
objdef m () -> m IdentDecl -> m IdentDecl
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IdentDecl -> m IdentDecl
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return IdentDecl
objdef
        Left TypeDef
_tydef  -> NodeInfo -> String -> m IdentDecl
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError (Ident -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo Ident
ident) (String -> String -> String -> String
mismatchErr String
"lookupObject" String
"an object" String
"a typeDef")

-- | add link between use and definition (private)
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 (u -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo u
use, d -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo d
def) of
    (NodeInfo Position
_ PosLength
_ Name
useName, NodeInfo Position
_ PosLength
_ Name
defName) ->
      (DefTable -> ((), DefTable)) -> m ()
forall a. (DefTable -> (a, DefTable)) -> m a
forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable
      (\DefTable
dt ->
         ((),
          DefTable
dt { refTable = insert (nameId useName) defName (refTable dt) }
         )
      )
    (NodeInfo
_, NodeInfo
_) -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- Don't have Names for both, so can't record.


mismatchErr :: String -> String -> String -> String
mismatchErr :: String -> String -> String -> String
mismatchErr String
ctx String
expect String
found = String
ctx String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": Expected " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
expect String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", but found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
found

-- * inserting declarations

-- | create a reference to a struct\/union\/enum
--
-- This currently depends on the fact the structs are tagged with unique names.
-- We could use the name generation of TravMonad as well, which might be the better
-- choice when dealing with autogenerated code.
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) = SUERef -> m SUERef
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return(SUERef -> m SUERef) -> SUERef -> m SUERef
forall 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 = SUERef -> m SUERef
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SUERef -> m SUERef) -> SUERef -> m SUERef
forall a b. (a -> b) -> a -> b
$ Name -> SUERef
AnonymousRef Name
name
                               | Bool
otherwise = NodeInfo -> String -> m SUERef
forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node_info String
"struct/union/enum definition without unique name"

-- * error handling facilities

handleTravError :: (MonadCError m) => m a -> m (Maybe a)
handleTravError :: forall (m :: * -> *) a. MonadCError m => m a -> m (Maybe a)
handleTravError m a
a = (a -> Maybe a) -> m a -> m (Maybe a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Maybe a
forall a. a -> Maybe a
Just m a
a m (Maybe a) -> (CError -> m (Maybe a)) -> m (Maybe a)
forall a. m a -> (CError -> m a) -> m a
forall (m :: * -> *) a.
MonadCError m =>
m a -> (CError -> m a) -> m a
`catchTravError` (\CError
e -> CError -> m ()
forall e. Error e => e -> m ()
forall (m :: * -> *) e. (MonadCError m, Error e) => e -> m ()
recordError CError
e m () -> m (Maybe a) -> m (Maybe a)
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe a -> m (Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing)

-- | check wheter non-recoverable errors occurred
hadHardErrors :: [CError] -> Bool
hadHardErrors :: [CError] -> Bool
hadHardErrors = (CError -> Bool) -> [CError] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any CError -> Bool
forall ex. Error ex => ex -> Bool
isHardError

-- | raise an error caused by a malformed AST
astError :: (MonadCError m) => NodeInfo -> String -> m a
astError :: forall (m :: * -> *) a. MonadCError m => NodeInfo -> String -> m a
astError NodeInfo
node String
msg = InvalidASTError -> m a
forall e a. Error e => e -> m a
forall (m :: * -> *) e a. (MonadCError m, Error e) => e -> m a
throwTravError (InvalidASTError -> m a) -> InvalidASTError -> m a
forall a b. (a -> b) -> a -> b
$ NodeInfo -> String -> InvalidASTError
invalidAST NodeInfo
node String
msg

-- | raise an error based on an Either argument
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) = e -> m a
forall e a. Error e => e -> m a
forall (m :: * -> *) e a. (MonadCError m, Error e) => e -> m a
throwTravError e
err
throwOnLeft (Right a
v)  = a -> m a
forall a. a -> m a
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 = e -> m ()
forall e. Error e => e -> m ()
forall (m :: * -> *) e. (MonadCError m, Error e) => e -> m ()
recordError (e -> ErrorLevel -> e
forall e. Error e => e -> ErrorLevel -> e
changeErrorLevel e
err ErrorLevel
LevelWarn)

-- * The Trav datatype

-- | simple traversal monad, providing user state and callbacks
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      = (TravState m s -> m (Either CError (TravState m s, TravState m s)))
-> TravT s m (TravState m s)
forall s (m :: * -> *) a.
(TravState m s -> m (Either CError (a, TravState m s)))
-> TravT s m a
TravT (\TravState m s
s -> Either CError (TravState m s, TravState m s)
-> m (Either CError (TravState m s, TravState m s))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((TravState m s, TravState m s)
-> Either CError (TravState m s, TravState m s)
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    = (TravState m s -> m (Either CError ((), TravState m s)))
-> TravT s m ()
forall s (m :: * -> *) a.
(TravState m s -> m (Either CError (a, TravState m s)))
-> TravT s m a
TravT (\TravState m s
_ -> Either CError ((), TravState m s)
-> m (Either CError ((), TravState m s))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (((), TravState m s) -> Either CError ((), TravState m s)
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 =
    TravState m s
-> TravT s m a -> m (Either [CError] (a, TravState m s))
forall s (m :: * -> *) a.
Monad m =>
TravState m s
-> TravT s m a -> m (Either [CError] (a, TravState m s))
runTravTWithTravState (s -> TravState m s
forall (m :: * -> *) s. Monad m => s -> TravState m s
initTravState s
state) (TravT s m a -> m (Either [CError] (a, TravState m s)))
-> TravT s m a -> m (Either [CError] (a, TravState m s))
forall a b. (a -> b) -> a -> b
$ do
      (DefTable -> ((), DefTable)) -> TravT s m ()
forall a. (DefTable -> (a, DefTable)) -> TravT s m a
forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable (((), DefTable) -> DefTable -> ((), DefTable)
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 =
    TravT s m a
-> TravState m s -> m (Either CError (a, TravState m s))
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 m (Either CError (a, TravState m s))
-> (Either CError (a, TravState m s)
    -> m (Either [CError] (a, TravState m s)))
-> m (Either [CError] (a, TravState m s))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either [CError] (a, TravState m s)
-> m (Either [CError] (a, TravState m s))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [CError] (a, TravState m s)
 -> m (Either [CError] (a, TravState m s)))
-> (Either CError (a, TravState m s)
    -> Either [CError] (a, TravState m s))
-> Either CError (a, TravState m s)
-> m (Either [CError] (a, TravState m s))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
        Left CError
trav_err                                 -> [CError] -> Either [CError] (a, TravState m s)
forall a b. a -> Either a b
Left [CError
trav_err]
        Right (a
v, TravState m s
ts) | [CError] -> Bool
hadHardErrors (TravState m s -> [CError]
forall (m :: * -> *) s. TravState m s -> [CError]
travErrors TravState m s
ts) -> [CError] -> Either [CError] (a, TravState m s)
forall a b. a -> Either a b
Left (TravState m s -> [CError]
forall (m :: * -> *) s. TravState m s -> [CError]
travErrors TravState m s
ts)
                      | Bool
otherwise                     -> (a, TravState m s) -> Either [CError] (a, TravState m s)
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 = Identity (Either [CError] (a, TravState Identity s))
-> Either [CError] (a, TravState Identity s)
forall a. Identity a -> a
runIdentity (s
-> Trav s a -> Identity (Either [CError] (a, TravState Identity s))
forall (m :: * -> *) s a.
Monad m =>
s -> TravT s m a -> m (Either [CError] (a, TravState m s))
runTravT s
state (Trav s a -> Trav s a
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 = (((a, [CError]), TravState Identity ()) -> (a, [CError]))
-> Either [CError] ((a, [CError]), TravState Identity ())
-> Either [CError] (a, [CError])
forall a b. (a -> b) -> Either [CError] a -> Either [CError] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a, [CError]), TravState Identity ()) -> (a, [CError])
forall a b. (a, b) -> a
fst (Either [CError] ((a, [CError]), TravState Identity ())
 -> Either [CError] (a, [CError]))
-> (Trav () (a, [CError])
    -> Either [CError] ((a, [CError]), TravState Identity ()))
-> Trav () (a, [CError])
-> Either [CError] (a, [CError])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ()
-> Trav () (a, [CError])
-> Either [CError] ((a, [CError]), TravState Identity ())
forall s a.
s -> Trav s a -> Either [CError] (a, TravState Identity s)
runTrav () (Trav () (a, [CError]) -> Either [CError] (a, [CError]))
-> Trav () (a, [CError]) -> Either [CError] (a, [CError])
forall a b. (a -> b) -> a -> b
$
    do a
r <- Trav () a
t
       [CError]
es <- TravT () Identity [CError]
forall (m :: * -> *). MonadCError m => m [CError]
getErrors
       (a, [CError]) -> Trav () (a, [CError])
forall a. a -> TravT () Identity a
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 (TravState m s -> TravState m s) -> TravT s m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TravState m s -> TravState m s) -> TravT s m ())
-> (TravState m s -> TravState m s) -> TravT s m ()
forall a b. (a -> b) -> a -> b
$ \TravState m s
st -> TravState m s
st { doHandleExtDecl = 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 = (a -> b) -> TravT s f a -> TravT s f b
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  = a -> TravT s f a
forall a. a -> TravT s f a
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
(<*>) = 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  = (TravState m s -> m (Either CError (a, TravState m s)))
-> TravT s m a
forall s (m :: * -> *) a.
(TravState m s -> m (Either CError (a, TravState m s)))
-> TravT s m a
TravT (\TravState m s
s -> Either CError (a, TravState m s)
-> m (Either CError (a, TravState m s))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, TravState m s) -> Either CError (a, TravState m s)
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   = (TravState m s -> m (Either CError (b, TravState m s)))
-> TravT s m b
forall s (m :: * -> *) a.
(TravState m s -> m (Either CError (a, TravState m s)))
-> TravT s m a
TravT (\TravState m s
s -> TravT s m a
-> TravState m s -> m (Either CError (a, TravState m 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 m (Either CError (a, TravState m s))
-> (Either CError (a, TravState m s)
    -> m (Either CError (b, TravState m s)))
-> m (Either CError (b, TravState m s))
forall a b. m a -> (a -> m b) -> m b
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) -> TravT s m b
-> TravState m s -> m (Either CError (b, TravState m s))
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       -> Either CError (b, TravState m s)
-> m (Either CError (b, TravState m s))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CError -> Either CError (b, TravState m s)
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 = (TravState m s -> m (Either CError (a, TravState m s)))
-> TravT s m a
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 -> (a, TravState m s) -> Either CError (a, TravState m s)
forall a b. b -> Either a b
Right (a
x, TravState m s
s)) (a -> Either CError (a, TravState m s))
-> m a -> m (Either CError (a, TravState m 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 = m a -> TravT s m a
forall (m :: * -> *) a. Monad m => m a -> TravT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> TravT s m a) -> (IO a -> m a) -> IO a -> TravT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

instance Monad m => MonadName (TravT s m) where
    -- unique name generation
    genName :: TravT s m Name
genName = TravT s m Name
forall (m :: * -> *) s. Monad m => TravT s m Name
generateName

instance Monad m => MonadSymtab (TravT s m) where
    -- symbol table handling
    getDefTable :: TravT s m DefTable
getDefTable = (TravState m s -> DefTable) -> TravT s m DefTable
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TravState m s -> DefTable
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 <- TravT s m (TravState m s)
forall s (m :: * -> *). MonadState s m => m s
get
        let (a
r,DefTable
symt') = DefTable -> (a, DefTable)
f (TravState m s -> DefTable
forall (m :: * -> *) s. TravState m s -> DefTable
symbolTable TravState m s
ts)
        TravState m s -> TravT s m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (TravState m s -> TravT s m ()) -> TravState m s -> TravT s m ()
forall a b. (a -> b) -> a -> b
$ TravState m s
ts { symbolTable = symt' }
        a -> TravT s m a
forall a. a -> TravT s m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r

instance Monad m => MonadCError (TravT s m) where
    -- error handling facilities
    throwTravError :: forall e a. Error e => e -> TravT s m a
throwTravError e
e = (TravState m s -> m (Either CError (a, TravState m s)))
-> TravT s m a
forall s (m :: * -> *) a.
(TravState m s -> m (Either CError (a, TravState m s)))
-> TravT s m a
TravT (\TravState m s
_ -> Either CError (a, TravState m s)
-> m (Either CError (a, TravState m s))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CError -> Either CError (a, TravState m s)
forall a b. a -> Either a b
Left (e -> CError
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 = (TravState m s -> m (Either CError (a, TravState m s)))
-> TravT s m a
forall s (m :: * -> *) a.
(TravState m s -> m (Either CError (a, TravState m s)))
-> TravT s m a
TravT (\TravState m s
s -> TravT s m a
-> TravState m s -> m (Either CError (a, TravState m 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 m (Either CError (a, TravState m s))
-> (Either CError (a, TravState m s)
    -> m (Either CError (a, TravState m s)))
-> m (Either CError (a, TravState m s))
forall a b. m a -> (a -> m b) -> m b
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  -> TravT s m a
-> TravState m s -> m (Either CError (a, TravState m s))
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 -> Either CError (a, TravState m s)
-> m (Either CError (a, TravState m s))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, TravState m s) -> Either CError (a, TravState m s)
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 = (TravState m s -> TravState m s) -> TravT s m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TravState m s -> TravState m s) -> TravT s m ())
-> (TravState m s -> TravState m s) -> TravT s m ()
forall a b. (a -> b) -> a -> b
$ \TravState m s
st -> TravState m s
st { rerrors = (rerrors st) `snoc` toError e }
    getErrors :: TravT s m [CError]
getErrors = (TravState m s -> [CError]) -> TravT s m [CError]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (RList CError -> [CError]
forall a. Reversed [a] -> [a]
RList.reverse (RList CError -> [CError])
-> (TravState m s -> RList CError) -> TravState m s -> [CError]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TravState m s -> RList CError
forall (m :: * -> *) s. TravState m s -> RList CError
rerrors)

instance Monad m => MonadTrav (TravT s m) where
    -- handling declarations and definitions
    handleDecl :: DeclEvent -> TravT s m ()
handleDecl DeclEvent
d = ((DeclEvent -> TravT s m ()) -> DeclEvent -> TravT s m ()
forall a b. (a -> b) -> a -> b
$ DeclEvent
d) ((DeclEvent -> TravT s m ()) -> TravT s m ())
-> TravT s m (DeclEvent -> TravT s m ()) -> TravT s m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (TravState m s -> DeclEvent -> TravT s m ())
-> TravT s m (DeclEvent -> TravT s m ())
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TravState m s -> DeclEvent -> TravT s m ()
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 = Trav s a -> Trav s a
forall a. a -> a
id

-- | The variety of the C language to accept. Note: this is not yet enforced.
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 = RList CError -> [CError]
forall a. Reversed [a] -> [a]
RList.reverse (RList CError -> [CError])
-> (TravState m s -> RList CError) -> TravState m s -> [CError]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TravState m s -> RList CError
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 = RList CError
forall a. Reversed [a]
RList.empty,
        nameGenerator :: [Name]
nameGenerator = [Name]
newNameSupply,
        doHandleExtDecl :: DeclEvent -> TravT s m ()
doHandleExtDecl = TravT s m () -> DeclEvent -> TravT s m ()
forall a b. a -> b -> a
const (() -> TravT s m ()
forall a. a -> TravT s m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()),
        userState :: s
userState = s
userst,
        options :: TravOptions
options = TravOptions { language :: CLanguage
language = CLanguage
C99 }
      }

-- * Trav specific operations
modifyUserState :: (s -> s) -> Trav s ()
modifyUserState :: forall s. (s -> s) -> Trav s ()
modifyUserState s -> s
f = (TravState Identity s -> TravState Identity s)
-> TravT s Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TravState Identity s -> TravState Identity s)
 -> TravT s Identity ())
-> (TravState Identity s -> TravState Identity s)
-> TravT s Identity ()
forall a b. (a -> b) -> a -> b
$ \TravState Identity s
ts -> TravState Identity s
ts { userState = f (userState ts) }

getUserState :: Trav s s
getUserState :: forall s. Trav s s
getUserState = TravState Identity s -> s
forall (m :: * -> *) s. TravState m s -> s
userState (TravState Identity s -> s)
-> TravT s Identity (TravState Identity s) -> TravT s Identity s
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` TravT s Identity (TravState Identity s)
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 = (TravState Identity s -> TravState Identity s)
-> TravT s Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TravState Identity s -> TravState Identity s)
 -> TravT s Identity ())
-> (TravState Identity s -> TravState Identity s)
-> TravT s Identity ()
forall a b. (a -> b) -> a -> b
$ \TravState Identity s
ts -> TravState Identity s
ts { options = f (options ts) }

generateName :: Monad m => TravT s m Name
generateName :: forall (m :: * -> *) s. Monad m => TravT s m Name
generateName =
    TravT s m (TravState m s)
forall s (m :: * -> *). MonadState s m => m s
get TravT s m (TravState m s)
-> (TravState m s -> TravT s m Name) -> TravT s m Name
forall a b. TravT s m a -> (a -> TravT s m b) -> TravT s m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TravState m s
ts ->
    do let (Name
new_name : [Name]
gen') = TravState m s -> [Name]
forall (m :: * -> *) s. TravState m s -> [Name]
nameGenerator TravState m s
ts
       TravState m s -> TravT s m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (TravState m s -> TravT s m ()) -> TravState m s -> TravT s m ()
forall a b. (a -> b) -> a -> b
$ TravState m s
ts { nameGenerator = gen'}
       Name -> TravT s m Name
forall a. a -> TravT s m a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
new_name

-- * helpers
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 = m (Maybe b) -> (a -> m (Maybe b)) -> Maybe a -> m (Maybe b)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe b -> m (Maybe b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
forall a. Maybe a
Nothing) ((b -> Maybe b) -> m b -> m (Maybe b)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM b -> Maybe b
forall a. a -> Maybe a
Just (m b -> m (Maybe b)) -> (a -> m b) -> a -> m (Maybe b)
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 = m () -> (a -> m ()) -> Maybe a -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall a. a -> m a
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) = (c -> (a, c)) -> m c -> m (a, c)
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 = ([[b]] -> [b]) -> m [[b]] -> m [b]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[b]] -> [b]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (m [[b]] -> m [b]) -> ([a] -> m [[b]]) -> [a] -> m [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m [b]) -> [a] -> m [[b]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM a -> m [b]
f