content: -- routines dealing with reading and preprocessing source code files.
  module Ho.ReadSource(
     preprocess,
     preprocessHs,
     languageFlags,
     fetchCompilerFlags,
     parseHsSource
  ) where
  
  import Control.Monad
  import Data.Char
  import Data.Maybe
  import System.FilePath as FP
  import System.Process
  import System.Directory
  import qualified Data.ByteString as BS
  import qualified Data.ByteString.Lazy as LBS
  import qualified Data.ByteString.Lazy.UTF8 as LBSU
  import qualified Data.Map as Map
  import qualified Data.Set as Set
  
  import FrontEnd.HsParser
  import FrontEnd.HsSyn
  import FrontEnd.ParseMonad
  import FrontEnd.SrcLoc
  import FrontEnd.Syn.Options
  import FrontEnd.Unlit
  import FrontEnd.Warning
  import Options
  import PackedString
  import RawFiles(prelude_m4)
  import Support.TempDir
  import Util.FilterInput
  import Util.Gen
  import Version.Config(revision,version)
  import qualified FlagDump as FD
  import qualified FlagOpts as FO
  
  preprocessHs :: Opt -> FilePath -> LBS.ByteString -> IO LBS.ByteString
  preprocessHs options fn lbs = preprocess (fst $ collectFileOpts options fn (LBSU.toString $ LBS.take 2048 lbs)) fn lbs
  
  preprocess :: Opt -> FilePath -> LBS.ByteString -> IO LBS.ByteString
  preprocess opt fn lbs = do
      let fopts s = s `Set.member` optFOptsSet opt
          incFlags = [ "-I" ++ d | d <- optIncdirs opt ++ optIncs opt]
          defFlags = ("-D__JHC__=" ++ revision):("-D__JHC_VERSION__=" ++ version):[ "-D" ++ d | d <- optDefs opt]
      case () of
          _ | fopts FO.Cpp -> readSystem "cpphs" $ incFlags ++ defFlags ++ [fn]
            | fopts FO.M4  -> do
                  m4p <- m4Prelude
                  maygm4 <- findExecutable "gm4"
                  readSystem (fromMaybe "m4" maygm4) $ ["-s", "-P"] ++ incFlags ++ defFlags ++ [m4p,fn]
            | otherwise -> return lbs
  
  m4Prelude :: IO FilePath
  m4Prelude = fileInTempDir "prelude.m4" $ \fp -> do putStrLn $ "Writing stuff:" ++ fp ; BS.writeFile fp prelude_m4 ; return ()
  
  collectFileOpts options fn s = (lproc opt,isJust fopts)  where
      copts os = [ as | (x,as) <- popts, x `elem` os]
      Just opt = fopts `mplus` Just options
      fopts = fileOptions options opts
      popts = parseOptions $ if FP.takeExtension fn == ".lhs" then unlit fn s else s
      opts = concatMap words (copts ["OPTIONS","JHC_OPTIONS","OPTIONS_JHC"])
      (pfs,nfs,_) = languageFlags $ concatMap (words . (map (\c -> if c == ',' then ' ' else c)))
          (copts ["LANGUAGE","JHC_LANGUAGE"] ++ optExtensions options ++ [ o | '-':'X':o <- opts])
      lproc opt = opt { optFOptsSet = Set.union pfs (optFOptsSet opt) Set.\\ nfs }
  
  -- translates a list of language extensions as pased to a LANGUAGE pragma or
  -- the -X option to the equivalent '-f' flags. The first return value are the
  -- positive flags, the negative flags, and the third is the unrecognized extensions.
  languageFlags :: [String] -> (Set.Set FO.Flag,Set.Set FO.Flag,[String])
  languageFlags ls = f ls Set.empty Set.empty [] where
      f [] pfs nfs us = (pfs,nfs,us)
      f (l:ls) pfs nfs us | Just lo <- Map.lookup ll langmap =  f ls (Set.union lo pfs) nfs us
                          | 'n':'o':ll <- ll, Just lo <- Map.lookup ll langmap = f ls pfs (nfs `Set.union` lo) us
                          | otherwise = f ls pfs nfs (l:us)
          where ll = map toLower l
  
  langmap = Map.fromList [
      "m4" ==> FO.M4,
      "cpp" ==> FO.Cpp,
      "foreignfunctioninterface" ==> FO.Ffi,
      "implicitprelude" ==> FO.Prelude,
      "unboxedtuples" ==> FO.UnboxedTuples,
      "unboxedvalues" ==> FO.UnboxedValues,
      "monomorphismrestriction" ==> FO.MonomorphismRestriction,
      "explicitforall" ==> FO.Forall,
      "existentialquantification" =+> [FO.Forall,FO.Exists],
      "scopedtypevariables" ==> FO.Forall,
      "rankntypes" ==> FO.Forall,
      "rank2types" ==> FO.Forall,
      "bangpatterns" ==> FO.BangPatterns,
      "polymorphiccomponents" ==> FO.Forall,
      "TypeFamilies" ==> FO.TypeFamilies,
      "magichash" ==> FO.UnboxedValues
      ] where x ==> y = (x,Set.singleton y)
              x =+> y = (x,Set.fromList y)
  
  parseHsSource :: Opt -> FilePath -> LBS.ByteString -> IO (HsModule,LBS.ByteString)
  parseHsSource options fp@(FP.splitExtension -> (base,".hsc")) _ = do
      let out = FP.takeFileName base ++ ".hs"
      tdir <- getTempDir
      (cc,cflags) <- fetchCompilerFlags
      let incFlags = [ "-I" ++ d | d <- optIncdirs options ++ optIncs options]
          defFlags = [ "-D" ++ d | d <- optDefs options ]
      let hscargs =   [fp, "-o", tdir </> out] ++ defFlags ++ incFlags ++ concatMap (\x -> ["-C",x]) cflags ++ ["-c", cc]
      when verbose $
          print ("hsc2hs",hscargs)
      rawSystem "hsc2hs" hscargs
      print tdir
      print out
      lbs <- LBS.readFile $ tdir </> out
      parseHsSource options out lbs
  parseHsSource options fn lbs = do
      lbs' <- preprocessHs options fn lbs
      let s = LBSU.toString lbs'
      let s' = if FP.takeExtension fn == ".lhs" then unlit fn s'' else s''
          s'' = case s of
              '#':' ':_   -> '\n':s                --  line pragma
              '#':'l':'i':'n':'e':' ':_  -> '\n':s --  line pragma
              '#':'!':_ -> dropWhile (/= '\n') s   --  hashbang
              _ -> s
      wdump FD.Preprocessed $ do
          putStrLn s'
      fn <- shortenPath fn
      let (fileOpts',ogood) = collectFileOpts options fn s
      unless ogood $
          warn (bogusASrcLoc { srcLocFileName = packString fn })
              UnknownOption "Invalid options in OPTIONS pragma"
      case runParserWithMode (parseModeOptions fileOpts') { parseFilename = fn } parse  s'  of
                        (ws,ParseOk e) -> processErrors ws >> return (e { hsModuleOpt = fileOpts' },LBSU.fromString s')
                        (_,ParseFailed sl err) -> putErrDie $ show sl ++ ": " ++ err
  
  fetchCompilerFlags :: IO (FilePath, [String]) -- ^ file path to compiler, compiler arguments
  fetchCompilerFlags = return (cc,args) where
      lup k = maybe "" id $ Map.lookup k (optInis options)
      boehmOpts | fopts FO.Boehm = ["-D_JHC_GC=_JHC_GC_BOEHM", "-lgc"]
                | fopts FO.Jgc   = ["-D_JHC_GC=_JHC_GC_JGC"]
                | otherwise = []
      profileOpts | fopts FO.Profile || lup "profile" == "true" = ["-D_JHC_PROFILE=1"]
                  | otherwise = []
      threadOpts | fopts FO.Pthread      = ["-D_JHC_CONC=_JHC_CONC_PTHREAD", "-pthread"]
                 | fopts FO.Customthread = ["-D_JHC_CONC=_JHC_CONC_CUSTOM"]
                 | otherwise             = ["-D_JHC_CONC=_JHC_CONC_NONE"]
      debug = if fopts FO.Debug then words (lup "cflags_debug") else words (lup "cflags_nodebug")
      cc = lup "cc"
      args = words (lup "cflags") ++ debug ++ optCCargs options  ++ boehmOpts ++ profileOpts ++ threadOpts
  