--  C->Haskell Compiler: custom header generator
--
--  Author : Manuel M T Chakravarty
--  Created: 5 February 2003
--
--  Version $Revision: 1.1 $
--
--  Copyright (c) 2004 Manuel M T Chakravarty
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--- DESCRIPTION ---------------------------------------------------------------
--
--  This module implements the generation of a custom header from a binding
--  module. 
--
--- DOCU ----------------------------------------------------------------------
--
--  language: Haskell 98
--
--  Computing CPP Conditionals
--  ~~~~~~~~~~~~~~~~~~~~~~~~~~
--  We obtain information about which branches of CPP conditions are taken
--  during pre-processing of the custom header file by introducing new
--  struct declarations.  Specifically, after each #if[[n]def] or #elif,
--  we place a declaration of the form
--
--    struct C2HS_COND_SENTRY<unique number>;
--
--  We can, then, determine which branch of a conditional has been taken by
--  checking whether the struct corresponding to that conditional has been
--  declared.
--
--- TODO ----------------------------------------------------------------------
--
--  * Ideally, `ghFrag[s]' should be tail recursive

module GenHeader (
  genHeader
) where 

-- standard libraries
import Control.Monad     (when)

-- Compiler Toolkit
import Position  (Position, Pos(..), nopos)
import DLists    (DList, openDL, closeDL, zeroDL, unitDL, joinDL, snocDL)
import Errors    (interr)
import Idents    (onlyPosIdent)
import UNames    (NameSupply, Name, names)

-- C->Haskell
import C2HSState (CST, getNameSupply, runCST, transCST, raiseError, catchExc,
                  throwExc, errorsPresent, showErrors, fatal)

-- friends
import CHS       (CHSModule(..), CHSFrag(..))


-- The header generation monad
--
type GH a = CST [Name] a

-- |Generate a custom C header from a CHS binding module.
--
--  * All CPP directives and inline-C fragments are moved into the custom header
--
--  * The CPP and inline-C fragments are removed from the .chs tree and
--   conditionals are replaced by structured conditionals
--
genHeader :: CHSModule -> CST s ([String], CHSModule, String)
genHeader mod = 
  do
    supply <- getNameSupply
    (header, mod) <- runCST (ghModule mod) (names supply)
                     `ifGHExc` return ([], CHSModule [])

    -- check for errors and finalise
    --
    errs <- errorsPresent
    if errs
      then do
        errmsgs <- showErrors
        fatal ("Errors during generation of C header:\n\n"   -- fatal error
               ++ errmsgs)
      else do
        warnmsgs <- showErrors
        return (header, mod, warnmsgs)

-- Obtain a new base name that may be used, in C, to encode the result of a
-- preprocessor conditionl.
--
newName :: CST [Name] String
newName = transCST $
  \supply -> (tail supply, "C2HS_COND_SENTRY_" ++ show (head supply))

-- Various forms of processed fragments
--
data FragElem = Frag  CHSFrag
              | Elif  String Position
              | Else  Position
              | Endif Position
              | EOF

instance Pos FragElem where
  posOf (Frag frag    ) = posOf frag
  posOf (Elif _    pos) = pos
  posOf (Else      pos) = pos
  posOf (Endif     pos) = pos
  posOf EOF             = nopos

-- check for end of file
--
isEOF :: FragElem -> Bool
isEOF EOF = True
isEOF _   = False

-- Generate the C header for an entire .chs module.
--
--  * This works more or less like a recursive decent parser for a statement
--   sequence that may contain conditionals, where `ghFrag' implements most of
--   the state transition system of the associated automaton
--
ghModule :: CHSModule -> GH ([String], CHSModule)
ghModule (CHSModule frags) =
  do
    (header, frags, last, rest) <- ghFrags frags
    when (not . isEOF $ last) $
      notOpenCondErr (posOf last)
    return (closeDL header, CHSModule frags)

-- Collect header and fragments up to eof or a CPP directive that is part of a
-- conditional
--
--  * We collect the header (ie, CPP directives and inline-C) using a
--   difference list to avoid worst case O(n^2) complexity due to
--   concatenation of lines that go into the header.
--
ghFrags :: [CHSFrag] -> GH (DList String, [CHSFrag], FragElem, [CHSFrag])
ghFrags []    = return (zeroDL, [], EOF, [])
ghFrags frags = 
  do
    (header, frag, rest) <- ghFrag frags
    case frag of
      Frag aFrag -> do
                      (header2, frags', frag', rest) <- ghFrags rest
                      -- FIXME: Not tail rec
                      return (header `joinDL` header2, aFrag:frags', 
                              frag', rest)
      _          -> return (header, [], frag, rest)

-- Process a single fragment *structure*; i.e., if the first fragment
-- introduces a conditional, process the whole conditional; otherwise, process
-- the first fragment
--
ghFrag :: [CHSFrag] -> GH (DList String, -- partial header file
                           FragElem,     -- processed fragment
                           [CHSFrag])    -- not yet processed fragments
ghFrag []                              =
  return (zeroDL, EOF, [])
ghFrag (frag@(CHSVerb  _ _  ) : frags) = 
  return (zeroDL, Frag frag, frags)
ghFrag (frag@(CHSHook  _    ) : frags) =
  return (zeroDL, Frag frag, frags)
ghFrag (frag@(CHSLine  _    ) : frags) =
  return (zeroDL, Frag frag, frags)
ghFrag (frag@(CHSLang  _ _  ) : frags) =
  return (zeroDL, Frag frag, frags)
ghFrag (     (CHSC    s  _  ) : frags) =
  do
    (header, frag, frags' ) <- ghFrag frags     -- scan for next CHS fragment
    return (unitDL s `joinDL` header, frag, frags')
    -- FIXME: this is not tail recursive...
ghFrag (     (CHSCond _  _  ) : frags) =
  interr "GenHeader.ghFrags: There can't be a structured conditional yet!"
ghFrag (frag@(CHSCPP  s  pos) : frags) =
  let
    (directive, _) =   break (`elem` " \t")
                     . dropWhile (`elem` " \t") 
                     $ s
  in
  case directive of
    "if"     -> openIf s pos frags
    "ifdef"  -> openIf s pos frags
    "ifndef" -> openIf s pos frags
    "else"   -> return (zeroDL              , Else   pos               , frags)
    "elif"   -> return (zeroDL              , Elif s pos               , frags)
    "endif"  -> return (zeroDL              , Endif  pos               , frags)
    _        -> return (openDL ['#':s, "\n"], Frag   (CHSVerb "" nopos), frags)
  where
    -- enter a new conditional (may be an #if[[n]def] or #elif)
    --
    --  * Arguments are the lexeme of the directive `s', the position of that
    --   directive `pos', and the fragments following the directive `frags'
    --
    openIf s pos frags = 
      do
        (headerTh, fragsTh, last, rest) <- ghFrags frags
        case last of
          Else    pos -> do
                           (headerEl, fragsEl, last, rest) <- ghFrags rest
                           case last of
                             Else    pos -> notOpenCondErr pos
                             Elif  _ pos -> notOpenCondErr pos
                             Endif   pos -> closeIf 
                                              ((headerTh 
                                                `snocDL` "#else\n")
                                               `joinDL` 
                                               (headerEl
                                                `snocDL` "#endif\n"))
                                              (s, fragsTh)
                                              []
                                              (Just fragsEl)
                                              rest
                             EOF         -> notClosedCondErr pos
          Elif s' pos -> do
                           (headerEl, condFrag, rest) <- openIf s' pos rest
                           case condFrag of
                             Frag (CHSCond alts dft) -> 
                               closeIf (headerTh `joinDL` headerEl)
                                       (s, fragsTh)
                                       alts
                                       dft
                                       rest
                             _                       -> 
                               interr "GenHeader.ghFrag: Expected CHSCond!"
          Endif   pos -> closeIf (headerTh `snocDL` "#endif\n") 
                                 (s, fragsTh)
                                 []
                                 (Just []) 
                                 rest
          EOF         -> notClosedCondErr pos
    --
    -- turn a completed conditional into a `CHSCond' fragment
    --
    --  * `(s, fragsTh)' is the CPP directive `s' containing the condition under
    --   which `fragTh' should be executed; `alts' are alternative branches
    --   (with conditions); and `oelse' is an optional else-branch
    --
    closeIf headerTail (s, fragsTh) alts oelse rest = 
      do
        sentryName <- newName
        let sentry = onlyPosIdent nopos sentryName
                       -- don't use an internal ident, as we need to test for
                       -- equality with identifiers read from the .i file
                       -- during binding hook expansion
            header = openDL ['#':s, "\n",
                             "struct ", sentryName, ";\n"] 
                            `joinDL` headerTail
        return (header, Frag (CHSCond ((sentry, fragsTh):alts) oelse), rest)


-- exception handling
-- ------------------

-- exception identifier
--
ghExc :: String
ghExc  = "ghExc"

-- throw an exception
--
throwGHExc :: GH a
throwGHExc  = throwExc ghExc "Error during C header generation"

-- catch a `ghExc'
--
ifGHExc           :: CST s a -> CST s a -> CST s a
ifGHExc m handler  = m `catchExc` (ghExc, const handler)

-- raise an error followed by throwing a GH exception
--
raiseErrorGHExc          :: Position -> [String] -> GH a
raiseErrorGHExc pos errs  = raiseError pos errs >> throwGHExc


-- error messages
-- --------------

notClosedCondErr :: Position -> GH a
notClosedCondErr pos  =
  raiseErrorGHExc pos
    ["Unexpected end of file!",
     "File ended while the conditional block starting here was not closed \
     \properly."]

notOpenCondErr :: Position -> GH a
notOpenCondErr pos  =
  raiseErrorGHExc pos
    ["Missing #if[[n]def]!",
     "There is a #else, #elif, or #endif without an #if, #ifdef, or #ifndef."]