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)
CHSModule
mod =
do
supply <- PreCST SwitchBoard s NameSupply
forall e s. PreCST e s NameSupply
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 :: CST [Name] String
newName = ([Name] -> ([Name], String)) -> CST [Name] String
forall s a e. (s -> (s, a)) -> PreCST e s a
transCST (([Name] -> ([Name], String)) -> CST [Name] String)
-> ([Name] -> ([Name], String)) -> CST [Name] String
forall a b. (a -> b) -> a -> b
$
\[Name]
supply -> ([Name] -> [Name]
forall a. HasCallStack => [a] -> [a]
tail [Name]
supply, String
"C2HS_COND_SENTRY_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show ([Name] -> Name
forall a. HasCallStack => [a] -> a
head [Name]
supply))
data FragElem = Frag CHSFrag
| Elif String Position
| Else Position
| Endif Position
| EOF
instance Pos FragElem where
posOf :: FragElem -> Position
posOf (Frag CHSFrag
frag ) = CHSFrag -> Position
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
isEOF :: FragElem -> Bool
isEOF :: FragElem -> Bool
isEOF FragElem
EOF = Bool
True
isEOF FragElem
_ = Bool
False
ghModule :: CHSModule -> GH ([String], CHSModule)
ghModule :: CHSModule -> PreCST SwitchBoard [Name] ([String], CHSModule)
ghModule (CHSModule [CHSFrag]
frags) =
do
(header, frags, last, rest) <- [CHSFrag] -> GH (DList String, [CHSFrag], FragElem, [CHSFrag])
ghFrags [CHSFrag]
frags
when (not . isEOF $ last) $
notOpenCondErr (posOf last)
return (closeDL header, CHSModule frags)
ghFrags :: [CHSFrag] -> GH (DList String, [CHSFrag], FragElem, [CHSFrag])
ghFrags :: [CHSFrag] -> GH (DList String, [CHSFrag], FragElem, [CHSFrag])
ghFrags [] = (DList String, [CHSFrag], FragElem, [CHSFrag])
-> GH (DList String, [CHSFrag], FragElem, [CHSFrag])
forall a. a -> PreCST SwitchBoard [Name] a
forall (m :: * -> *) a. Monad m => a -> m a
return (DList String
forall a. DList a
zeroDL, [], FragElem
EOF, [])
ghFrags [CHSFrag]
frags =
do
(header, frag, rest) <- [CHSFrag] -> GH (DList String, FragElem, [CHSFrag])
ghFrag [CHSFrag]
frags
case frag of
Frag CHSFrag
aFrag -> do
(header2, frags', frag', rest) <- [CHSFrag] -> GH (DList String, [CHSFrag], FragElem, [CHSFrag])
ghFrags [CHSFrag]
rest
return (header `joinDL` header2, aFrag:frags',
frag', rest)
FragElem
_ -> (DList String, [CHSFrag], FragElem, [CHSFrag])
-> GH (DList String, [CHSFrag], FragElem, [CHSFrag])
forall a. a -> PreCST SwitchBoard [Name] a
forall (m :: * -> *) a. Monad m => a -> m a
return (DList String
header, [], FragElem
frag, [CHSFrag]
rest)
ghFrag :: [CHSFrag] -> GH (DList String,
FragElem,
[CHSFrag])
ghFrag :: [CHSFrag] -> GH (DList String, FragElem, [CHSFrag])
ghFrag [] =
(DList String, FragElem, [CHSFrag])
-> GH (DList String, FragElem, [CHSFrag])
forall a. a -> PreCST SwitchBoard [Name] a
forall (m :: * -> *) a. Monad m => a -> m a
return (DList String
forall a. DList a
zeroDL, FragElem
EOF, [])
ghFrag (frag :: CHSFrag
frag@(CHSVerb String
_ Position
_ ) : [CHSFrag]
frags) =
(DList String, FragElem, [CHSFrag])
-> GH (DList String, FragElem, [CHSFrag])
forall a. a -> PreCST SwitchBoard [Name] a
forall (m :: * -> *) a. Monad m => a -> m a
return (DList String
forall a. DList a
zeroDL, CHSFrag -> FragElem
Frag CHSFrag
frag, [CHSFrag]
frags)
ghFrag (frag :: CHSFrag
frag@(CHSHook CHSHook
_ ) : [CHSFrag]
frags) =
(DList String, FragElem, [CHSFrag])
-> GH (DList String, FragElem, [CHSFrag])
forall a. a -> PreCST SwitchBoard [Name] a
forall (m :: * -> *) a. Monad m => a -> m a
return (DList String
forall a. DList a
zeroDL, CHSFrag -> FragElem
Frag CHSFrag
frag, [CHSFrag]
frags)
ghFrag (frag :: CHSFrag
frag@(CHSLine Position
_ ) : [CHSFrag]
frags) =
(DList String, FragElem, [CHSFrag])
-> GH (DList String, FragElem, [CHSFrag])
forall a. a -> PreCST SwitchBoard [Name] a
forall (m :: * -> *) a. Monad m => a -> m a
return (DList String
forall a. DList a
zeroDL, CHSFrag -> FragElem
Frag CHSFrag
frag, [CHSFrag]
frags)
ghFrag (frag :: CHSFrag
frag@(CHSLang [String]
_ Position
_ ) : [CHSFrag]
frags) =
(DList String, FragElem, [CHSFrag])
-> GH (DList String, FragElem, [CHSFrag])
forall a. a -> PreCST SwitchBoard [Name] a
forall (m :: * -> *) a. Monad m => a -> m a
return (DList String
forall a. DList a
zeroDL, CHSFrag -> FragElem
Frag CHSFrag
frag, [CHSFrag]
frags)
ghFrag ( (CHSC String
s Position
_ ) : [CHSFrag]
frags) =
do
(header, frag, frags' ) <- [CHSFrag] -> GH (DList String, FragElem, [CHSFrag])
ghFrag [CHSFrag]
frags
return (unitDL s `joinDL` header, frag, frags')
ghFrag ( (CHSCond [(Ident, [CHSFrag])]
_ Maybe [CHSFrag]
_ ) : [CHSFrag]
frags) =
String -> GH (DList String, FragElem, [CHSFrag])
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
_) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
" \t")
(String -> (String, String))
-> (String -> String) -> String -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
" \t")
(String -> (String, String)) -> String -> (String, String)
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" -> (DList String, FragElem, [CHSFrag])
-> GH (DList String, FragElem, [CHSFrag])
forall a. a -> PreCST SwitchBoard [Name] a
forall (m :: * -> *) a. Monad m => a -> m a
return (DList String
forall a. DList a
zeroDL , Position -> FragElem
Else Position
pos , [CHSFrag]
frags)
String
"elif" -> (DList String, FragElem, [CHSFrag])
-> GH (DList String, FragElem, [CHSFrag])
forall a. a -> PreCST SwitchBoard [Name] a
forall (m :: * -> *) a. Monad m => a -> m a
return (DList String
forall a. DList a
zeroDL , String -> Position -> FragElem
Elif String
s Position
pos , [CHSFrag]
frags)
String
"endif" -> (DList String, FragElem, [CHSFrag])
-> GH (DList String, FragElem, [CHSFrag])
forall a. a -> PreCST SwitchBoard [Name] a
forall (m :: * -> *) a. Monad m => a -> m a
return (DList String
forall a. DList a
zeroDL , Position -> FragElem
Endif Position
pos , [CHSFrag]
frags)
String
_ -> (DList String, FragElem, [CHSFrag])
-> GH (DList String, FragElem, [CHSFrag])
forall a. a -> PreCST SwitchBoard [Name] a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> DList String
forall a. [a] -> [a] -> [a]
openDL [Char
'#'Char -> String -> String
forall a. a -> [a] -> [a]
:String
s, String
"\n"], CHSFrag -> FragElem
Frag (String -> Position -> CHSFrag
CHSVerb String
"" Position
nopos), [CHSFrag]
frags)
where
openIf :: String
-> Position -> [CHSFrag] -> GH (DList String, FragElem, [CHSFrag])
openIf String
s Position
pos [CHSFrag]
frags =
do
(headerTh, fragsTh, last, rest) <- [CHSFrag] -> GH (DList String, [CHSFrag], FragElem, [CHSFrag])
ghFrags [CHSFrag]
frags
case last of
Else Position
pos -> do
(headerEl, fragsEl, last, rest) <- [CHSFrag] -> GH (DList String, [CHSFrag], FragElem, [CHSFrag])
ghFrags [CHSFrag]
rest
case last of
Else Position
pos -> Position -> GH (DList String, FragElem, [CHSFrag])
forall a. Position -> GH a
notOpenCondErr Position
pos
Elif String
_ Position
pos -> Position -> GH (DList String, FragElem, [CHSFrag])
forall a. Position -> GH a
notOpenCondErr Position
pos
Endif Position
pos -> DList String
-> (String, [CHSFrag])
-> [(Ident, [CHSFrag])]
-> Maybe [CHSFrag]
-> [CHSFrag]
-> GH (DList String, FragElem, [CHSFrag])
forall {c}.
DList String
-> (String, [CHSFrag])
-> [(Ident, [CHSFrag])]
-> Maybe [CHSFrag]
-> c
-> PreCST SwitchBoard [Name] (DList String, FragElem, c)
closeIf
((DList String
headerTh
DList String -> String -> DList String
forall a. DList a -> a -> DList a
`snocDL` String
"#else\n")
DList String -> DList String -> DList String
forall a. DList a -> DList a -> DList a
`joinDL`
(DList String
headerEl
DList String -> String -> DList String
forall a. DList a -> a -> DList a
`snocDL` String
"#endif\n"))
(String
s, [CHSFrag]
fragsTh)
[]
([CHSFrag] -> Maybe [CHSFrag]
forall a. a -> Maybe a
Just [CHSFrag]
fragsEl)
[CHSFrag]
rest
FragElem
EOF -> Position -> GH (DList String, FragElem, [CHSFrag])
forall a. Position -> GH a
notClosedCondErr Position
pos
Elif String
s' Position
pos -> do
(headerEl, condFrag, rest) <- String
-> Position -> [CHSFrag] -> GH (DList String, FragElem, [CHSFrag])
openIf String
s' Position
pos [CHSFrag]
rest
case condFrag of
Frag (CHSCond [(Ident, [CHSFrag])]
alts Maybe [CHSFrag]
dft) ->
DList String
-> (String, [CHSFrag])
-> [(Ident, [CHSFrag])]
-> Maybe [CHSFrag]
-> [CHSFrag]
-> GH (DList String, FragElem, [CHSFrag])
forall {c}.
DList String
-> (String, [CHSFrag])
-> [(Ident, [CHSFrag])]
-> Maybe [CHSFrag]
-> c
-> PreCST SwitchBoard [Name] (DList String, FragElem, c)
closeIf (DList String
headerTh DList String -> DList String -> DList String
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
_ ->
String -> GH (DList String, FragElem, [CHSFrag])
forall a. String -> a
interr String
"GenHeader.ghFrag: Expected CHSCond!"
Endif Position
pos -> DList String
-> (String, [CHSFrag])
-> [(Ident, [CHSFrag])]
-> Maybe [CHSFrag]
-> [CHSFrag]
-> GH (DList String, FragElem, [CHSFrag])
forall {c}.
DList String
-> (String, [CHSFrag])
-> [(Ident, [CHSFrag])]
-> Maybe [CHSFrag]
-> c
-> PreCST SwitchBoard [Name] (DList String, FragElem, c)
closeIf (DList String
headerTh DList String -> String -> DList String
forall a. DList a -> a -> DList a
`snocDL` String
"#endif\n")
(String
s, [CHSFrag]
fragsTh)
[]
([CHSFrag] -> Maybe [CHSFrag]
forall a. a -> Maybe a
Just [])
[CHSFrag]
rest
FragElem
EOF -> Position -> GH (DList String, FragElem, [CHSFrag])
forall a. Position -> GH a
notClosedCondErr Position
pos
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
sentryName <- CST [Name] String
newName
let sentry = Position -> String -> Ident
onlyPosIdent Position
nopos String
sentryName
header = [String] -> DList String
forall a. [a] -> [a] -> [a]
openDL [Char
'#'Char -> String -> String
forall a. a -> [a] -> [a]
:String
s, String
"\n",
String
"struct ", String
sentryName, String
";\n"]
DList String -> DList String -> DList String
forall a. DList a -> DList a -> DList a
`joinDL` DList String
headerTail
return (header, Frag (CHSCond ((sentry, fragsTh):alts) oelse), rest)
ghExc :: String
ghExc :: String
ghExc = String
"ghExc"
throwGHExc :: GH a
throwGHExc :: forall a. GH a
throwGHExc = String -> String -> PreCST SwitchBoard [Name] a
forall e s a. String -> String -> PreCST e s a
throwExc String
ghExc String
"Error during C header generation"
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 CST s a -> (String, String -> CST s a) -> CST s a
forall e s a.
PreCST e s a -> (String, String -> PreCST e s a) -> PreCST e s a
`catchExc` (String
ghExc, CST s a -> String -> CST s a
forall a b. a -> b -> a
const CST s a
handler)
raiseErrorGHExc :: Position -> [String] -> GH a
raiseErrorGHExc :: forall a. Position -> [String] -> GH a
raiseErrorGHExc Position
pos [String]
errs = Position -> [String] -> PreCST SwitchBoard [Name] ()
forall e s. Position -> [String] -> PreCST e s ()
raiseError Position
pos [String]
errs PreCST SwitchBoard [Name] ()
-> PreCST SwitchBoard [Name] a -> PreCST SwitchBoard [Name] a
forall a b.
PreCST SwitchBoard [Name] a
-> PreCST SwitchBoard [Name] b -> PreCST SwitchBoard [Name] b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PreCST SwitchBoard [Name] a
forall a. GH a
throwGHExc
notClosedCondErr :: Position -> GH a
notClosedCondErr :: forall a. Position -> GH a
notClosedCondErr Position
pos =
Position -> [String] -> GH a
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 =
Position -> [String] -> GH a
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."]