-- C->Haskell Compiler: custom header generator
--
-- Author : Manuel M T Chakravarty
-- Created: 5 February 2003
--
-- 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 C2HS.Gen.Header (
genHeader
) where
-- standard libraries
import Control.Monad (when,liftM)
-- Language.C / Compiler Toolkit
import Language.C.Data
import Language.C.Pretty
import Language.C.Syntax
import Data.Errors (interr)
import Data.DList (DList)
import qualified Data.DList as DL
-- C->Haskell
import C2HS.State (CST, runCST, transCST, raiseError, catchExc,
throwExc, errorsPresent, showErrors, fatal)
-- friends
import C2HS.CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSChangeCase(..),
CHSTrans(..), CHSAPath(..))
-- | 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
(header, mod'') <- runCST (ghModule mod') newNameSupply
`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 conditional.
--
newName :: CST [Name] String
newName = transCST $
\supply -> (tail supply, "C2HS_COND_SENTRY_" ++ (show.nameId) (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 (DL.toList 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 (DL.empty, [], 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 `DL.append` 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 (DL.empty, EOF, [])
ghFrag (frag@(CHSVerb _ _ ) : frags) =
return (DL.empty, Frag frag, frags)
-- generate an
-- enum __c2hs__enum__'id { __c2hs_enr__'id = DEF1, ... }
-- and then process an ordinary enum directive
ghFrag (_frag@(CHSHook (CHSEnumDefine hsident trans
instances pos) hkpos) : frags) =
do ide <- newEnumIdent
(enrs,trans') <- createEnumerators trans
return (DL.fromList [show.pretty $ enumDef ide enrs,";\n"],
Frag (enumFrag (identToString ide) trans'), frags)
where
newEnumIdent = liftM internalIdent $ transCST $
\supply -> (tail supply, "__c2hs_enum__" ++
show (nameId $ head supply))
newEnrIdent = liftM internalIdent $ transCST $
\supply -> (tail supply, "__c2hs_enr__" ++
show (nameId $ head supply))
createEnumerators (CHSTrans isUnderscore changeCase aliases omits)
| isUnderscore =
raiseErrorGHExc pos ["underScoreToCase is meaningless " ++
"for `enum define' hooks"]
| changeCase /= CHSSameCase =
raiseErrorGHExc pos ["changing case is meaningless " ++
"for `enum define' hooks"]
| otherwise =
do (enrs,transtbl') <- liftM unzip (mapM createEnumerator aliases)
return (enrs,CHSTrans False CHSSameCase transtbl' omits)
createEnumerator (cid,hsid) =
liftM (\enr -> ((enr,cid),(enr,hsid))) newEnrIdent
enumDef ide enrs = CEnum (Just ide) (Just$ map mkEnr enrs) [] undefNode
where mkEnr (name,value) = (name, Just $ CVar value undefNode)
enumFrag ide trans' = CHSHook (CHSEnum (internalIdent ide) (Just hsident)
trans' True Nothing Nothing
instances pos) hkpos
ghFrag (_frag@(CHSHook (CHSConst cident pos) hkpos) : frags) =
do ide <- newConstIdent
return (DL.fromList [show.pretty $ constDef ide,";\n"],
Frag (CHSHook (CHSConst ide pos) hkpos), frags)
where
newConstIdent =
liftM internalIdent $ transCST $
\supply -> (tail supply, "__c2hs__const__" ++ show (nameId $ head supply))
constDef ide =
-- This is a little nasty. We write a definition of an *integer*
-- C value into the header, regardless of what type it really
-- is...
CDecl [CTypeSpec (CIntType undefNode)]
[(Just (CDeclr (Just ide) [] Nothing [] undefNode),
Just (CInitExpr (CVar cident undefNode) undefNode),
Nothing)]
undefNode
ghFrag (frag@(CHSHook (CHSFun _ _ _ True varTypes
(CHSRoot _ ide) oalias _ _ _ _) _) : frags) = do
let ideLexeme = identToString ide
hsLexeme = ideLexeme `maybe` identToString $ oalias
vaIdent base idx = "__c2hs__vararg__" ++ base ++ "_" ++ show idx
ides = map (vaIdent hsLexeme) [0..length varTypes - 1]
defs = zipWith (\t i -> t ++ " " ++ i ++ ";\n") varTypes ides
return (DL.fromList defs, Frag frag, frags)
ghFrag (frag@(CHSHook (CHSTypedef cIde hsIde _) _) : frags) = do
let cTypLexeme = identToString cIde
hsTypLexeme = identToString hsIde
defs = [cTypLexeme ++ " __c2hs_typedef__" ++
cTypLexeme ++ "__" ++ hsTypLexeme ++ ";\n"]
return (DL.fromList defs, Frag frag, frags)
ghFrag (frag@(CHSHook _ _) : frags) = return (DL.empty, Frag frag, frags)
ghFrag (frag@(CHSLine _ ) : frags) = return (DL.empty, Frag frag, frags)
ghFrag ( (CHSC s _ ) : frags) =
do
(header, frag, frags' ) <- ghFrag frags -- scan for next CHS fragment
return (DL.singleton s `DL.append` header, frag, frags')
-- FIXME: this is not tail recursive...
ghFrag ( (CHSCond _ _ ) : _ ) =
interr "GenHeader.ghFrags: There can't be a structured conditional yet!"
ghFrag ( (CHSCPP s pos nl) : 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 (DL.empty , Else pos , frags)
"elif" -> return (DL.empty , Elif s pos , frags)
"endif" -> return (DL.empty , Endif pos , frags)
_ -> return (DL.fromList ['#':s, "\n"],
Frag (CHSVerb (if nl then "\n" else "") pos), 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 _ -> closeIf
((headerTh
`DL.snoc` "#else\n")
`DL.append`
(headerEl
`DL.snoc` "#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 `DL.append` headerEl)
(s, fragsTh)
alts
dft
rest'
_ ->
interr "GenHeader.ghFrag: Expected CHSCond!"
Endif _ -> closeIf (headerTh `DL.snoc` "#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 = internalIdent 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 = DL.fromList ['#':s', "\n",
"struct ", sentryName, ";\n"]
`DL.append` 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."]