{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE CPP #-}

module Ivory.Compile.C.Modules where

import Paths_ivory_backend_c (version)

import Prelude ()
import Prelude.Compat

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 qualified Data.Set as S
import Control.Monad (unless)
import System.FilePath.Posix ((<.>)) -- Always use posix convention in C code
import MonadLib (put,runM)

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

showModule :: CompileUnits -> String
showModule m = unlines $ map unlines $
  [ mk (lbl "Source") (sources m)
  , mk (lbl "Header") (headers m)
  ]
  where
  lbl l = "// module " ++ unitName m ++ " " ++ l ++ ":\n"
  mk _   (_,[])         = []
  mk str (incls,units)  = str : pp (map includeDef (S.toList incls) ++ units)
  pp = map (pretty maxWidth . ppr)

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

compilerVersion :: String
compilerVersion = showVersion version

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

renderHdr :: (Includes, Sources) -> String -> String
renderHdr s unitname = displayS (render maxWidth guardedHeader) ""
  where
  guardedHeader = stack [ topComments
                        , topGuard
                        , topExternC
                        , ppr (defs s)
                        , botExternC
                        , botGuard
                        ]
  topGuard        = text "#ifndef" <+> guardName </> 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

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

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

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.modImports     = imports
                       , I.modExterns     = externs
                       , I.modProcs       = procs
                       , I.modStructs     = structs
                       , I.modAreas       = areas
                       , I.modAreaImports = ais
                       }
  = CompileUnits
  { unitName = nm
  , sources  = sources res
  , headers  = headers 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 . LocalInclude) (S.toList hdrs)
    mapM_ (compileStruct Public) (I.public structs)
    mapM_ (compileStruct Private) (I.private structs)
    mapM_ fromImport imports
    mapM_ fromExtern externs
    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 = putHdrInc (SysInclude (I.importFile p))

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

fromExtern :: I.Extern -> Compile
fromExtern p = putHdrInc (SysInclude (I.externFile 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

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

-- This is generated code, and sometimes, we have large expressions. In
-- practice, this means that once the width is reached, one token is placed per
-- line(!). So we'll make a high limit for width, somewhat ironically making
-- generated C more readable.
maxWidth :: Int
maxWidth = 400