content: module GenForeign (genForeign) where
  
  import Error(internalError, ErrMsg(..), ErrorHandle, bsError)
  import Util(headOrErr, findSame)
  import Flags
  import Pragma
  import Id
  import CSyntax
  import PPrint
  import ABin (ABin(..), ABinForeignFuncInfo(..))
  import GenABin(genABinFile)
  import ForeignFunctions(ForeignFunction(..), mkForeignFunction)
  import Version(bscVersionStr)
  import FileNameUtil(mkAName, getRelativeFilePath)
  import TopUtils(putStrLnF)
  
  import Control.Monad(unless)
  
  -- For dumping purposes, this returns a list of
  -- the foreign src IDs, and their corresponding ForeignFunctions
  genForeign :: ErrorHandle -> Flags -> String -> CPackage ->
                IO [(Id, ForeignFunction)]
  genForeign errh flags prefix (CPackage pkg_id _ _ _ defs _) =
      let
          isPPforeignImport (PPforeignImport {}) = True
          isPPforeignImport _ = False
  
          foreignIds = [ i | (CPragma (Pproperties i pps)) <- defs,
                             any isPPforeignImport pps ]
          foreignDefs = [ d | d@(CValueSign (CDefT i _ _ _)) <- defs,
                              i `elem` foreignIds ]
          foreignInfos = map extractForeignFuncInfo foreignDefs
  
          genABin info@(src_id, foreign_func) =
              let ffinfo = ABinForeignFuncInfo src_id foreign_func
                  abin = ABinForeignFunc ffinfo (bscVersionStr True)
                  -- generate the filename
                  afilename_base = getIdString (ff_name foreign_func)
                  afilename = mkAName (bdir flags) prefix afilename_base
                  afilename_rel = getRelativeFilePath afilename
                  -- user message
                  abinPrintPrefix = "Foreign import file created: "
              in  do
                     -- write the file with full path
                     genABinFile errh afilename abin
                     -- report the file to the user with relative path
                     -- (typically just the filename, for current directory)
                     unless (quiet flags) $ putStrLnF $ abinPrintPrefix ++ afilename_rel
                     -- return the info, for dumping
                     return info
  
          -- check for duplicate imports and report an error
          link_ids = map (ff_name . snd) foreignInfos
          duplicates = findSame link_ids
          mkDupErr dups =
              let link_id = headOrErr "GenForeign mkDupErr link" dups
                  has_this_link (i,ff) = (ff_name ff == link_id)
                  src_ids = map fst (filter has_this_link foreignInfos)
                  src_ips = map (\i -> (getIdString i, getPosition i)) src_ids
                  link_name = getIdString link_id
                  pos = getPosition link_id
              in  (pos, EForeignFuncDuplicates link_name src_ips)
      in
          if (not (null duplicates))
          then bsError errh (map mkDupErr duplicates)
          else mapM genABin foreignInfos
  
  
  -- After typechecking, the import should contain a CForeignFuncCT expression
  -- which contains the primitive type.  This function extracts that.
  extractForeignFuncInfo :: CDefn -> (Id, ForeignFunction)
  extractForeignFuncInfo defn =
      let
          extractFromCDefn (CValueSign (CDefT _ _ _ clauses)) =
              concatMap extractFromCClause clauses
          extractFromCDefn _ = internalError "GenForeign: extractFromCDefn"
  
          extractFromCClause (CClause _ _ expr) = extractFromCExpr expr
  
          extractFromCExpr expr@(CForeignFuncCT {}) = [expr]
          extractFromCExpr (CLam _ expr) = extractFromCExpr expr
          extractFromCExpr (CLamT _ _ expr) = extractFromCExpr expr
          extractFromCExpr (Cletseq defs expr) =
              concatMap extractFromCDefl defs ++ extractFromCExpr expr
          extractFromCExpr (Cletrec defs expr) =
              concatMap extractFromCDefl defs ++ extractFromCExpr expr
          extractFromCExpr (CApply expr1 exprs) =
              extractFromCExpr expr1 ++ concatMap extractFromCExpr exprs
          extractFromCExpr _ = []
  
          extractFromCDefl (CLValueSign (CDefT _ _ _ clauses) _) =
              concatMap extractFromCClause clauses
          extractFromCDefl _ = internalError "GenForeign: extractFromCDefl"
  
      in
          case (extractFromCDefn defn) of
              [CForeignFuncCT link_id ctype] ->
                  case (getName defn) of
                    Right i -> (i, mkForeignFunction link_id ctype)
                    Left _ -> internalError "GenForeign: getName"
              res -> internalError ("GenForeign: foreigns = " ++
                                    ppReadable res)
  