content: {- |
  Module      :  ./Driver/WriteLibDefn.hs
  Description :  Writing out a DOL library
  Copyright   :  (c) Klaus Luettich, C.Maeder, Uni Bremen 2002-2006
  License     :  GPLv2 or higher, see LICENSE.txt
  
  Maintainer  :  Christian.Maeder@dfki.de
  Stability   :  provisional
  Portability :  non-portable(DevGraph)
  
  Writing out DOL env files as much as is needed for
  the static analysis
  -}
  
  module Driver.WriteLibDefn
    ( getFilePrefix
    , getFilePrefixGeneric
    , writeLibDefn
    , writeLibDefnLatex
    , toShATermString
    , writeShATermFile
    , writeFileInfo
    ) where
  
  import Common.Utils
  import Common.Doc
  import Common.LibName
  import Common.PrintLaTeX
  import Common.GlobalAnnotations (GlobalAnnos)
  import Common.ConvertGlobalAnnos ()
  import Common.IO
  
  import Control.Exception as Exception
  
  import ATerm.AbstractSyntax
  import qualified ATerm.ReadWrite as AT
  
  import ATC.AS_Library ()
  import ATC.DevGraph ()
  import ATC.Grothendieck
  
  import Logic.Grothendieck
  
  import Syntax.AS_Library (LIB_DEFN ())
  import Syntax.Print_AS_Library ()
  import Syntax.Print_AS_Structured
  import Syntax.ToXml
  
  import Text.XML.Light (ppTopElement)
  
  import Driver.Options
  import Driver.Version
  
  import System.FilePath
  
  -- | Compute the prefix for files to be written out
  getFilePrefix :: HetcatsOpts -> FilePath -> (FilePath, FilePath)
  getFilePrefix opts = getFilePrefixGeneric (envSuffix : downloadExtensions)
                       $ outdir opts
  
  -- | Version of getFilePrefix with explicit parameters
  getFilePrefixGeneric :: [String] -- ^ list of suffixes
                       -> FilePath -- ^ the outdir
                       -> FilePath -> (FilePath, FilePath)
  getFilePrefixGeneric suffs odir' file =
      let (base, path, _) = fileparse suffs file
          odir = if null odir' then path else odir'
      in (odir, odir </> base)
  
  {- |
    Write the given LIB_DEFN in every format that HetcatsOpts includes.
    Filenames are determined by the output formats.
  -}
  writeLibDefn :: LogicGraph -> GlobalAnnos -> FilePath -> HetcatsOpts
    -> LIB_DEFN -> IO ()
  writeLibDefn lg ga fullFileName opts ld = do
      let file = tryToStripPrefix "file://" fullFileName
          (odir, filePrefix) = getFilePrefix opts file
          printXml fn = writeFile fn $ ppTopElement (xmlLibDefn lg ga ld)
          printAscii b fn = writeEncFile (ioEncoding opts) fn
            $ renderExtText (StripComment b) ga (prettyLG lg ld) ++ "\n"
          printHtml fn = writeEncFile (ioEncoding opts) fn
            $ renderHtml ga $ prettyLG lg ld
          write_type :: OutType -> IO ()
          write_type ty = case ty of
              PrettyOut pty -> do
                let fn = filePrefix ++ "." ++ show ty
                putIfVerbose opts 2 $ "Writing file: " ++ fn
                case pty of
                  PrettyXml -> printXml fn
                  PrettyAscii b -> printAscii b fn
                  PrettyHtml -> printHtml fn
                  PrettyLatex b -> writeLibDefnLatex lg b ga fn ld
              _ -> return () -- implemented elsewhere
      putIfVerbose opts 3 ("Current OutDir: " ++ odir)
      mapM_ write_type $ outtypes opts
  
  writeLibDefnLatex :: LogicGraph -> Bool -> GlobalAnnos -> FilePath -> LIB_DEFN
    -> IO ()
  writeLibDefnLatex lg lbl ga oup = writeFile oup . renderLatex Nothing
    . toLatexAux (StripComment False) (MkLabel lbl) ga . prettyLG lg
  
  toShATermString :: ShATermLG a => a -> IO String
  toShATermString = fmap AT.writeSharedATerm . versionedATermTable
  
  writeShATermFile :: ShATermLG a => FilePath -> a -> IO ()
  writeShATermFile fp atcon = toShATermString atcon >>= writeFile fp
  
  versionedATermTable :: ShATermLG a => a -> IO ATermTable
  versionedATermTable atcon = do
      (att1, versionno) <- toShATermLG emptyATermTable hetsVersionNumeric
      (att2, aterm) <- toShATermLG att1 atcon
      return $ fst $ addATerm (ShAAppl "hets" [versionno, aterm] []) att2
  
  writeShATermFileSDoc :: ShATermLG a => FilePath -> a -> IO ()
  writeShATermFileSDoc fp atcon =
     versionedATermTable atcon >>= AT.writeSharedATermFile fp
  
  writeFileInfo :: ShATermLG a => HetcatsOpts -> LibName
                -> FilePath -> LIB_DEFN -> a -> IO ()
  writeFileInfo opts ln fullFileName ld gctx =
    let file = tryToStripPrefix "file://" fullFileName
        envFile = snd (getFilePrefix opts file) ++ envSuffix in
    case analysis opts of
    Basic -> do
        putIfVerbose opts 2 ("Writing file: " ++ envFile)
        Exception.catch (writeShATermFileSDoc envFile (ln, (ld, gctx)))
             $ \ err -> do
                putIfVerbose opts 2 (envFile ++ " not written")
                putIfVerbose opts 3 ("see following error description:\n"
                                     ++ shows (err :: SomeException) "\n")
    _ -> putIfVerbose opts 2 ("Not writing " ++ envFile)
  