module GenHeader (
genHeader
) where
import Control.Monad (when)
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)
import C2HSState (CST, getNameSupply, runCST, transCST, raiseError, catchExc,
throwExc, errorsPresent, showErrors, fatal)
import CHS (CHSModule(..), CHSFrag(..))
type GH a = CST [Name] a
genHeader :: CHSModule -> CST s ([String], CHSModule, String)
genHeader mod =
do
supply <- getNameSupply
(header, mod) <- runCST (ghModule mod) (names supply)
`ifGHExc` return ([], CHSModule [])
errs <- errorsPresent
if errs
then do
errmsgs <- showErrors
fatal ("Errors during generation of C header:\n\n"
++ errmsgs)
else do
warnmsgs <- showErrors
return (header, mod, warnmsgs)
newName :: CST [Name] String
newName = transCST $
\supply -> (tail supply, "C2HS_COND_SENTRY_" ++ show (head supply))
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
isEOF :: FragElem -> Bool
isEOF EOF = True
isEOF _ = False
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)
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
return (header `joinDL` header2, aFrag:frags',
frag', rest)
_ -> return (header, [], frag, rest)
ghFrag :: [CHSFrag] -> GH (DList String,
FragElem,
[CHSFrag])
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
return (unitDL s `joinDL` header, frag, frags')
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
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
closeIf headerTail (s, fragsTh) alts oelse rest =
do
sentryName <- newName
let sentry = onlyPosIdent nopos sentryName
header = openDL ['#':s, "\n",
"struct ", sentryName, ";\n"]
`joinDL` headerTail
return (header, Frag (CHSCond ((sentry, fragsTh):alts) oelse), rest)
ghExc :: String
ghExc = "ghExc"
throwGHExc :: GH a
throwGHExc = throwExc ghExc "Error during C header generation"
ifGHExc :: CST s a -> CST s a -> CST s a
ifGHExc m handler = m `catchExc` (ghExc, const handler)
raiseErrorGHExc :: Position -> [String] -> GH a
raiseErrorGHExc pos errs = raiseError pos errs >> throwGHExc
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."]