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)
mod :: CHSModule
mod =
do
NameSupply
supply <- PreCST SwitchBoard s NameSupply
forall e s. PreCST e s NameSupply
getNameSupply
(header :: [String]
header, mod :: 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 ("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
$
\supply :: [Name]
supply -> ([Name] -> [Name]
forall a. [a] -> [a]
tail [Name]
supply, "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 frag :: CHSFrag
frag ) = CHSFrag -> Position
forall a. Pos a => a -> Position
posOf CHSFrag
frag
posOf (Elif _ pos :: Position
pos) = Position
pos
posOf (Else pos :: Position
pos) = Position
pos
posOf (Endif pos :: Position
pos) = Position
pos
posOf EOF = Position
nopos
isEOF :: FragElem -> Bool
isEOF :: FragElem -> Bool
isEOF EOF = Bool
True
isEOF _ = Bool
False
ghModule :: CHSModule -> GH ([String], CHSModule)
ghModule :: CHSModule -> PreCST SwitchBoard [Name] ([String], CHSModule)
ghModule (CHSModule frags :: [CHSFrag]
frags) =
do
(header :: DList String
header, frags :: [CHSFrag]
frags, last :: FragElem
last, rest :: [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 frags :: [CHSFrag]
frags =
do
(header :: DList String
header, frag :: FragElem
frag, rest :: [CHSFrag]
rest) <- [CHSFrag] -> GH (DList String, FragElem, [CHSFrag])
ghFrag [CHSFrag]
frags
case FragElem
frag of
Frag aFrag :: CHSFrag
aFrag -> do
(header2 :: DList String
header2, frags' :: [CHSFrag]
frags', frag' :: FragElem
frag', rest :: [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)
_ -> (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 _ _ ) : frags :: [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 _ ) : frags :: [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 _ ) : frags :: [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 _ _ ) : frags :: [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 s :: String
s _ ) : frags :: [CHSFrag]
frags) =
do
(header :: DList String
header, frag :: FragElem
frag, frags' :: [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 _ _ ) : frags :: [CHSFrag]
frags) =
String -> GH (DList String, FragElem, [CHSFrag])
forall a. String -> a
interr "GenHeader.ghFrags: There can't be a structured conditional yet!"
ghFrag (frag :: CHSFrag
frag@(CHSCPP s :: String
s pos :: Position
pos) : frags :: [CHSFrag]
frags) =
let
(directive :: String
directive, _) = (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` " \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` " \t")
(String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ String
s
in
case String
directive of
"if" -> String
-> Position -> [CHSFrag] -> GH (DList String, FragElem, [CHSFrag])
openIf String
s Position
pos [CHSFrag]
frags
"ifdef" -> String
-> Position -> [CHSFrag] -> GH (DList String, FragElem, [CHSFrag])
openIf String
s Position
pos [CHSFrag]
frags
"ifndef" -> String
-> Position -> [CHSFrag] -> GH (DList String, FragElem, [CHSFrag])
openIf String
s Position
pos [CHSFrag]
frags
"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)
"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)
"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)
_ -> (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 -> String -> String
forall a. a -> [a] -> [a]
:String
s, "\n"], CHSFrag -> FragElem
Frag (String -> Position -> CHSFrag
CHSVerb "" Position
nopos), [CHSFrag]
frags)
where
openIf :: String
-> Position -> [CHSFrag] -> GH (DList String, FragElem, [CHSFrag])
openIf s :: String
s pos :: Position
pos frags :: [CHSFrag]
frags =
do
(headerTh :: DList String
headerTh, fragsTh :: [CHSFrag]
fragsTh, last :: FragElem
last, rest :: [CHSFrag]
rest) <- [CHSFrag] -> GH (DList String, [CHSFrag], FragElem, [CHSFrag])
ghFrags [CHSFrag]
frags
case FragElem
last of
Else pos :: Position
pos -> do
(headerEl :: DList String
headerEl, fragsEl :: [CHSFrag]
fragsEl, last :: FragElem
last, rest :: [CHSFrag]
rest) <- [CHSFrag] -> GH (DList String, [CHSFrag], FragElem, [CHSFrag])
ghFrags [CHSFrag]
rest
case FragElem
last of
Else pos :: Position
pos -> Position -> GH (DList String, FragElem, [CHSFrag])
forall a. Position -> GH a
notOpenCondErr Position
pos
Elif _ pos :: Position
pos -> Position -> GH (DList String, FragElem, [CHSFrag])
forall a. Position -> GH a
notOpenCondErr Position
pos
Endif pos :: 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` "#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` "#endif\n"))
(String
s, [CHSFrag]
fragsTh)
[]
([CHSFrag] -> Maybe [CHSFrag]
forall a. a -> Maybe a
Just [CHSFrag]
fragsEl)
[CHSFrag]
rest
EOF -> Position -> GH (DList String, FragElem, [CHSFrag])
forall a. Position -> GH a
notClosedCondErr Position
pos
Elif s' :: String
s' pos :: Position
pos -> do
(headerEl :: DList String
headerEl, condFrag :: FragElem
condFrag, rest :: [CHSFrag]
rest) <- String
-> Position -> [CHSFrag] -> GH (DList String, FragElem, [CHSFrag])
openIf String
s' Position
pos [CHSFrag]
rest
case FragElem
condFrag of
Frag (CHSCond alts :: [(Ident, [CHSFrag])]
alts dft :: 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
_ ->
String -> GH (DList String, FragElem, [CHSFrag])
forall a. String -> a
interr "GenHeader.ghFrag: Expected CHSCond!"
Endif pos :: 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` "#endif\n")
(String
s, [CHSFrag]
fragsTh)
[]
([CHSFrag] -> Maybe [CHSFrag]
forall a. a -> Maybe a
Just [])
[CHSFrag]
rest
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 headerTail :: DList String
headerTail (s :: String
s, fragsTh :: [CHSFrag]
fragsTh) alts :: [(Ident, [CHSFrag])]
alts oelse :: Maybe [CHSFrag]
oelse rest :: 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 -> String -> String
forall a. a -> [a] -> [a]
:String
s, "\n",
"struct ", String
sentryName, ";\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 = "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 "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 m :: CST s a
m handler :: 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 pos :: Position
pos errs :: [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 pos :: Position
pos =
Position -> [String] -> GH a
forall a. Position -> [String] -> GH a
raiseErrorGHExc Position
pos
["Unexpected end of file!",
"File ended while the conditional block starting here was not closed \
\properly."]
notOpenCondErr :: Position -> GH a
notOpenCondErr :: Position -> GH a
notOpenCondErr pos :: Position
pos =
Position -> [String] -> GH a
forall a. Position -> [String] -> GH a
raiseErrorGHExc Position
pos
["Missing #if[[n]def]!",
"There is a #else, #elif, or #endif without an #if, #ifdef, or #ifndef."]