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 <- PreCST SwitchBoard s NameSupply
forall e s. PreCST e s NameSupply
getNameSupply
([String]
header, CHSModule
mod) <- PreCST SwitchBoard [Name] ([String], CHSModule)
-> [Name] -> PreCST SwitchBoard s ([String], CHSModule)
forall e s a s'. PreCST e s a -> s -> PreCST e s' a
runCST (CHSModule -> PreCST SwitchBoard [Name] ([String], CHSModule)
ghModule CHSModule
mod) (NameSupply -> [Name]
names NameSupply
supply)
PreCST SwitchBoard s ([String], CHSModule)
-> PreCST SwitchBoard s ([String], CHSModule)
-> PreCST SwitchBoard s ([String], CHSModule)
forall s a. CST s a -> CST s a -> CST s a
`ifGHExc` ([String], CHSModule) -> PreCST SwitchBoard s ([String], CHSModule)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [CHSFrag] -> CHSModule
CHSModule [])
Bool
errs <- PreCST SwitchBoard s Bool
forall e s. PreCST e s Bool
errorsPresent
if Bool
errs
then do
String
errmsgs <- PreCST SwitchBoard s String
forall e s. PreCST e s String
showErrors
String -> CST s ([String], CHSModule, String)
forall e s a. String -> PreCST e s a
fatal (String
"Errors during generation of C header:\n\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
errmsgs)
else do
String
warnmsgs <- PreCST SwitchBoard s String
forall e s. PreCST e s String
showErrors
([String], CHSModule, String)
-> CST s ([String], CHSModule, String)
forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
header, CHSModule
mod, String
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. [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. [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
(DList String
header, [CHSFrag]
frags, FragElem
last, [CHSFrag]
rest) <- [CHSFrag] -> GH (DList String, [CHSFrag], FragElem, [CHSFrag])
ghFrags [CHSFrag]
frags
Bool
-> PreCST SwitchBoard [Name] () -> PreCST SwitchBoard [Name] ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> (FragElem -> Bool) -> FragElem -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FragElem -> Bool
isEOF (FragElem -> Bool) -> FragElem -> Bool
forall a b. (a -> b) -> a -> b
$ FragElem
last) (PreCST SwitchBoard [Name] () -> PreCST SwitchBoard [Name] ())
-> PreCST SwitchBoard [Name] () -> PreCST SwitchBoard [Name] ()
forall a b. (a -> b) -> a -> b
$
Position -> PreCST SwitchBoard [Name] ()
forall a. Position -> GH a
notOpenCondErr (FragElem -> Position
forall a. Pos a => a -> Position
posOf FragElem
last)
([String], CHSModule)
-> PreCST SwitchBoard [Name] ([String], CHSModule)
forall (m :: * -> *) a. Monad m => a -> m a
return (DList String -> [String]
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 [] = (DList String, [CHSFrag], FragElem, [CHSFrag])
-> GH (DList String, [CHSFrag], FragElem, [CHSFrag])
forall (m :: * -> *) a. Monad m => a -> m a
return (DList String
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
(DList String, [CHSFrag], FragElem, [CHSFrag])
-> GH (DList String, [CHSFrag], FragElem, [CHSFrag])
forall (m :: * -> *) a. Monad m => a -> m a
return (DList String
header DList String -> DList String -> DList String
forall a. DList a -> DList a -> DList a
`joinDL` DList String
header2, CHSFrag
aFragCHSFrag -> [CHSFrag] -> [CHSFrag]
forall a. a -> [a] -> [a]
:[CHSFrag]
frags',
FragElem
frag', [CHSFrag]
rest)
FragElem
_ -> (DList String, [CHSFrag], FragElem, [CHSFrag])
-> GH (DList String, [CHSFrag], FragElem, [CHSFrag])
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 (m :: * -> *) a. Monad m => a -> m a
return (DList String
forall a. [a] -> [a]
zeroDL, FragElem
EOF, [])
ghFrag (frag :: CHSFrag
frag@(CHSVerb String
_ Position
_ ) : [CHSFrag]
frags) =
(DList String, FragElem, [CHSFrag])
-> GH (DList String, FragElem, [CHSFrag])
forall (m :: * -> *) a. Monad m => a -> m a
return (DList String
forall a. [a] -> [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 (m :: * -> *) a. Monad m => a -> m a
return (DList String
forall a. [a] -> [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 (m :: * -> *) a. Monad m => a -> m a
return (DList String
forall a. [a] -> [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 (m :: * -> *) a. Monad m => a -> m a
return (DList String
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
(DList String, FragElem, [CHSFrag])
-> GH (DList String, FragElem, [CHSFrag])
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> DList String
forall a. a -> [a] -> [a]
unitDL String
s DList String -> DList String -> DList String
forall a. DList a -> DList a -> DList a
`joinDL` DList String
header, FragElem
frag, [CHSFrag]
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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return (DList String
forall a. [a] -> [a]
zeroDL , Position -> FragElem
Else Position
pos , [CHSFrag]
frags)
String
"elif" -> (DList String, FragElem, [CHSFrag])
-> GH (DList String, FragElem, [CHSFrag])
forall (m :: * -> *) a. Monad m => a -> m a
return (DList String
forall a. [a] -> [a]
zeroDL , String -> Position -> FragElem
Elif String
s Position
pos , [CHSFrag]
frags)
String
"endif" -> (DList String, FragElem, [CHSFrag])
-> GH (DList String, FragElem, [CHSFrag])
forall (m :: * -> *) a. Monad m => a -> m a
return (DList String
forall a. [a] -> [a]
zeroDL , Position -> FragElem
Endif Position
pos , [CHSFrag]
frags)
String
_ -> (DList String, FragElem, [CHSFrag])
-> GH (DList String, FragElem, [CHSFrag])
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
(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 -> 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
(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) ->
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
String
sentryName <- CST [Name] String
newName
let sentry :: Ident
sentry = Position -> String -> Ident
onlyPosIdent Position
nopos String
sentryName
header :: DList String
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
(DList String, FragElem, c)
-> PreCST SwitchBoard [Name] (DList String, FragElem, c)
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)(Ident, [CHSFrag]) -> [(Ident, [CHSFrag])] -> [(Ident, [CHSFrag])]
forall a. a -> [a] -> [a]
:[(Ident, [CHSFrag])]
alts) Maybe [CHSFrag]
oelse), c
rest)
ghExc :: String
ghExc :: String
ghExc = String
"ghExc"
throwGHExc :: GH a
throwGHExc :: GH a
throwGHExc = String -> String -> GH 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 :: 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 :: 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] () -> GH a -> GH a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GH a
forall a. GH a
throwGHExc
notClosedCondErr :: Position -> GH a
notClosedCondErr :: 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 :: 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."]