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
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 [])
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"
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)
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))
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
isEOF :: FragElem -> Bool
isEOF :: FragElem -> Bool
isEOF FragElem
EOF = Bool
True
isEOF FragElem
_ = Bool
False
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)
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
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)
ghFrag :: [CHSFrag] -> GH (DList String,
FragElem,
[CHSFrag])
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
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')
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
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
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
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)
ghExc :: String
ghExc :: String
ghExc = String
"ghExc"
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"
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)
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
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."]