content: {-# LANGUAGE CPP #-}
  module ForeignFunctions ( ForeignType(..)
                          , ForeignFunction(..)
                          , ForeignCall(..)
                          , Argument(..)
                          , ReturnStyle(..)
                          , ForeignFuncMap
                          , mkForeignFunction
                          , mkImportDeclarations
                          , mkDPIDeclarations
                          , getForeignFunctions
                          , mkFFDecl
                          , encodeArgs
                          , argExpr
                          , mkCallExpr
                          , mkCallAction
                          , isAbsent
                          , isNarrow
                          , isWide
                          , isPoly
                          , isString
                          , wideReturn
                          , polyReturn
                          , toAVId
                          , fromAVId
                          , isAVId
                          , isMappedAVId
                          , toDisplayId
                          , fromDisplayId
                          , isDisplayId
                          , toFileId
                          , fromFileId
                          , isFileId
                          )
    where
  
  #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 804)
  import Prelude hiding ((<>))
  #endif
  
  import Id(Id, isSignedId, getIdString, qualEq)
  import CType
  import ASyntax
  import ASyntaxUtil
  import CCSyntax
  import Verilog(VDPI(..), VDPIType(..), mkVId, idToVId)
  import ErrorUtil(internalError)
  import Util(tailOrErr, itos)
  import PPrint hiding (char, int)
  import Eval(Hyper(..))
  
  import Data.List(intercalate, isPrefixOf, nub)
  import Data.Maybe(mapMaybe, maybeToList)
  import PreIds
  import ListMap as LM
  
  import qualified Data.Map as M
  
  -- import Debug.Trace
  -- import Util(traces)
  
  -- Represent the width information needed for foreign types
  data ForeignType = Void
                   | Narrow Integer
                   | Wide Integer
                   | Polymorphic
                   | StringPtr
    deriving (Eq,Show);
  
  instance PPrint ForeignType where
    pPrint _ _ Void        = text "void"
    pPrint _ _ (Narrow n)  = (text "Bits#(") <> (text (itos n)) <> (text ")")
    pPrint _ _ (Wide n)    = (text "Bits#(") <> (text (itos n)) <> (text ")")
    pPrint _ _ Polymorphic = text "Bits#(?)"
    pPrint _ _ StringPtr   = text "String"
  
  instance Hyper ForeignType where
    hyper x y = (x==x) `seq` y
  
  isAbsent :: ForeignType -> Bool
  isAbsent Void = True
  isAbsent _    = False
  
  isNarrow :: ForeignType -> Bool
  isNarrow (Narrow n) = True
  isNarrow _          = False
  
  isWide :: ForeignType -> Bool
  isWide (Wide _) = True
  isWide _         = False
  
  isPoly :: ForeignType -> Bool
  isPoly Polymorphic = True
  isPoly _           = False
  
  isString :: ForeignType -> Bool
  isString StringPtr = True
  isString _         = False
  
  -- Associate a name, return type and argument types to describe
  -- a foreign function.
  data ForeignFunction = FF { ff_name :: Id
                            , ff_ret  :: ForeignType
                            , ff_args :: [ForeignType]
                            }
    deriving (Eq,Show);
  
  instance PPrint ForeignFunction where
    pPrint d p (FF nm rt args) =
      let name = text (getIdString nm)
          ret_type = pPrint d p rt
          arg_types = pparen True (sepList (map (pPrint d p) args) comma)
      in ret_type <+> name <> arg_types
  
  instance Hyper ForeignFunction where
    hyper x y = (x==x) `seq` y
  
  mkForeignFunction :: Id -> CType -> ForeignFunction
  mkForeignFunction name ty =
    let (args,ret) = getArrows ty
        ret_type = mkFT ret
        arg_types = map mkFT args
    in FF name ret_type arg_types
    where mkFT ty | isTypeString ty  = StringPtr
                  | isTypePolyBit ty = Polymorphic
                  | (isTypeBit ty) || (isTypeActionValue ty) || (isTypeActionValue_ ty) =
                                       if bitWidth ty > 64
                                       then Wide (bitWidth ty)
                                       else if bitWidth ty == 0
                                            then Void
                                            else Narrow (bitWidth ty)
                  | (isTypeAction ty) || (isTypePrimAction ty) = Void
                  | otherwise        =
                      internalError $ "mkForeignFunction: unexpected type -- " ++ (show ty)
  
  -- lookup for foreign function info
  type ForeignFuncMap = M.Map String ForeignFunction
  
  -- A foreign function can be called as an expression or an action.
  -- They can each also call non-foreign functions, but those are
  -- not encapsulated as ForeignCalls.
  data ForeignCall = FFCall   { fc_func :: ForeignFunction
                              , fc_call :: AExpr
                              }
                   | FFAction { fc_func :: ForeignFunction
                              , fc_action :: AAction
                              }
    deriving (Eq,Show);
  
  fc_args :: ForeignCall -> [AExpr]
  fc_args (FFCall _ expr)  = ae_args expr
  fc_args (FFAction _ act) = tailOrErr "action has no condition" (aact_args act)
  
  getFn :: ForeignFuncMap -> String -> ForeignFunction
  getFn ff_map name =
    case M.lookup name ff_map of
      (Just ff) -> ff
      Nothing   -> internalError $ "unknown foreign function: " ++ name
  
  wideReturn :: ForeignFuncMap -> AExpr -> Bool
  wideReturn ff_map expr =
    let ff = getFn ff_map (ae_funname expr)
    in isUserCExpr expr && isWide (ff_ret ff)
  
  polyReturn :: ForeignFuncMap -> AExpr -> Bool
  polyReturn ff_map expr =
    let ff = getFn ff_map (ae_funname expr)
    in isUserCExpr expr && isPoly (ff_ret ff)
  
  -- -------------------------------------------------
  -- Argument list processing for interfacing to C/C++
  -- This handles both foreign and non-foreign calls.
  
  data Argument = Arg     AExpr          -- expression
                | Field   AExpr String   -- expression.field
                | Ptr     AExpr          -- &expression
                | Copy    Argument       -- pointer to copy of value
                | NoConst Argument       -- cast to non-const
                | SimHdl                 -- pointer to the kernel state
                | Module                 -- pointer to enclosing module
                | ArgStr                 -- descr. of arg types and sizes
                | Alloc   Integer Bool   -- newly allocated memory
                | Null                   -- NULL pointer
    deriving (Eq, Show);
  
  data ReturnStyle = None      -- there is no return value
                   | Direct    -- the value is returned from the call
                   | Pointer   -- the value is passed in and overwritten
                   | Buffered  -- storage is allocated and passed in
    deriving (Eq, Show);
  
  instance PPrint ReturnStyle where
      pPrint d p x = text (show x)
  
  instance PPrint Argument where
      pPrint d p (Arg e)     = parens ( text( "Arg" ) <+> pPrint d p e)
      pPrint d p (Field e s) = parens ( text( "Field" ) <+> pPrint d p e <> parens(text s))
      pPrint d p (Ptr e) = parens ( text( "Ptr" ) <+> pPrint d p e )
      pPrint d p (Copy a) = parens ( text( "Copy" ) <+> pPrint d p a)
      pPrint d p (NoConst a) = parens ( text( "NoConst" ) <+> pPrint d p a)
      pPrint d p (SimHdl) = text "SimHdl"
      pPrint d p (Module) = text "Module"
      pPrint d p (ArgStr) = text "ArgStr"
      pPrint d p (Alloc i b) = parens ( text( "Alloc" ) <+> pPrint d p (i,b))
      pPrint d p Null = text "Null"
  
  -- we need to be able to handle unsized strings
  is_str_lit :: AExpr -> Bool
  is_str_lit (ASStr _ _ _)  = True
  is_str_lit _              = False
  
  is_str_def :: AExpr -> Bool
  is_str_def (ASDef (ATString _) _) = True
  is_str_def _                      = False
  
  is_str_param :: AExpr -> Bool
  is_str_param (ASParam (ATString _) _) = True
  is_str_param _ = False
  
  is_str :: AExpr -> Bool
  is_str e = (is_str_lit e) || (is_str_def e) || (is_str_param e)
  
  is_real :: AExpr -> Bool
  is_real e = aType e == ATReal
  
  str_size :: AExpr -> [Char]
  str_size (ASDef (ATString Nothing) _) = ""
  str_size e                            = show (aSize e)
  
  argExpr :: Argument -> Maybe AExpr
  argExpr (Arg e)     = Just e
  argExpr (Field e _) = Just e
  argExpr (Ptr e)     = Just e
  argExpr (Copy a)    = argExpr a
  argExpr (NoConst a) = argExpr a
  argExpr _           = Nothing
  
  -- we need to be able to distinguish between calls to
  -- internal C++ functions and to imported foreign C functions.
  isUserCExpr :: AExpr -> Bool
  isUserCExpr e@(AFunCall {})   = ae_isC e
  isUserCExpr _                 = False
  
  isUserCAction :: AAction -> Bool
  isUserCAction a@(AFCall {})      = afcall_isC a
  isUserCAction a@(ATaskAction {}) = ataskact_isC a
  isUserCAction _                  = False
  
  
  -- This is used when passing argument type information into our
  -- system task implementations.  User foreign C calls should not use it.
  encodeArgs :: [Argument] -> String
  encodeArgs args =
    let prefix (ASDef _ aid) | isSignedId aid = "-"
        prefix _                              = ""
        encode (Arg e)     | is_str e  = Just ((str_size e) ++ "s")
                           | is_real e = Just "r"
                           | otherwise = Just ((prefix e) ++ (show (aSize e)))
        encode (Field e _) = Just ((prefix e) ++ (show (aSize e)) ++ "p")
        encode (Ptr e)     = if (is_str e)
                             then Just "s"
                             else Just ((prefix e) ++ (show (aSize e)) ++ "p")
        encode (Copy a)    = encode a
        encode (NoConst a) = encode a
        encode _           = Nothing
    in intercalate "," (mapMaybe encode args)
  
  -- A value treated polymorphically must be handled based on the type of
  -- the actual expression.
  polyArg :: AExpr -> Argument
  polyArg e = if aSize e > 64 then Field e "data" else Ptr e
  -- Create an Argument value for an AExpr, without copying
  noCopy :: (AExpr,ForeignType) -> Argument
  noCopy (e,t) | is_str e  = NoConst (Arg e)
               | isWide t  = Field e "data"
               | isPoly t  = polyArg e
               | otherwise = Arg e
  
  -- Create an Argument value for an AExpr, with copying
  withCopy :: (AExpr,ForeignType) -> Argument
  withCopy (e,t) | is_str e  = NoConst (Copy (Arg e))
                 | isWide t  = Copy (Field e "data")
                 | isPoly t  = Copy (polyArg e)
                 | otherwise = Arg e
  
  -- Create an Argument with allocated storage, as an ignored
  -- return value for a foreign call.
  ignoreRet :: ForeignCall -> Argument
  ignoreRet fc =
    case ff_ret (fc_func fc) of
      (Narrow n)  -> Alloc n False
      (Wide n)    -> Alloc n False
      Polymorphic ->
        case fc of
          (FFAction _ (ATaskAction { ataskact_value_type = ty })) ->
             Alloc (aSize ty) False
          otherwise -> Null
      otherwise   -> Null
  
  -- Create an Argument used as a return buffer.
  -- If the expression is already in 32-bit storage, it can
  -- be used directly.  If it is not, then it must be copied
  -- into 32-bit storage and written back after the call.
  forReturn :: (AExpr, ForeignType) -> (ReturnStyle,Argument)
  forReturn (e,rt) | aSize e > 64 = (Pointer,  noCopy (e,rt))
                   | isPoly rt    = (Buffered, Alloc (aSize e) True)
                   | aSize e > 32 = (Buffered, Alloc (aSize e) True)
                   | aSize e > 8  = (Direct,   noCopy (e,rt))
                   | otherwise    = (Buffered, Alloc (aSize e) True)
  
  -- Foreign functions which return wide or polymorphic values have
  -- a pointer to the storage for the return passed as their first argument.
  getReturnArg :: (Maybe (AType,Bool,AId)) -> ForeignType -> (Maybe AExpr)
  getReturnArg (Just (ty,isPort,aid)) ft = if isWide ft || isPoly ft
                                           then if isPort
                                                then Just (ASPort ty aid)
                                                else Just (ASDef ty aid)
                                           else Nothing
  getReturnArg Nothing         _  = Nothing
  
  -- Convert arguments for a ForeignCall into a list of Arguments suitable
  -- for calling the imported function.  This may require copying inputs and
  -- adding an argument for the output memory area.  If there is no
  -- expression for the return argument to a wide or polymorphic return,
  -- space is allocated and passed in.
  mkForeignCallArgs :: (Maybe AExpr) -> ForeignCall -> (ReturnStyle,[Argument])
  mkForeignCallArgs ret fc =
    let rest = [ withCopy a | a <- zip (fc_args fc) (ff_args (fc_func fc)) ]
        rt = ff_ret (fc_func fc)
    in if isAbsent rt
       then (None,rest)
       else case ret of
              (Just e) -> let (ret_style, e') = forReturn (e,rt)
                          in (ret_style, (e':rest))
              Nothing  -> if isWide rt || isPoly rt
                          then (Buffered,((ignoreRet fc):rest))
                          else (Direct,rest)
  
  -- Generate a (do_writeback, fn name, arg list) tuple for an imported call
  -- given an optional return def name and a ForeignCall.
  mkForeignCall :: (Maybe (AType,Bool,AId)) -> ForeignCall
                      -> (ReturnStyle,String,[Argument])
  mkForeignCall ret fc@(FFCall ff expr) =
    let name = case expr of
                 (AFunCall {}) -> ae_funname expr
                 otherwise     -> internalError "mkForeignCall: non-call expr"
        ret_expr = getReturnArg ret (ff_ret ff)
        (ret_style,args) = mkForeignCallArgs ret_expr fc
    in (ret_style, name, args)
  mkForeignCall ret fc@(FFAction ff action) =
    let name = case action of
                 (AFCall {})      -> afcall_fun action
                 (ATaskAction {}) -> ataskact_fun action
                 otherwise        -> internalError "mkForeignCall: non-foreign action"
        ret_expr = getReturnArg ret (ff_ret ff)
        (ret_style,args) = mkForeignCallArgs ret_expr fc
    in (ret_style, name, args)
  
  
  -- Determine whether a system task needs a pointer to the kernel state
  fnNeedsSimHdl :: String -> Bool
  fnNeedsSimHdl name = any (`isPrefixOf` name ) tasks
      where tasks = [ "$time", "$stime"
  
                    , "$stop", "$finish"
  
                    , "$test$plusargs"
  
                    , "$dumpfile" , "$dumpvars"
                    , "$dumpon"   , "$dumpoff"  , "$dumpall"
                    , "$dumplimit", "$dumpflush"
  
                    -- idPrefixOf handles the "b", "o", "h", "AV" variants
                    , "$write"  , "$fwrite"  , "$swrite"
                    , "$display", "$fdisplay", "$sformat"
                    , "$info"   , "$warning" , "$error", "$fatal"
                    ]
  
  -- Determine whether a system task needs a pointer to its module
  fnNeedsLocation :: String -> Bool
  fnNeedsLocation name = any (`isPrefixOf` name ) tasks
      where tasks = ["$write"  , "$fwrite"  , "$swrite"
                    ,"$display", "$fdisplay", "$sformat"
                    ,"$info"   , "$warning" , "$error", "$fatal"
                    ]
  
  -- rewrite $<taskname> as dollar_<taskname>
  mapFnName :: String -> String
  mapFnName s = helper s False
    where helper []       _     = []
          helper ('$':cs) True  = "_dollar_" ++ (helper cs True)
          helper ('$':cs) False = "dollar_" ++ (helper cs True)
          helper (c:cs)   _     = c:(helper cs True)
  
  -- Determine whether a system task needs a pointer to its return value
  mkSystemTaskReturn :: AAction -> (ReturnStyle, Maybe Argument)
  mkSystemTaskReturn act@(ATaskAction {}) =
    if any (\x -> isPrefixOf x (ataskact_fun act)) tasks
    then case (ataskact_temp act) of
           (Just aid) -> (Pointer, (Just (Ptr (ASDef (ataskact_value_type act) aid))))
           Nothing    -> (Direct, Nothing)
    else (Direct, Nothing)
    where tasks = ["$swrite", "$sformat"]
  mkSystemTaskReturn _ = internalError "mkSystemTaskReturn: not a task action"
  
  -- Convert arguments for a ForeignCall into a list of Arguments suitable
  -- for calling a system task.  This may require adding a "this" pointer,
  -- adding an argument descriptor string, and passing some values by pointer.
  mkSystemTaskArgs :: Bool -> Bool -> Maybe Argument -> [AExpr] -> [Argument]
  mkSystemTaskArgs add_sim add_this ret_arg args =
    let rest   = map convAExprToArgument args
        sim    = if add_sim then [SimHdl] else []
        this   = if add_this then [Module] else []
        argstr = if (null args) then [] else [ArgStr]
    in sim ++ this ++ argstr ++ (maybeToList ret_arg) ++ rest
  
  convAExprToArgument :: AExpr -> Argument
  convAExprToArgument e | (is_str e)     = Ptr e
                        | (is_real e)    = Arg e
                        | (aSize e) > 64 = Ptr e
                        | otherwise      = Arg e
  
  
  -- Generate a (do_writeback, fn name, arg list) tuple for a system task
  -- given a suitable AExpr or AAction
  mkSystemTaskCallExpr :: AExpr -> (ReturnStyle,String,[Argument])
  mkSystemTaskCallExpr e@(AFunCall {}) =
    let name = ae_funname e
        add_sim = fnNeedsSimHdl name
        add_this = fnNeedsLocation name
        args = mkSystemTaskArgs add_sim add_this Nothing (ae_args e)
    in (Direct, mapFnName name, args)
  mkSystemTaskCallExpr e =
    internalError $ "mkSystemTaskCallExpr: non-call expr -- " ++ (show e)
  
  
  mkSystemTaskCallAction :: AAction -> (ReturnStyle,String,[Argument])
  mkSystemTaskCallAction act@(AFCall {}) =
    let name = afcall_fun act
        add_sim = fnNeedsSimHdl name
        add_this = fnNeedsLocation name
        args = mkSystemTaskArgs add_sim add_this
                                Nothing
                                (tailOrErr "action has no condition"
                                           (aact_args act))
    in (None, mapFnName name, args)
  mkSystemTaskCallAction act@(ATaskAction {}) =
    let name = ataskact_fun act
        (ret_style,ret_arg) = mkSystemTaskReturn act
        add_sim = fnNeedsSimHdl name
        add_this = fnNeedsLocation name
        args = mkSystemTaskArgs add_sim add_this
                                ret_arg
                                (tailOrErr "action has no condition"
                                           (aact_args act))
    in (ret_style, mapFnName name, args)
  mkSystemTaskCallAction act =
    internalError $ "mkSystemTaskCall: non-systask action -- " ++ (show act)
  
  -- versions which handle foreign call detection and lookup
  
  mkCallExpr :: ForeignFuncMap -> Maybe (Bool,AId) -> AExpr ->
                (ReturnStyle,String,[Argument])
  mkCallExpr ff_map ret expr =
    let ret' = case ret of
                 (Just (isPort,aid)) -> Just (aType expr, isPort, aid)
                 Nothing             -> Nothing
        res = if isUserCExpr expr
              then mkForeignCall ret' (FFCall (getFn ff_map (ae_funname expr)) expr)
              else mkSystemTaskCallExpr expr
    in res
  
  mkCallAction :: ForeignFuncMap -> Maybe (Bool,AId) -> AAction ->
                  (ReturnStyle,String,[Argument])
  mkCallAction ff_map _ action@(AFCall {}) =
    let res = if isUserCAction action
              then mkForeignCall Nothing (FFAction (getFn ff_map (afcall_fun action)) action)
              else mkSystemTaskCallAction action
    in res
  mkCallAction ff_map ret action@(ATaskAction {}) =
    let isPort = maybe False fst ret
        ret' = case (ataskact_temp action) of
                (Just aid) -> Just ((ataskact_value_type action), isPort, aid)
                Nothing    -> Nothing
        drop_type (Just (_,p,i)) = Just (p,i)
        drop_type Nothing        = Nothing
    in if (ret /= (drop_type ret'))
       then internalError "mkCallAction: mismatched return values for ATaskAction"
       else if isUserCAction action
            then mkForeignCall ret' (FFAction (getFn ff_map (ataskact_fun action)) action)
            else mkSystemTaskCallAction action
  mkCallAction _ _ action =
    internalError $ "mkCallAction: passed method call -- " ++ (show action)
  
  -- =================================================
  -- Make a header file with declarations for all foreign functions in
  -- the ForeignFuncMap.
  
  toCtype :: ForeignType -> (CCFragment -> CCFragment)
  toCtype Void = void
  toCtype (Narrow n) | n <= 8    = CCSyntax.char
                     | n <= 32   = unsigned . CCSyntax.int
                     | n <= 64   = unsigned . long . long
                     | otherwise = internalError "Narrow n > 64"
  toCtype (Wide _)    = ptr . unsigned . CCSyntax.int
  toCtype StringPtr   = ptr . CCSyntax.char
  toCtype Polymorphic = ptr . unsigned . CCSyntax.int
  
  mkFFDecl :: ForeignFunction -> CCFragment
  mkFFDecl (FF name rt arg_types) =
    let (ret,ats) = if isWide rt || isPoly rt
                    then (Void,(rt:arg_types))
                    else (rt,arg_types)
    in decl $ function (toCtype ret)
                       (mkVar (getIdString name))
                       [ decl $ (toCtype ty) (mkVar "") | ty <- ats ]
  
  
  mkImportDeclarations :: ForeignFuncMap -> CCFragment
  mkImportDeclarations ff_map =
    let ffs = M.elems ff_map
    in program [externC (map mkFFDecl ffs)]
  
  -- =================================================
  -- Make the SystemVerilog DPI-C declarations for all foreign functions in
  -- the ForeignFuncMap.
  
  mkDPIDeclarations :: [ForeignFunction] -> [VDPI]
  mkDPIDeclarations ffuncs = map mkDPIDecl ffuncs
    where
      mkDPIDecl :: ForeignFunction -> VDPI
      mkDPIDecl (FF name rt arg_types) =
        let
            mkResName = mkVId "res"
            mkArgName n = mkVId ("arg" ++ show (n :: Integer))
  
            mkOut t = (mkResName, False, toVDPIType t)
            mkIn n t = (mkArgName n, True, toVDPIType t)
            mkIns ts = zipWith mkIn [0..] ts
  
            (vdpi_ret, vdpi_args) =
              if isWide rt || isPoly rt
              then (VDT_void, (mkOut rt : mkIns arg_types))
              else (toVDPIType rt, mkIns arg_types)
        in
           VDPI (idToVId name) vdpi_ret vdpi_args
  
      toVDPIType :: ForeignType -> VDPIType
      toVDPIType Void = VDT_void
      toVDPIType (Narrow n) | n <= 8    = VDT_byte
                            | n <= 32   = VDT_int
                            | n <= 64   = VDT_longint
                            | otherwise = internalError "Narrow n > 64"
      toVDPIType (Wide n)    = VDT_wide n
      toVDPIType StringPtr   = VDT_string
      toVDPIType Polymorphic = VDT_poly
  
  getForeignFunctions :: ForeignFuncMap -> ASPackage -> [ForeignFunction]
  getForeignFunctions ffmap aspkg =
    let
        expr_ff_uses = findAExprs exprForeignCalls aspkg
        expr_ff_names =
          [ i | (AFunCall { ae_funname = i, ae_isC = True }) <- expr_ff_uses ]
  
        act_ff_uses = concatMap snd (aspkg_foreign_calls aspkg)
        act_ff_names = map afc_fun act_ff_uses
  
        ff_names = nub (expr_ff_names ++ act_ff_names)
  
        findFF name = M.lookup name ffmap
    in
        mapMaybe findFF ff_names
  
  -- #############################################################################
  -- # Map to and from real Verilog foreign funcs and the BSV AV version.
  -- #############################################################################
  
  toAVId :: Id -> Id
  toAVId id = case (LM.lookupBy qualEq toAVIdMap id) of
              Just x -> x
              _      -> internalError $ "ForeignFunctions: (toAVId) No AVId exists for " ++ (ppReadable id)
  
  
  fromAVId :: Id -> Id
  fromAVId id = case (LM.lookupBy qualEq fromAVIdMap id) of
                Just x -> x
                _      -> internalError $ "ForeignFunctions: (fromAVId) " ++ (ppReadable id) ++ "is not an AVId"
  
  isAVId :: Id -> Bool
  isAVId id = case (LM.lookupBy qualEq fromAVIdMap id) of
              Nothing -> False
              _       -> True
  
  isMappedAVId :: Id -> Bool
  isMappedAVId id = case (LM.lookupBy qualEq toAVIdMap id) of
              Nothing -> False
              _       -> True
  
  toAVIdMap :: [(Id, Id)]
  toAVIdMap = [ (idSWrite,  idSWriteAV)
              , (idSWriteb, idSWritebAV)
              , (idSWriteo, idSWriteoAV)
              , (idSWriteh, idSWritehAV)
              , (idSFormat, idSFormatAV)
              ]
  
  fromAVIdMap :: [(Id, Id)]
  fromAVIdMap =
      let flip (a,b) = (b,a)
      in map flip toAVIdMap
  
  -- #############################################################################
  -- # Map to and from $display (and friends) and $write (and friends)
  -- #############################################################################
  
  toDisplayId :: Id -> Id
  toDisplayId id = case (LM.lookupBy qualEq toDisplayIdMap id) of
              Just x -> x
              _      -> internalError $ "ForeignFunctions: (toDisplayId) No DisplayId exists for " ++ (ppReadable id)
  
  
  fromDisplayId :: Id -> Id
  fromDisplayId id = case (LM.lookupBy qualEq fromDisplayIdMap id) of
                Just x -> x
                _      -> internalError $ "ForeignFunctions: (fromDisplayId) " ++ (ppReadable id) ++ "is not an DisplayId"
  
  isDisplayId :: Id -> Bool
  isDisplayId id = case (LM.lookupBy qualEq fromDisplayIdMap id) of
              Nothing -> False
              _       -> True
  
  toDisplayIdMap :: [(Id, Id)]
  toDisplayIdMap = [ (idWrite,   idDisplay)
                 , (idWriteb,  idDisplayb)
                 , (idWriteo,  idDisplayo)
                 , (idWriteh,  idDisplayh)
                 , (idFWrite,  idFDisplay)
                 , (idFWriteb, idFDisplayb)
                 , (idFWriteo, idFDisplayo)
                 , (idFWriteh, idFDisplayh)
                 ]
  
  fromDisplayIdMap :: [(Id, Id)]
  fromDisplayIdMap =
      let flip (a,b) = (b,a)
      in map flip toDisplayIdMap
  
  -- #############################################################################
  -- # Map to and from $display and $fdisplay etc.
  -- #############################################################################
  
  toFileId :: Id -> Id
  toFileId id = case (LM.lookupBy qualEq toFileIdMap id) of
              Just x -> x
              _      -> internalError $ "ForeignFunctions: (toFileId) No FileId exists for " ++ (ppReadable id)
  
  
  fromFileId :: Id -> Id
  fromFileId id = case (LM.lookupBy qualEq fromFileIdMap id) of
                Just x -> x
                _      -> internalError $ "ForeignFunctions: (fromFileId) " ++ (ppReadable id) ++ "is not an FileId"
  
  isFileId :: Id -> Bool
  isFileId id = case (LM.lookupBy qualEq fromFileIdMap id) of
              Nothing -> False
              _       -> True
  
  toFileIdMap :: [(Id, Id)]
  toFileIdMap = [  (idWrite,   idFWrite)
                 , (idWriteb,  idFWriteb)
                 , (idWriteo,  idFWriteo)
                 , (idWriteh,  idFWriteh)
                 , (idDisplay,  idFDisplay)
                 , (idDisplayb, idFDisplayb)
                 , (idDisplayo, idFDisplayo)
                 , (idDisplayh, idFDisplayh)
                 ]
  
  fromFileIdMap :: [(Id, Id)]
  fromFileIdMap =
      let flip (a,b) = (b,a)
      in map flip toFileIdMap
  