--  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 :: forall s. CHSModule -> CST s ([String], CHSModule, String)
genHeader CHSModule
mod = 
  do
    NameSupply
supply <- forall e s. PreCST e s NameSupply
getNameSupply
    ([String]
header, CHSModule
mod) <- forall e s a s'. PreCST e s a -> s -> PreCST e s' a
runCST (CHSModule -> GH ([String], CHSModule)
ghModule CHSModule
mod) (NameSupply -> [Name]
names NameSupply
supply)
                     forall s a. CST s a -> CST s a -> CST s a
`ifGHExc` forall (m :: * -> *) a. Monad m => a -> m a
return ([], [CHSFrag] -> CHSModule
CHSModule [])

    -- check for errors and finalise
    --
    Bool
errs <- forall e s. PreCST e s Bool
errorsPresent
    if Bool
errs
      then do
        String
errmsgs <- forall e s. PreCST e s String
showErrors
        forall e s a. String -> PreCST e s a
fatal (String
"Errors during generation of C header:\n\n"   -- fatal error
               forall a. [a] -> [a] -> [a]
++ String
errmsgs)
      else do
        String
warnmsgs <- forall e s. PreCST e s String
showErrors
        forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
header, CHSModule
mod, String
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 :: CST [Name] String
newName = forall s a e. (s -> (s, a)) -> PreCST e s a
transCST forall a b. (a -> b) -> a -> b
$
  \[Name]
supply -> (forall a. [a] -> [a]
tail [Name]
supply, String
"C2HS_COND_SENTRY_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. [a] -> a
head [Name]
supply))

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

instance Pos FragElem where
  posOf :: FragElem -> Position
posOf (Frag CHSFrag
frag    ) = forall a. Pos a => a -> Position
posOf CHSFrag
frag
  posOf (Elif String
_    Position
pos) = Position
pos
  posOf (Else      Position
pos) = Position
pos
  posOf (Endif     Position
pos) = Position
pos
  posOf FragElem
EOF             = Position
nopos

-- check for end of file
--
isEOF :: FragElem -> Bool
isEOF :: FragElem -> Bool
isEOF FragElem
EOF = Bool
True
isEOF FragElem
_   = Bool
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 -> GH ([String], CHSModule)
ghModule (CHSModule [CHSFrag]
frags) =
  do
    (DList String
header, [CHSFrag]
frags, FragElem
last, [CHSFrag]
rest) <- [CHSFrag] -> GH (DList String, [CHSFrag], FragElem, [CHSFrag])
ghFrags [CHSFrag]
frags
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. FragElem -> Bool
isEOF forall a b. (a -> b) -> a -> b
$ FragElem
last) forall a b. (a -> b) -> a -> b
$
      forall a. Position -> GH a
notOpenCondErr (forall a. Pos a => a -> Position
posOf FragElem
last)
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. DList a -> [a]
closeDL DList String
header, [CHSFrag] -> CHSModule
CHSModule [CHSFrag]
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 :: [CHSFrag] -> GH (DList String, [CHSFrag], FragElem, [CHSFrag])
ghFrags []    = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
zeroDL, [], FragElem
EOF, [])
ghFrags [CHSFrag]
frags = 
  do
    (DList String
header, FragElem
frag, [CHSFrag]
rest) <- [CHSFrag] -> GH (DList String, FragElem, [CHSFrag])
ghFrag [CHSFrag]
frags
    case FragElem
frag of
      Frag CHSFrag
aFrag -> do
                      (DList String
header2, [CHSFrag]
frags', FragElem
frag', [CHSFrag]
rest) <- [CHSFrag] -> GH (DList String, [CHSFrag], FragElem, [CHSFrag])
ghFrags [CHSFrag]
rest
                      -- FIXME: Not tail rec
                      forall (m :: * -> *) a. Monad m => a -> m a
return (DList String
header forall a. DList a -> DList a -> DList a
`joinDL` DList String
header2, CHSFrag
aFragforall a. a -> [a] -> [a]
:[CHSFrag]
frags', 
                              FragElem
frag', [CHSFrag]
rest)
      FragElem
_          -> forall (m :: * -> *) a. Monad m => a -> m a
return (DList String
header, [], FragElem
frag, [CHSFrag]
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 :: [CHSFrag] -> GH (DList String, FragElem, [CHSFrag])
ghFrag []                              =
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
zeroDL, FragElem
EOF, [])
ghFrag (frag :: CHSFrag
frag@(CHSVerb  String
_ Position
_  ) : [CHSFrag]
frags) = 
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
zeroDL, CHSFrag -> FragElem
Frag CHSFrag
frag, [CHSFrag]
frags)
ghFrag (frag :: CHSFrag
frag@(CHSHook  CHSHook
_    ) : [CHSFrag]
frags) =
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
zeroDL, CHSFrag -> FragElem
Frag CHSFrag
frag, [CHSFrag]
frags)
ghFrag (frag :: CHSFrag
frag@(CHSLine  Position
_    ) : [CHSFrag]
frags) =
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
zeroDL, CHSFrag -> FragElem
Frag CHSFrag
frag, [CHSFrag]
frags)
ghFrag (frag :: CHSFrag
frag@(CHSLang  [String]
_ Position
_  ) : [CHSFrag]
frags) =
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
zeroDL, CHSFrag -> FragElem
Frag CHSFrag
frag, [CHSFrag]
frags)
ghFrag (     (CHSC    String
s  Position
_  ) : [CHSFrag]
frags) =
  do
    (DList String
header, FragElem
frag, [CHSFrag]
frags' ) <- [CHSFrag] -> GH (DList String, FragElem, [CHSFrag])
ghFrag [CHSFrag]
frags     -- scan for next CHS fragment
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> [a] -> [a]
unitDL String
s forall a. DList a -> DList a -> DList a
`joinDL` DList String
header, FragElem
frag, [CHSFrag]
frags')
    -- FIXME: this is not tail recursive...
ghFrag (     (CHSCond [(Ident, [CHSFrag])]
_  Maybe [CHSFrag]
_  ) : [CHSFrag]
frags) =
  forall a. String -> a
interr String
"GenHeader.ghFrags: There can't be a structured conditional yet!"
ghFrag (frag :: CHSFrag
frag@(CHSCPP  String
s  Position
pos) : [CHSFrag]
frags) =
  let
    (String
directive, String
_) =   forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
" \t")
                     forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
" \t") 
                     forall a b. (a -> b) -> a -> b
$ String
s
  in
  case String
directive of
    String
"if"     -> String
-> Position -> [CHSFrag] -> GH (DList String, FragElem, [CHSFrag])
openIf String
s Position
pos [CHSFrag]
frags
    String
"ifdef"  -> String
-> Position -> [CHSFrag] -> GH (DList String, FragElem, [CHSFrag])
openIf String
s Position
pos [CHSFrag]
frags
    String
"ifndef" -> String
-> Position -> [CHSFrag] -> GH (DList String, FragElem, [CHSFrag])
openIf String
s Position
pos [CHSFrag]
frags
    String
"else"   -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
zeroDL              , Position -> FragElem
Else   Position
pos               , [CHSFrag]
frags)
    String
"elif"   -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
zeroDL              , String -> Position -> FragElem
Elif String
s Position
pos               , [CHSFrag]
frags)
    String
"endif"  -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
zeroDL              , Position -> FragElem
Endif  Position
pos               , [CHSFrag]
frags)
    String
_        -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a] -> [a]
openDL [Char
'#'forall a. a -> [a] -> [a]
:String
s, String
"\n"], CHSFrag -> FragElem
Frag   (String -> Position -> CHSFrag
CHSVerb String
"" Position
nopos), [CHSFrag]
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 :: String
-> Position -> [CHSFrag] -> GH (DList String, FragElem, [CHSFrag])
openIf String
s Position
pos [CHSFrag]
frags = 
      do
        (DList String
headerTh, [CHSFrag]
fragsTh, FragElem
last, [CHSFrag]
rest) <- [CHSFrag] -> GH (DList String, [CHSFrag], FragElem, [CHSFrag])
ghFrags [CHSFrag]
frags
        case FragElem
last of
          Else    Position
pos -> do
                           (DList String
headerEl, [CHSFrag]
fragsEl, FragElem
last, [CHSFrag]
rest) <- [CHSFrag] -> GH (DList String, [CHSFrag], FragElem, [CHSFrag])
ghFrags [CHSFrag]
rest
                           case FragElem
last of
                             Else    Position
pos -> forall a. Position -> GH a
notOpenCondErr Position
pos
                             Elif  String
_ Position
pos -> forall a. Position -> GH a
notOpenCondErr Position
pos
                             Endif   Position
pos -> forall {c}.
DList String
-> (String, [CHSFrag])
-> [(Ident, [CHSFrag])]
-> Maybe [CHSFrag]
-> c
-> PreCST SwitchBoard [Name] (DList String, FragElem, c)
closeIf 
                                              ((DList String
headerTh 
                                                forall a. DList a -> a -> DList a
`snocDL` String
"#else\n")
                                               forall a. DList a -> DList a -> DList a
`joinDL` 
                                               (DList String
headerEl
                                                forall a. DList a -> a -> DList a
`snocDL` String
"#endif\n"))
                                              (String
s, [CHSFrag]
fragsTh)
                                              []
                                              (forall a. a -> Maybe a
Just [CHSFrag]
fragsEl)
                                              [CHSFrag]
rest
                             FragElem
EOF         -> forall a. Position -> GH a
notClosedCondErr Position
pos
          Elif String
s' Position
pos -> do
                           (DList String
headerEl, FragElem
condFrag, [CHSFrag]
rest) <- String
-> Position -> [CHSFrag] -> GH (DList String, FragElem, [CHSFrag])
openIf String
s' Position
pos [CHSFrag]
rest
                           case FragElem
condFrag of
                             Frag (CHSCond [(Ident, [CHSFrag])]
alts Maybe [CHSFrag]
dft) -> 
                               forall {c}.
DList String
-> (String, [CHSFrag])
-> [(Ident, [CHSFrag])]
-> Maybe [CHSFrag]
-> c
-> PreCST SwitchBoard [Name] (DList String, FragElem, c)
closeIf (DList String
headerTh forall a. DList a -> DList a -> DList a
`joinDL` DList String
headerEl)
                                       (String
s, [CHSFrag]
fragsTh)
                                       [(Ident, [CHSFrag])]
alts
                                       Maybe [CHSFrag]
dft
                                       [CHSFrag]
rest
                             FragElem
_                       -> 
                               forall a. String -> a
interr String
"GenHeader.ghFrag: Expected CHSCond!"
          Endif   Position
pos -> forall {c}.
DList String
-> (String, [CHSFrag])
-> [(Ident, [CHSFrag])]
-> Maybe [CHSFrag]
-> c
-> PreCST SwitchBoard [Name] (DList String, FragElem, c)
closeIf (DList String
headerTh forall a. DList a -> a -> DList a
`snocDL` String
"#endif\n") 
                                 (String
s, [CHSFrag]
fragsTh)
                                 []
                                 (forall a. a -> Maybe a
Just []) 
                                 [CHSFrag]
rest
          FragElem
EOF         -> forall a. Position -> GH a
notClosedCondErr Position
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 :: DList String
-> (String, [CHSFrag])
-> [(Ident, [CHSFrag])]
-> Maybe [CHSFrag]
-> c
-> PreCST SwitchBoard [Name] (DList String, FragElem, c)
closeIf DList String
headerTail (String
s, [CHSFrag]
fragsTh) [(Ident, [CHSFrag])]
alts Maybe [CHSFrag]
oelse c
rest = 
      do
        String
sentryName <- CST [Name] String
newName
        let sentry :: Ident
sentry = Position -> String -> Ident
onlyPosIdent Position
nopos String
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 :: DList String
header = forall a. [a] -> [a] -> [a]
openDL [Char
'#'forall a. a -> [a] -> [a]
:String
s, String
"\n",
                             String
"struct ", String
sentryName, String
";\n"] 
                            forall a. DList a -> DList a -> DList a
`joinDL` DList String
headerTail
        forall (m :: * -> *) a. Monad m => a -> m a
return (DList String
header, CHSFrag -> FragElem
Frag ([(Ident, [CHSFrag])] -> Maybe [CHSFrag] -> CHSFrag
CHSCond ((Ident
sentry, [CHSFrag]
fragsTh)forall a. a -> [a] -> [a]
:[(Ident, [CHSFrag])]
alts) Maybe [CHSFrag]
oelse), c
rest)


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

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

-- throw an exception
--
throwGHExc :: GH a
throwGHExc :: forall a. GH a
throwGHExc  = forall e s a. String -> String -> PreCST e s a
throwExc String
ghExc String
"Error during C header generation"

-- catch a `ghExc'
--
ifGHExc           :: CST s a -> CST s a -> CST s a
ifGHExc :: forall s a. CST s a -> CST s a -> CST s a
ifGHExc CST s a
m CST s a
handler  = CST s a
m forall e s a.
PreCST e s a -> (String, String -> PreCST e s a) -> PreCST e s a
`catchExc` (String
ghExc, forall a b. a -> b -> a
const CST s a
handler)

-- raise an error followed by throwing a GH exception
--
raiseErrorGHExc          :: Position -> [String] -> GH a
raiseErrorGHExc :: forall a. Position -> [String] -> GH a
raiseErrorGHExc Position
pos [String]
errs  = forall e s. Position -> [String] -> PreCST e s ()
raiseError Position
pos [String]
errs forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. GH a
throwGHExc


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

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

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