{-# 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 :: String -> t -> DeclarationStatus t1 -> m ()
checkRedef subject :: String
subject new_decl :: t
new_decl redecl_status :: DeclarationStatus t1
redecl_status =
    case DeclarationStatus t1
redecl_status of
        NewDecl -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Redeclared old_def :: t1
old_def   -> RedefError -> m ()
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 old_def :: t1
old_def -> RedefError -> m ()
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 _old_def :: t1
_old_def     ->  () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            -- warn $
            -- redefinition LevelWarn subject ShadowedDef (nodeInfo new_decl) (nodeInfo old_def)
        KeepDef _old_def :: t1
_old_def      -> () -> m ()
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 :: TagFwdDecl -> m ()
handleTagDecl decl :: TagFwdDecl
decl = do
    DeclarationStatus TagEntry
redecl <- (DefTable -> (DeclarationStatus TagEntry, DefTable))
-> m (DeclarationStatus TagEntry)
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 :: TagDef -> m ()
handleTagDef def :: TagDef
def = do
    DeclarationStatus TagEntry
redecl <- (DefTable -> (DeclarationStatus TagEntry, DefTable))
-> m (DeclarationStatus TagEntry)
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 :: Enumerator -> m ()
handleEnumeratorDef enumerator :: 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 (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 (m :: * -> *) a. Monad m => a -> m a
return ()

handleTypeDef :: (MonadTrav m) => TypeDef -> m ()
handleTypeDef :: TypeDef -> m ()
handleTypeDef typeDef :: TypeDef
typeDef@(TypeDef ident :: Ident
ident t1 :: Type
t1 _ _) = do
    DeclarationStatus IdentEntry
redecl <- (DefTable -> (DeclarationStatus IdentEntry, DefTable))
-> m (DeclarationStatus IdentEntry)
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 _ t2 :: Type
t2 _ _)) | Type -> Type -> Bool
sameType Type
t1 Type
t2 -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      _ -> 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 (m :: * -> *) a. Monad m => a -> m a
return ()

handleAsmBlock :: (MonadTrav m) => AsmBlock -> m ()
handleAsmBlock :: AsmBlock -> m ()
handleAsmBlock asm :: 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 :: Ident -> ErrorLevel -> new -> old -> RedefKind -> m ()
redefErr name :: Ident
name lvl :: ErrorLevel
lvl new :: new
new old :: old
old kind :: RedefKind
kind =
  RedefError -> m ()
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 :: IdentEntry -> DeclarationStatus IdentEntry -> m ()
_checkIdentTyRedef (Right decl :: IdentDecl
decl) status :: DeclarationStatus IdentEntry
status = IdentDecl -> DeclarationStatus IdentEntry -> m ()
forall (m :: * -> *).
MonadCError m =>
IdentDecl -> DeclarationStatus IdentEntry -> m ()
checkVarRedef IdentDecl
decl DeclarationStatus IdentEntry
status
_checkIdentTyRedef (Left tydef :: TypeDef
tydef) (KindMismatch old_def :: 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 tydef :: TypeDef
tydef) (Redeclared old_def :: 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 _tydef :: TypeDef
_tydef) _ = () -> m ()
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 :: IdentDecl -> DeclarationStatus IdentEntry -> m ()
checkVarRedef def :: IdentDecl
def redecl :: DeclarationStatus IdentEntry
redecl =
    case DeclarationStatus IdentEntry
redecl of
        -- always an error
        KindMismatch old_def :: 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 old_def :: 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 old_def :: 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
        _ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    where
    redefVarErr :: old -> RedefKind -> m ()
redefVarErr old_def :: old
old_def kind :: 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_def :: new
new_def old_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
            (NoLinkage, _) -> 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
            _              -> 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 _) = Bool
True
    canBeOverwritten (ObjectDef od :: ObjDef
od)  = ObjDef -> Bool
isTentative ObjDef
od
    canBeOverwritten _               = Bool
False
    agreeOnLinkage :: d -> d -> Bool
agreeOnLinkage new_def :: d
new_def old_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 :: Bool -> Decl -> m ()
handleVarDecl is_local :: Bool
is_local decl :: 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 :: ParamDecl -> m ()
handleParamDecl pd :: ParamDecl
pd@(AbstractParamDecl _ _) = DeclEvent -> m ()
forall (m :: * -> *). MonadTrav m => DeclEvent -> m ()
handleDecl (ParamDecl -> DeclEvent
ParamEvent ParamDecl
pd)
handleParamDecl pd :: ParamDecl
pd@(ParamDecl vardecl :: VarDecl
vardecl node :: 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 (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 :: Decl -> (IdentDecl -> Bool) -> m IdentDecl
enterDecl decl :: Decl
decl cond :: IdentDecl -> Bool
cond = do
    let def :: IdentDecl
def = Decl -> IdentDecl
Declaration Decl
decl
    DeclarationStatus IdentEntry
redecl <- (DefTable -> (DeclarationStatus IdentEntry, DefTable))
-> m (DeclarationStatus IdentEntry)
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 (m :: * -> *) a. Monad m => a -> m a
return IdentDecl
def

-- | handle function definitions
handleFunDef :: (MonadTrav m) => Ident -> FunDef -> m ()
handleFunDef :: Ident -> FunDef -> m ()
handleFunDef ident :: Ident
ident fun_def :: 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 (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 _) = Bool
True
isDeclaration _ = Bool
False

checkCompatibleTypes :: Type -> Type -> Either TypeMismatch ()
checkCompatibleTypes :: Type -> Type -> Either TypeMismatch ()
checkCompatibleTypes _ _ = () -> Either TypeMismatch ()
forall a b. b -> Either a b
Right ()

-- | handle object defintions (maybe tentative)
handleObjectDef :: (MonadTrav m) => Bool -> Ident -> ObjDef -> m ()
handleObjectDef :: Bool -> Ident -> ObjDef -> m ()
handleObjectDef local :: Bool
local ident :: Ident
ident obj_def :: 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 (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 object_def :: ObjDef
object_def) = ObjDef -> Bool
isTentative ObjDef
object_def
    isTentativeDef _ = Bool
False
    shouldOverride :: IdentDecl -> IdentDecl -> Bool
shouldOverride def :: IdentDecl
def old :: 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 :: (DefTable -> DefTable) -> m ()
updDefTable f :: DefTable -> DefTable
f = (DefTable -> ((), DefTable)) -> m ()
forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable (\st :: DefTable
st -> ((),DefTable -> DefTable
f DefTable
st))

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

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

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

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

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

leaveBlockScope :: (MonadSymtab m) => m ()
leaveBlockScope :: 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 :: Ident -> m Type
lookupTypeDef ident :: Ident
ident =
    m DefTable
forall (m :: * -> *). MonadSymtab m => m DefTable
getDefTable m DefTable -> (DefTable -> m Type) -> m Type
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \symt :: DefTable
symt ->
    case Ident -> DefTable -> Maybe IdentEntry
lookupIdent Ident
ident DefTable
symt of
        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
$ "unbound typeDef: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
identToString Ident
ident
        Just (Left (TypeDef def_ident :: Ident
def_ident ty :: Type
ty _ _)) -> 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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty
        Just (Right d :: 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 d :: IdentDecl
d = "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]
++ " (for identifier `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
identToString Ident
ident String -> String -> String
forall a. [a] -> [a] -> [a]
++ "')"


-- | lookup an object, function or enumerator
lookupObject :: (MonadCError m, MonadSymtab m) => Ident -> m (Maybe IdentDecl)
lookupObject :: Ident -> m (Maybe IdentDecl)
lookupObject ident :: 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
$ \obj :: IdentEntry
obj ->
        case IdentEntry
obj of
        Right objdef :: 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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IdentDecl -> m IdentDecl
forall (m :: * -> *) a. Monad m => a -> m a
return IdentDecl
objdef
        Left _tydef :: 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 "lookupObject" "an object" "a typeDef")

-- | add link between use and definition (private)
addRef :: (MonadCError m, MonadSymtab m, CNode u, CNode d) => u -> d -> m ()
addRef :: u -> d -> m ()
addRef use :: u
use def :: 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 _ _ useName :: Name
useName, NodeInfo _ _ defName :: Name
defName) ->
      (DefTable -> ((), DefTable)) -> m ()
forall (m :: * -> *) a.
MonadSymtab m =>
(DefTable -> (a, DefTable)) -> m a
withDefTable
      (\dt :: DefTable
dt ->
         ((),
          DefTable
dt { refTable :: IntMap Name
refTable = Key -> Name -> IntMap Name -> IntMap Name
forall a. Key -> a -> IntMap a -> IntMap a
insert (Name -> Key
nameId Name
useName) Name
defName (DefTable -> IntMap Name
refTable DefTable
dt) }
         )
      )
    (_, _) -> () -> m ()
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 ctx :: String
ctx expect :: String
expect found :: String
found = String
ctx String -> String -> String
forall a. [a] -> [a] -> [a]
++ ": Expected " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
expect String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", 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 :: NodeInfo -> Maybe Ident -> m SUERef
createSUERef _node_info :: NodeInfo
_node_info (Just ident :: Ident
ident) = SUERef -> m SUERef
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 node_info :: NodeInfo
node_info Nothing | (Just name :: Name
name) <- NodeInfo -> Maybe Name
nameOfNode NodeInfo
node_info = SUERef -> m SUERef
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 "struct/union/enum definition without unique name"

-- * error handling facilities

handleTravError :: (MonadCError m) => m a -> m (Maybe a)
handleTravError :: m a -> m (Maybe a)
handleTravError a :: 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 (m :: * -> *) a.
MonadCError m =>
m a -> (CError -> m a) -> m a
`catchTravError` (\e :: CError
e -> CError -> m ()
forall (m :: * -> *) e. (MonadCError m, Error e) => e -> m ()
recordError CError
e m () -> m (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe a -> m (Maybe 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 :: NodeInfo -> String -> m a
astError node :: NodeInfo
node msg :: String
msg = InvalidASTError -> 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 :: Either e a -> m a
throwOnLeft (Left err :: e
err) = e -> m a
forall (m :: * -> *) e a. (MonadCError m, Error e) => e -> m a
throwTravError e
err
throwOnLeft (Right v :: a
v)  = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v

warn :: (Error e, MonadCError m) => e -> m ()
warn :: e -> m ()
warn err :: e
err = 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 { 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 (\s :: TravState m s
s -> Either CError (TravState m s, TravState m s)
-> m (Either CError (TravState m s, TravState m s))
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 s :: 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 (\_ -> Either CError ((), TravState m s)
-> m (Either CError ((), TravState m s))
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 :: s -> TravT s m a -> m (Either [CError] (a, TravState m s))
runTravT state :: s
state traversal :: 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 (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 :: TravState m s
-> TravT s m a -> m (Either [CError] (a, TravState m s))
runTravTWithTravState state :: TravState m s
state traversal :: 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 (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 (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 trav_err :: CError
trav_err                                 -> [CError] -> Either [CError] (a, TravState m s)
forall a b. a -> Either a b
Left [CError
trav_err]
        Right (v :: a
v, ts :: 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 :: s -> Trav s a -> Either [CError] (a, TravState Identity s)
runTrav state :: s
state traversal :: 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_ :: Trav () a -> Either [CError] (a, [CError])
runTrav_ t :: Trav () a
t = (((a, [CError]), TravState Identity ()) -> (a, [CError]))
-> Either [CError] ((a, [CError]), TravState Identity ())
-> Either [CError] (a, [CError])
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 (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 :: TravT s m a -> (DeclEvent -> TravT s m ()) -> TravT s m a
withExtDeclHandler action :: TravT s m a
action handler :: 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
$ \st :: 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 :: (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 :: a -> TravT s f a
pure  = a -> TravT s f a
forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: 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 :: a -> TravT s m a
return x :: 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 (\s :: TravState m s
s -> Either CError (a, TravState m s)
-> m (Either CError (a, TravState m s))
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)))
    m :: TravT s m a
m >>= :: TravT s m a -> (a -> TravT s m b) -> TravT s m b
>>= k :: 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 (\s :: 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \y :: Either CError (a, TravState m s)
y -> case Either CError (a, TravState m s)
y of
                              Right (x :: a
x,s1 :: 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 e :: CError
e       -> Either CError (b, TravState m s)
-> m (Either CError (b, TravState m s))
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 :: m a -> TravT s m a
lift m :: 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 (\s :: TravState m s
s -> (\x :: 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 :: IO a -> TravT s m a
liftIO = 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 (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 :: (DefTable -> (a, DefTable)) -> TravT s m a
withDefTable f :: 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 (r :: a
r,symt' :: 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 :: DefTable
symbolTable = DefTable
symt' }
        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 :: e -> TravT s m a
throwTravError e :: 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 (\_ -> Either CError (a, TravState m s)
-> m (Either CError (a, TravState m s))
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 :: TravT s m a -> (CError -> TravT s m a) -> TravT s m a
catchTravError a :: TravT s m a
a handler :: 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 (\s :: 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \x :: Either CError (a, TravState m s)
x -> case Either CError (a, TravState m s)
x of
                                             Left e :: 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 r :: (a, TravState m s)
r -> Either CError (a, TravState m s)
-> m (Either CError (a, TravState m s))
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 :: e -> TravT s m ()
recordError e :: 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
$ \st :: TravState m s
st -> TravState m s
st { rerrors :: RList CError
rerrors = (TravState m s -> RList CError
forall (m :: * -> *) s. TravState m s -> RList CError
rerrors TravState m s
st) RList CError -> CError -> RList CError
forall a. Reversed [a] -> a -> Reversed [a]
`snoc` e -> CError
forall e. Error e => e -> CError
toError e
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 d :: 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 :: 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 {
        TravState m s -> DefTable
symbolTable :: DefTable,
        TravState m s -> RList CError
rerrors :: RList CError,
        TravState m s -> [Name]
nameGenerator :: [Name],
        TravState m s -> DeclEvent -> TravT s m ()
doHandleExtDecl :: (DeclEvent -> TravT s m ()),
        TravState m s -> s
userState :: s,
        TravState m s -> TravOptions
options :: TravOptions
      }

travErrors :: TravState m s -> [CError]
travErrors :: 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 :: s -> TravState m s
initTravState userst :: s
userst =
    TravState :: forall (m :: * -> *) s.
DefTable
-> RList CError
-> [Name]
-> (DeclEvent -> TravT s m ())
-> s
-> TravOptions
-> TravState m s
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 (m :: * -> *) a. Monad m => a -> m a
return ()),
        userState :: s
userState = s
userst,
        options :: TravOptions
options = TravOptions :: CLanguage -> TravOptions
TravOptions { language :: CLanguage
language = CLanguage
C99 }
      }

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

getUserState :: Trav s s
getUserState :: 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) -> Trav s 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 :: (TravOptions -> TravOptions) -> Trav s ()
modifyOptions f :: TravOptions -> TravOptions
f = (TravState Identity s -> TravState Identity s) -> Trav s ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TravState Identity s -> TravState Identity s) -> Trav s ())
-> (TravState Identity s -> TravState Identity s) -> Trav s ()
forall a b. (a -> b) -> a -> b
$ \ts :: TravState Identity s
ts -> TravState Identity s
ts { options :: TravOptions
options = TravOptions -> TravOptions
f (TravState Identity s -> TravOptions
forall (m :: * -> *) s. TravState m s -> TravOptions
options TravState Identity s
ts) }

generateName :: Monad m => TravT s m Name
generateName :: 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ts :: TravState m s
ts ->
    do let (new_name :: Name
new_name : gen' :: [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 :: [Name]
nameGenerator = [Name]
gen'}
       Name -> TravT s m Name
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 :: Maybe a -> (a -> m b) -> m (Maybe b)
mapMaybeM m :: Maybe a
m f :: 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 (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 :: Maybe a -> (a -> m ()) -> m ()
maybeM m :: Maybe a
m f :: a -> m ()
f = m () -> (a -> m ()) -> Maybe a -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
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 :: (b -> m c) -> (a, b) -> m (a, c)
mapSndM f :: b -> m c
f (a :: a
a,b :: 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 :: (a -> m [b]) -> [a] -> m [b]
concatMapM f :: 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)
mapM a -> m [b]
f