{-# LANGUAGE QuasiQuotes #-}

module Ivory.Compile.C.Modules where

import Paths_ivory_backend_c (version)

import qualified Text.PrettyPrint.Mainland as PP
import Text.PrettyPrint.Mainland

import qualified Ivory.Language.Syntax.AST as I

import Ivory.Compile.C.Gen
import Ivory.Compile.C.Types

import Data.Char (toUpper)
import Data.Version (showVersion)
import Control.Applicative ((<$>))
import qualified Data.Set as S
import Control.Monad
import System.FilePath.Posix ((<.>)) -- Always use posix convention in C code
import MonadLib (put,runM)

--------------------------------------------------------------------------------

showModule :: CompileUnits -> [[String]]
showModule m =
  [ mk "// Sources:\n" (sources m)
  , mk "// Header:\n"  (headers m)
  , mk "// Externs:\n" (S.empty, externs m)
  ]
  where
  mk _   (_,[])         = []
  mk str (incls,units)  = str : pp (map includeDef (S.toList incls) ++ units)
  pp = map (show . ppr)

--------------------------------------------------------------------------------

compilerVersion :: String
compilerVersion = showVersion version

---
topComments :: Doc
topComments  = text "/* This file has been autogenerated by Ivory" </>
               text " * Compiler version " <+> text compilerVersion </>
               text " */"

-- | Output header file for a module.
writeHdr :: Bool                -- ^ Verbosity
         -> FilePath            -- ^ Output file name
         -> (Includes, Sources) -- ^ Source to translate
         -> String              -- ^ Unit name
         -> IO ()
writeHdr True  f s unitname = toFile f $ renderHdr s unitname
writeHdr False f s unitname = toFileQuiet f $ renderHdr s unitname

renderHdr :: (Includes, Sources) -> String -> String
renderHdr s unitname = PP.displayS (PP.render width guardedHeader) ""
  where
  width = 80
  guardedHeader = stack [ topComments
                        , topGuard
                        , topExternC
                        , ppr (defs s)
                        , botExternC
                        , botGuard
                        ]
  topGuard        = text "#ifndef" <+> guardName PP.</> text "#define"
                      <+> guardName
  botGuard        = text "#endif" <+> text "/*" <+> guardName <+> text "*/"
  unitname'       = map (\c -> if c == '-' then '_' else c) unitname
  guardName       = text "__" <> text (toUpper <$> unitname') <> text "_H__"
  topExternC      = stack $ text <$> [ "#ifdef __cplusplus"
                                     , "extern \"C\" {"
                                     , "#endif"]
  botExternC      = stack $ text <$> [ "#ifdef __cplusplus"
                                     , "}"
                                     , "#endif"]
  defs (incls,us) = map includeDef (S.toList incls) ++ us


-- | Output source file for a module.
writeSrc :: Bool                 -- ^ Be verbose
         -> FilePath             -- ^ Output source name
         -> (Includes, Sources)  -- ^ Module to translate
         -> IO ()
writeSrc verbose f s = vToFile f (renderSrc s)
  where
  vToFile = if verbose then toFile else toFileQuiet

renderSrc :: (Includes, Sources) -> String
renderSrc s = PP.displayS (PP.render width srcdoc) ""
  where
  width = 80
  srcdoc = topComments </> out
  defs (incls,us) = map includeDef (S.toList incls) ++ us
  out = stack $ punctuate line $ map ppr $ defs s

-- Utility
toFileQuiet :: FilePath -> String -> IO ()
toFileQuiet f v = writeFile f v

toFile :: FilePath -> String -> IO ()
toFile f v = do
  putStr $ "Writing to file " ++ f ++ "..."
  toFileQuiet f v
  putStrLn " Done."

--------------------------------------------------------------------------------

runOpt :: (I.Proc -> I.Proc) -> I.Module -> I.Module
runOpt opt m =
  m { I.modProcs = procs' }
  where
  procs' = procs { I.public = map' I.public, I.private = map' I.private }
  procs = I.modProcs m
  map' acc = map opt (acc procs)

--------------------------------------------------------------------------------

-- | Compile a module.
compileModule :: I.Module -> CompileUnits
compileModule I.Module { I.modName        = nm
                       , I.modDepends     = deps
                       , I.modHeaders     = hdrs
                       , I.modExterns     = exts
                       , I.modImports     = imports
                       , I.modProcs       = procs
                       , I.modStructs     = structs
                       , I.modAreas       = areas
                       , I.modAreaImports = ais
                       }
  = CompileUnits
  { unitName = nm
  , sources  = sources res
  , headers  = headers res
  , externs  = externs res
  }
  where
  res     = compRes comp
  compRes = (snd . runM . unCompile)

  unitHdr = LocalInclude (nm <.> "h")

  comp = do
    let c = compRes comp0
    unless (null (snd (headers c))) (putSrcInc unitHdr)
    Compile (put c)

  comp0 :: Compile
  comp0 = do
    putHdrInc (LocalInclude "ivory.h")
    -- module names don't have a .h on the end
    mapM_ (putHdrInc . LocalInclude . ((<.> "h"))) (S.toList deps)
    mapM_ (putHdrInc . SysInclude)   (S.toList hdrs)
    mapM_ (compileStruct Public) (I.public structs)
    mapM_ (compileStruct Private) (I.private structs)
    mapM_ compileExtern exts
    mapM_ fromImport imports
    mapM_ (extractAreaProto Public) (I.public areas)
    mapM_ (extractAreaProto Private) (I.private areas)
    mapM_ (compileArea Public) (I.public areas)
    mapM_ (compileArea Private) (I.private areas)
    mapM_ compileAreaImport ais
    mapM_ (extractProto Public) (I.public procs)
    mapM_ (extractProto Private) (I.private procs)
    mapM_ compileUnit (I.public procs ++ I.private procs)

--------------------------------------------------------------------------------

fromImport :: I.Import -> Compile
fromImport p = putSrcInc (SysInclude (I.importFile p))

--------------------------------------------------------------------------------

outputProcSyms :: [I.Module] -> IO ()
outputProcSyms mods = putStrLn $ unwords $ concatMap go mods
  where
  go :: I.Module -> [String]
  go m = map I.procSym (pub ++ priv)
    where I.Visible pub priv = I.modProcs m

--------------------------------------------------------------------------------