module CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSTrans(..), CHSParm(..),
CHSArg(..), CHSAccess(..), CHSAPath(..), CHSPtrType(..),
skipToLangPragma, hasCPP,
loadCHS, dumpCHS, hssuffix, chssuffix, loadAllCHI, loadCHI, dumpCHI,
chisuffix, showCHSParm)
where
import Data.Char (isSpace, toUpper, toLower)
import Data.List (intersperse)
import Control.Monad (when, unless)
import Position (Position(..), Pos(posOf), nopos, isBuiltinPos)
import Errors (interr)
import Idents (Ident, identToLexeme, onlyPosIdent)
import C2HSState (CST, nop, doesFileExistCIO, readFileCIO, writeFileCIO, getId,
getSwitch, chiPathSB, catchExc, throwExc, raiseError,
fatal, errorsPresent, showErrors, Traces(..), putTraceStr)
import CHSLexer (CHSToken(..), lexCHS)
data CHSModule = CHSModule [CHSFrag]
data CHSFrag = CHSVerb String
Position
| CHSHook CHSHook
| CHSCPP String
Position
| CHSLine Position
| CHSC String
Position
| CHSCond [(Ident,
[CHSFrag])]
(Maybe [CHSFrag])
| CHSLang [String]
Position
instance Pos CHSFrag where
posOf (CHSVerb _ pos ) = pos
posOf (CHSHook hook ) = posOf hook
posOf (CHSCPP _ pos ) = pos
posOf (CHSLine pos ) = pos
posOf (CHSC _ pos ) = pos
posOf (CHSCond alts _) = case alts of
(_, frag:_):_ -> posOf frag
_ -> nopos
posOf (CHSLang _ pos) = pos
data CHSHook = CHSImport Bool
Ident
String
Position
| CHSContext (Maybe String)
(Maybe String)
(Maybe String)
Position
| CHSType Ident
Position
| CHSSizeof Ident
Position
| CHSEnum Ident
(Maybe Ident)
CHSTrans
(Maybe String)
[Ident]
Position
| CHSCall Bool
Bool
Bool
Ident
(Maybe Ident)
Position
| CHSFun Bool
Bool
Bool
Ident
(Maybe Ident)
(Maybe String)
[CHSParm]
CHSParm
Position
| CHSField CHSAccess
CHSAPath
Position
| CHSPointer Bool
Ident
(Maybe Ident)
CHSPtrType
Bool
(Maybe Ident)
Position
| CHSClass (Maybe Ident)
Ident
Ident
Position
instance Pos CHSHook where
posOf (CHSImport _ _ _ pos) = pos
posOf (CHSContext _ _ _ pos) = pos
posOf (CHSType _ pos) = pos
posOf (CHSSizeof _ pos) = pos
posOf (CHSEnum _ _ _ _ _ pos) = pos
posOf (CHSCall _ _ _ _ _ pos) = pos
posOf (CHSFun _ _ _ _ _ _ _ _ pos) = pos
posOf (CHSField _ _ pos) = pos
posOf (CHSPointer _ _ _ _ _ _ pos) = pos
posOf (CHSClass _ _ _ pos) = pos
instance Eq CHSHook where
(CHSImport qual1 ide1 _ _) == (CHSImport qual2 ide2 _ _) =
qual1 == qual2 && ide1 == ide2
(CHSContext olib1 opref1 olock1 _ ) ==
(CHSContext olib2 opref2 olock2 _ ) =
olib1 == olib1 && opref1 == opref2 && olock1 == olock2
(CHSType ide1 _) == (CHSType ide2 _) =
ide1 == ide2
(CHSSizeof ide1 _) == (CHSSizeof ide2 _) =
ide1 == ide2
(CHSEnum ide1 oalias1 _ _ _ _) == (CHSEnum ide2 oalias2 _ _ _ _) =
oalias1 == oalias2 && ide1 == ide2
(CHSCall _ _ _ ide1 oalias1 _) == (CHSCall _ _ _ ide2 oalias2 _) =
oalias1 == oalias2 && ide1 == ide2
(CHSFun _ _ _ ide1 oalias1 _ _ _ _)
== (CHSFun _ _ _ ide2 oalias2 _ _ _ _) =
oalias1 == oalias2 && ide1 == ide2
(CHSField acc1 path1 _) == (CHSField acc2 path2 _) =
acc1 == acc2 && path1 == path2
(CHSPointer _ ide1 oalias1 _ _ _ _)
== (CHSPointer _ ide2 oalias2 _ _ _ _) =
ide1 == ide2 && oalias1 == oalias2
(CHSClass _ ide1 _ _) == (CHSClass _ ide2 _ _) =
ide1 == ide2
_ == _ = False
data CHSTrans = CHSTrans Bool
[(Ident, Ident)]
data CHSParm = CHSParm (Maybe (Ident, CHSArg))
String
Bool
(Maybe (Ident, CHSArg))
Position
data CHSArg = CHSValArg
| CHSIOArg
| CHSVoidArg
deriving (Eq)
data CHSAccess = CHSSet
| CHSGet
deriving (Eq)
data CHSAPath = CHSRoot Ident
| CHSDeref CHSAPath Position
| CHSRef CHSAPath Ident
deriving (Eq)
data CHSPtrType = CHSPtr
| CHSForeignPtr
| CHSStablePtr
deriving (Eq)
instance Show CHSPtrType where
show CHSPtr = "Ptr"
show CHSForeignPtr = "ForeignPtr"
show CHSStablePtr = "StablePtr"
instance Read CHSPtrType where
readsPrec _ ( 'P':'t':'r':rest) =
[(CHSPtr, rest)]
readsPrec _ ('F':'o':'r':'e':'i':'g':'n':'P':'t':'r':rest) =
[(CHSForeignPtr, rest)]
readsPrec _ ('S':'t':'a':'b':'l':'e' :'P':'t':'r':rest) =
[(CHSStablePtr, rest)]
readsPrec p (c:cs)
| isSpace c = readsPrec p cs
readsPrec _ _ = []
skipToLangPragma :: CHSModule -> Maybe CHSModule
skipToLangPragma (CHSModule frags) = hLP frags
where
hLP all@(CHSLang exts _:_) = Just (CHSModule all)
hLP (x:xs) = hLP xs
hLP [] = Nothing
hasCPP :: CHSModule -> Bool
hasCPP (CHSModule (CHSLang exts _:_)) = "CPP" `elem` exts
hasCPP _ = False
hssuffix, chssuffix :: String
hssuffix = ".hs"
chssuffix = ".chs"
loadCHS :: FilePath -> CST s (CHSModule, String)
loadCHS fname = do
traceInfoRead fname
contents <- readFileCIO fname
traceInfoParse
mod <- parseCHSModule (Position fname 1 1) contents
errs <- errorsPresent
if errs
then do
traceInfoErr
errmsgs <- showErrors
fatal ("CHS module contains \
\errors:\n\n" ++ errmsgs)
else do
traceInfoOK
warnmsgs <- showErrors
return (mod, warnmsgs)
where
traceInfoRead fname = putTraceStr tracePhasesSW
("Attempting to read file `"
++ fname ++ "'...\n")
traceInfoParse = putTraceStr tracePhasesSW
("...parsing `"
++ fname ++ "'...\n")
traceInfoErr = putTraceStr tracePhasesSW
("...error(s) detected in `"
++ fname ++ "'.\n")
traceInfoOK = putTraceStr tracePhasesSW
("...successfully loaded `"
++ fname ++ "'.\n")
dumpCHS :: String -> CHSModule -> Bool -> CST s ()
dumpCHS fname mod pureHaskell =
do
let (suffix, kind) = if pureHaskell
then (hssuffix , "(Haskell)")
else (chssuffix, "(C->HS binding)")
(version, _, _) <- getId
writeFileCIO (fname ++ suffix) (contents version kind)
where
contents version kind | hasCPP mod = showCHSModule mod pureHaskell
| otherwise =
"-- GENERATED by " ++ version ++ " " ++ kind ++ "\n\
\-- Edit the ORIGNAL .chs file instead!\n\n"
++ showCHSModule mod pureHaskell
data LineState = Emit
| Wait
| NoLine
deriving (Eq)
showCHSModule :: CHSModule -> Bool -> String
showCHSModule (CHSModule frags) pureHaskell =
showFrags pureHaskell Emit frags []
where
showFrags :: Bool -> LineState -> [CHSFrag] -> ShowS
showFrags _ _ [] = id
showFrags pureHs state (CHSVerb s pos : frags) =
let
(Position fname line _) = pos
generated = isBuiltinPos pos
emitNow = state == Emit ||
(state == Wait && not (null s) && nlStart)
nlStart = head s == '\n'
nextState = if generated then Wait else NoLine
in
(if emitNow then
showString ("\n{-# LINE " ++ show (line `max` 0) ++ " " ++
show fname ++ " #-}" ++
(if nlStart then "" else "\n"))
else id)
. showString s
. showFrags pureHs nextState frags
showFrags False _ (CHSHook hook : frags) =
showString "{#"
. showCHSHook hook
. showString "#}"
. showFrags False Wait frags
showFrags False _ (CHSCPP s _ : frags) =
showChar '#'
. showString s
. showFrags False Emit frags
showFrags pureHs _ (CHSLine s : frags) =
showFrags pureHs Emit frags
showFrags False _ (CHSC s _ : frags) =
showString "\n#c"
. showString s
. showString "\n#endc"
. showFrags False Emit frags
showFrags False _ (CHSCond _ _ : frags) =
interr "showCHSFrag: Cannot print `CHSCond'!"
showFrags pureHs _ (CHSLang exts _ : frags) =
let extsNoCPP = filter ((/=) "CPP") exts in
if null extsNoCPP then showFrags pureHs Emit frags else
showString "{-# LANGUAGE "
. showString (concat (intersperse "," extsNoCPP))
. showString " #-}\n"
. showFrags pureHs Emit frags
showFrags True _ _ =
interr "showCHSFrag: Illegal hook, cpp directive, or inline C code!"
showCHSHook :: CHSHook -> ShowS
showCHSHook (CHSImport isQual ide _ _) =
showString "import "
. (if isQual then showString "qualified " else id)
. showCHSIdent ide
showCHSHook (CHSContext olib oprefix olock _) =
showString "context "
. (case olib of
Nothing -> showString ""
Just lib -> showString "lib = " . showString lib . showString " ")
. showPrefix oprefix False
. (case olock of
Nothing -> showString ""
Just lock -> showString "lock = " . showString lock . showString " ")
showCHSHook (CHSType ide _) =
showString "type "
. showCHSIdent ide
showCHSHook (CHSSizeof ide _) =
showString "sizeof "
. showCHSIdent ide
showCHSHook (CHSEnum ide oalias trans oprefix derive _) =
showString "enum "
. showIdAlias ide oalias
. showCHSTrans trans
. showPrefix oprefix True
. if null derive then id else showString $
"deriving ("
++ concat (intersperse ", " (map identToLexeme derive))
++ ") "
showCHSHook (CHSCall isPure isUns isNol ide oalias _) =
showString "call "
. (if isPure then showString "pure " else id)
. (if isUns then showString "unsafe " else id)
. (if isNol then showString "nolock " else id)
. showIdAlias ide oalias
showCHSHook (CHSFun isPure isUns isNol ide oalias octxt parms parm _) =
showString "fun "
. (if isPure then showString "pure " else id)
. (if isUns then showString "unsafe " else id)
. (if isNol then showString "nolock " else id)
. showIdAlias ide oalias
. (case octxt of
Nothing -> showChar ' '
Just ctxtStr -> showString ctxtStr . showString " => ")
. showString "{"
. foldr (.) id (intersperse (showString ", ") (map showCHSParm parms))
. showString "} -> "
. showCHSParm parm
showCHSHook (CHSField acc path _) =
(case acc of
CHSGet -> showString "get "
CHSSet -> showString "set ")
. showCHSAPath path
showCHSHook (CHSPointer star ide oalias ptrType isNewtype oRefType _) =
showString "pointer "
. (if star then showString "*" else showString "")
. showIdAlias ide oalias
. (case ptrType of
CHSForeignPtr -> showString " foreign"
CHSStablePtr -> showString " stable"
_ -> showString "")
. (case (isNewtype, oRefType) of
(True , _ ) -> showString " newtype"
(False, Just ide) -> showString " -> " . showCHSIdent ide
(False, Nothing ) -> showString "")
showCHSHook (CHSClass oclassIde classIde typeIde _) =
showString "class "
. (case oclassIde of
Nothing -> showString ""
Just classIde -> showCHSIdent classIde . showString " => ")
. showCHSIdent classIde
. showString " "
. showCHSIdent typeIde
showPrefix :: Maybe String -> Bool -> ShowS
showPrefix Nothing _ = showString ""
showPrefix (Just prefix) withWith = maybeWith
. showString "prefix = "
. showString prefix
. showString " "
where
maybeWith = if withWith then showString "with " else id
showIdAlias :: Ident -> Maybe Ident -> ShowS
showIdAlias ide oalias =
showCHSIdent ide
. (case oalias of
Nothing -> id
Just ide -> showString " as " . showCHSIdent ide)
showCHSParm :: CHSParm -> ShowS
showCHSParm (CHSParm oimMarsh hsTyStr twoCVals oomMarsh _) =
showOMarsh oimMarsh
. showChar ' '
. showHsVerb hsTyStr
. (if twoCVals then showChar '&' else id)
. showChar ' '
. showOMarsh oomMarsh
where
showOMarsh Nothing = id
showOMarsh (Just (ide, argKind)) = showCHSIdent ide
. (case argKind of
CHSValArg -> id
CHSIOArg -> showString "*"
CHSVoidArg -> showString "-")
showHsVerb str = showChar '`' . showString str . showChar '\''
showCHSTrans :: CHSTrans -> ShowS
showCHSTrans (CHSTrans _2Case assocs) =
showString "{"
. (if _2Case then showString ("underscoreToCase" ++ maybeComma) else id)
. foldr (.) id (intersperse (showString ", ") (map showAssoc assocs))
. showString "}"
where
maybeComma = if null assocs then "" else ", "
showAssoc (ide1, ide2) =
showCHSIdent ide1
. showString " as "
. showCHSIdent ide2
showCHSAPath :: CHSAPath -> ShowS
showCHSAPath (CHSRoot ide) =
showCHSIdent ide
showCHSAPath (CHSDeref path _) =
showString "* "
. showCHSAPath path
showCHSAPath (CHSRef (CHSDeref path _) ide) =
showCHSAPath path
. showString "->"
. showCHSIdent ide
showCHSAPath (CHSRef path ide) =
showCHSAPath path
. showString "."
. showCHSIdent ide
showCHSIdent :: Ident -> ShowS
showCHSIdent = showString . identToLexeme
chisuffix :: String
chisuffix = ".chi"
versionPrefix :: String
versionPrefix = "C->Haskell Interface Version "
loadAllCHI :: CHSModule -> CST s CHSModule
loadAllCHI (CHSModule frags) = do
let checkFrag (CHSHook (CHSImport qual name fName pos)) = do
chi <- loadCHI fName
return (CHSHook (CHSImport qual name chi pos))
checkFrag h = return h
frags' <- mapM checkFrag frags
return (CHSModule frags')
loadCHI :: FilePath -> CST s String
loadCHI fname = do
paths <- getSwitch chiPathSB
let fullnames = [path ++ '/':fname ++ chisuffix |
path <- paths]
fullname <- findFirst fullnames
(fatal $ fname++chisuffix++" not found in:\n"++
unlines paths)
traceInfoRead fullname
contents <- readFileCIO fullname
traceInfoVersion
let ls = lines contents
when (null ls) $
errorCHICorrupt fname
let versline:chi = ls
prefixLen = length versionPrefix
when (length versline < prefixLen
|| take prefixLen versline /= versionPrefix) $
errorCHICorrupt fname
let versline' = drop prefixLen versline
(major, minor) <- case majorMinor versline' of
Nothing -> errorCHICorrupt fname
Just majMin -> return majMin
(version, _, _) <- getId
let Just (myMajor, myMinor) = majorMinor version
when (major /= myMajor || minor /= myMinor) $
errorCHIVersion fname
(major ++ "." ++ minor) (myMajor ++ "." ++ myMinor)
traceInfoOK
return $ concat chi
where
traceInfoRead fname = putTraceStr tracePhasesSW
("Attempting to read file `"
++ fname ++ "'...\n")
traceInfoVersion = putTraceStr tracePhasesSW
("...checking version `"
++ fname ++ "'...\n")
traceInfoOK = putTraceStr tracePhasesSW
("...successfully loaded `"
++ fname ++ "'.\n")
findFirst [] err = err
findFirst (p:aths) err = do
e <- doesFileExistCIO p
if e then return p else findFirst aths err
dumpCHI :: String -> String -> CST s ()
dumpCHI fname contents =
do
(version, _, _) <- getId
writeFileCIO (fname ++ chisuffix) $
versionPrefix ++ version ++ "\n" ++ contents
majorMinor :: String -> Maybe (String, String)
majorMinor vers = let (major, rest) = break (== '.') vers
(minor, _ ) = break (== '.') . tail $ rest
in
if null rest then Nothing else Just (major, minor)
syntaxExc :: String
syntaxExc = "syntax"
ifError :: CST s a -> CST s a -> CST s a
ifError action handler = action `catchExc` (syntaxExc, const handler)
raiseSyntaxError :: CST s a
raiseSyntaxError = throwExc syntaxExc "syntax error"
parseCHSModule :: Position -> String -> CST s CHSModule
parseCHSModule pos cs = do
toks <- lexCHS cs pos
frags <- parseFrags toks
return (CHSModule frags)
parseFrags :: [CHSToken] -> CST s [CHSFrag]
parseFrags toks = do
parseFrags0 toks
`ifError` contFrags toks
where
parseFrags0 :: [CHSToken] -> CST s [CHSFrag]
parseFrags0 [] = return []
parseFrags0 (CHSTokHaskell pos s:toks) = do
frags <- parseFrags toks
return $ CHSVerb s pos : frags
parseFrags0 (CHSTokCtrl pos c:toks) = do
frags <- parseFrags toks
return $ CHSVerb [c] pos : frags
parseFrags0 (CHSTokCPP pos s:toks) = do
frags <- parseFrags toks
return $ CHSCPP s pos : frags
parseFrags0 (CHSTokLine pos :toks) = do
frags <- parseFrags toks
return $ CHSLine pos : frags
parseFrags0 (CHSTokC pos s:toks) = parseC pos s toks
parseFrags0 (CHSTokImport pos :toks) = parseImport pos toks
parseFrags0 (CHSTokContext pos :toks) = parseContext pos toks
parseFrags0 (CHSTokType pos :toks) = parseType pos toks
parseFrags0 (CHSTokSizeof pos :toks) = parseSizeof pos toks
parseFrags0 (CHSTokEnum pos :toks) = parseEnum pos toks
parseFrags0 (CHSTokCall pos :toks) = parseCall pos toks
parseFrags0 (CHSTokFun pos :toks) = parseFun pos toks
parseFrags0 (CHSTokGet pos :toks) = parseField pos CHSGet toks
parseFrags0 (CHSTokSet pos :toks) = parseField pos CHSSet toks
parseFrags0 (CHSTokClass pos :toks) = parseClass pos toks
parseFrags0 (CHSTokPointer pos :toks) = parsePointer pos toks
parseFrags0 (CHSTokPragma pos :toks) = parsePragma pos toks
parseFrags0 toks = syntaxError toks
contFrags [] = return []
contFrags toks@(CHSTokHaskell _ _:_ ) = parseFrags toks
contFrags toks@(CHSTokCtrl _ _:_ ) = parseFrags toks
contFrags (_ :toks) = contFrags toks
parseC :: Position -> String -> [CHSToken] -> CST s [CHSFrag]
parseC pos s toks =
do
frags <- collectCtrlAndC toks
return $ CHSC s pos : frags
where
collectCtrlAndC (CHSTokCtrl pos c:toks) = do
frags <- collectCtrlAndC toks
return $ CHSC [c] pos : frags
collectCtrlAndC (CHSTokC pos s:toks) = do
frags <- collectCtrlAndC toks
return $ CHSC s pos : frags
collectCtrlAndC toks = parseFrags toks
parseImport :: Position -> [CHSToken] -> CST s [CHSFrag]
parseImport pos toks = do
(qual, modid, toks') <-
case toks of
CHSTokIdent _ ide :toks ->
let (ide', toks') = rebuildModuleId ide toks
in return (False, ide', toks')
CHSTokQualif _: CHSTokIdent _ ide:toks ->
let (ide', toks') = rebuildModuleId ide toks
in return (True , ide', toks')
_ -> syntaxError toks
let fName = moduleNameToFileName . identToLexeme $ modid
toks'' <- parseEndHook toks'
frags <- parseFrags toks''
return $ CHSHook (CHSImport qual modid fName pos) : frags
rebuildModuleId ide (CHSTokDot _ : CHSTokIdent _ ide' : toks) =
let catIdent ide ide' = onlyPosIdent (posOf ide)
(identToLexeme ide ++ '.' : identToLexeme ide')
in rebuildModuleId (catIdent ide ide') toks
rebuildModuleId ide toks = (ide, toks)
moduleNameToFileName :: String -> FilePath
moduleNameToFileName = map dotToSlash
where dotToSlash '.' = '/'
dotToSlash c = c
parseContext :: Position -> [CHSToken] -> CST s [CHSFrag]
parseContext pos toks = do
(olib , toks ) <- parseOptLib toks
(opref , toks) <- parseOptPrefix False toks
(olock , toks) <- parseOptLock toks
toks <- parseEndHook toks
frags <- parseFrags toks
let frag = CHSContext olib opref olock pos
return $ CHSHook frag : frags
parseType :: Position -> [CHSToken] -> CST s [CHSFrag]
parseType pos (CHSTokIdent _ ide:toks) =
do
toks' <- parseEndHook toks
frags <- parseFrags toks'
return $ CHSHook (CHSType ide pos) : frags
parseType _ toks = syntaxError toks
parseSizeof :: Position -> [CHSToken] -> CST s [CHSFrag]
parseSizeof pos (CHSTokIdent _ ide:toks) =
do
toks' <- parseEndHook toks
frags <- parseFrags toks'
return $ CHSHook (CHSSizeof ide pos) : frags
parseSizeof _ toks = syntaxError toks
parseEnum :: Position -> [CHSToken] -> CST s [CHSFrag]
parseEnum pos (CHSTokIdent _ ide:toks) =
do
(oalias, toks' ) <- parseOptAs ide True toks
(trans , toks'') <- parseTrans toks'
(oprefix, toks''') <- parseOptPrefix True toks''
(derive, toks'''') <- parseDerive toks'''
toks''''' <- parseEndHook toks''''
frags <- parseFrags toks'''''
return $ CHSHook (CHSEnum ide (norm oalias) trans oprefix derive pos) : frags
where
norm Nothing = Nothing
norm (Just ide') | ide == ide' = Nothing
| otherwise = Just ide'
parseEnum _ toks = syntaxError toks
parseCall :: Position -> [CHSToken] -> CST s [CHSFrag]
parseCall pos toks =
do
(isPure , toks ) <- parseIsPure toks
(isUnsafe, toks ) <- parseIsUnsafe toks
(isNolock, toks ) <- parseIsNolock toks
(ide , toks ) <- parseIdent toks
(oalias , toks ) <- parseOptAs ide False toks
toks <- parseEndHook toks
frags <- parseFrags toks
return $
CHSHook (CHSCall isPure isUnsafe isNolock ide (norm ide oalias) pos) : frags
parseFun :: Position -> [CHSToken] -> CST s [CHSFrag]
parseFun pos toks =
do
(isPure , toks' ) <- parseIsPure toks
(isUnsafe, toks'2) <- parseIsUnsafe toks'
(isNolock, toks'3) <- parseIsNolock toks'2
(ide , toks'4) <- parseIdent toks'3
(oalias , toks'5) <- parseOptAs ide False toks'4
(octxt , toks'6) <- parseOptContext toks'5
(parms , toks'7) <- parseParms toks'6
(parm , toks'8) <- parseParm toks'7
toks'9 <- parseEndHook toks'8
frags <- parseFrags toks'9
return $
CHSHook
(CHSFun isPure isUnsafe isNolock ide (norm ide oalias) octxt parms parm pos) :
frags
where
parseOptContext (CHSTokHSVerb _ ctxt:CHSTokDArrow _:toks) =
return (Just ctxt, toks)
parseOptContext toks =
return (Nothing , toks)
parseParms (CHSTokLBrace _:CHSTokRBrace _:CHSTokArrow _:toks) =
return ([], toks)
parseParms (CHSTokLBrace _ :toks) =
parseParms' (CHSTokComma nopos:toks)
parseParms toks =
syntaxError toks
parseParms' (CHSTokRBrace _:CHSTokArrow _:toks) = return ([], toks)
parseParms' (CHSTokComma _ :toks) = do
(parm , toks' ) <- parseParm toks
(parms, toks'') <- parseParms' toks'
return (parm:parms, toks'')
parseParms' (CHSTokRBrace _ :toks) = syntaxError toks
parseParms' toks = syntaxError toks
parseIsPure :: [CHSToken] -> CST s (Bool, [CHSToken])
parseIsPure (CHSTokPure _:toks) = return (True , toks)
parseIsPure (CHSTokFun _:toks) = return (True , toks)
parseIsPure toks = return (False, toks)
parseIsUnsafe :: [CHSToken] -> CST s (Bool, [CHSToken])
parseIsUnsafe (CHSTokUnsafe _:toks) = return (True , toks)
parseIsUnsafe toks = return (False, toks)
parseIsNolock :: [CHSToken] -> CST s (Bool, [CHSToken])
parseIsNolock (CHSTokNolock _:toks) = return (True , toks)
parseIsNolock toks = return (False, toks)
norm :: Ident -> Maybe Ident -> Maybe Ident
norm ide Nothing = Nothing
norm ide (Just ide') | ide == ide' = Nothing
| otherwise = Just ide'
parseParm :: [CHSToken] -> CST s (CHSParm, [CHSToken])
parseParm toks =
do
(oimMarsh, toks' ) <- parseOptMarsh toks
(hsTyStr, twoCVals, pos, toks'2) <-
case toks' of
(CHSTokHSVerb pos hsTyStr:CHSTokAmp _:toks'2) ->
return (hsTyStr, True , pos, toks'2)
(CHSTokHSVerb pos hsTyStr :toks'2) ->
return (hsTyStr, False, pos, toks'2)
toks -> syntaxError toks
(oomMarsh, toks'3) <- parseOptMarsh toks'2
return (CHSParm oimMarsh hsTyStr twoCVals oomMarsh pos, toks'3)
where
parseOptMarsh :: [CHSToken] -> CST s (Maybe (Ident, CHSArg), [CHSToken])
parseOptMarsh (CHSTokIdent _ ide:CHSTokStar _ :toks) =
return (Just (ide, CHSIOArg) , toks)
parseOptMarsh (CHSTokIdent _ ide:CHSTokMinus _:toks) =
return (Just (ide, CHSVoidArg), toks)
parseOptMarsh (CHSTokIdent _ ide :toks) =
return (Just (ide, CHSValArg) , toks)
parseOptMarsh toks =
return (Nothing, toks)
parseField :: Position -> CHSAccess -> [CHSToken] -> CST s [CHSFrag]
parseField pos access toks =
do
(path, toks') <- parsePath toks
frags <- parseFrags toks'
return $ CHSHook (CHSField access path pos) : frags
parsePointer :: Position -> [CHSToken] -> CST s [CHSFrag]
parsePointer pos toks =
do
(isStar, ide, toks') <-
case toks of
CHSTokStar _:CHSTokIdent _ ide:toks' -> return (True , ide, toks')
CHSTokIdent _ ide :toks' -> return (False, ide, toks')
_ -> syntaxError toks
(oalias , toks'2) <- parseOptAs ide True toks'
(ptrType, toks'3) <- parsePtrType toks'2
let
(isNewtype, oRefType, toks'4) =
case toks'3 of
CHSTokNewtype _ :toks' -> (True , Nothing , toks' )
CHSTokArrow _:CHSTokIdent _ ide:toks' -> (False, Just ide, toks' )
_ -> (False, Nothing , toks'3)
toks'5 <- parseEndHook toks'4
frags <- parseFrags toks'5
return $
CHSHook
(CHSPointer isStar ide (norm ide oalias) ptrType isNewtype oRefType pos)
: frags
where
parsePtrType :: [CHSToken] -> CST s (CHSPtrType, [CHSToken])
parsePtrType (CHSTokForeign _:toks) = return (CHSForeignPtr, toks)
parsePtrType (CHSTokStable _ :toks) = return (CHSStablePtr, toks)
parsePtrType toks = return (CHSPtr, toks)
norm ide Nothing = Nothing
norm ide (Just ide') | ide == ide' = Nothing
| otherwise = Just ide'
parsePragma :: Position -> [CHSToken] -> CST s [CHSFrag]
parsePragma pos toks = do
let
parseExts exts (CHSTokIdent _ ide:CHSTokComma _:toks) =
parseExts (identToLexeme ide:exts) toks
parseExts exts (CHSTokIdent _ ide:CHSTokPragEnd _:toks) =
return (reverse (identToLexeme ide:exts), toks)
parseExts exts toks = syntaxError toks
(exts, toks) <- parseExts [] toks
frags <- parseFrags toks
return (CHSLang exts pos : frags)
parseClass :: Position -> [CHSToken] -> CST s [CHSFrag]
parseClass pos (CHSTokIdent _ sclassIde:
CHSTokDArrow _ :
CHSTokIdent _ classIde :
CHSTokIdent _ typeIde :
toks) =
do
toks' <- parseEndHook toks
frags <- parseFrags toks'
return $ CHSHook (CHSClass (Just sclassIde) classIde typeIde pos) : frags
parseClass pos (CHSTokIdent _ classIde :
CHSTokIdent _ typeIde :
toks) =
do
toks' <- parseEndHook toks
frags <- parseFrags toks'
return $ CHSHook (CHSClass Nothing classIde typeIde pos) : frags
parseClass _ toks = syntaxError toks
parseOptLib :: [CHSToken] -> CST s (Maybe String, [CHSToken])
parseOptLib (CHSTokLib _ :
CHSTokEqual _ :
CHSTokString _ str:
toks) = return (Just str, toks)
parseOptLib (CHSTokLib _:toks ) = syntaxError toks
parseOptLib toks = return (Nothing, toks)
parseOptLock :: [CHSToken] -> CST s (Maybe String, [CHSToken])
parseOptLock (CHSTokLock _ :
CHSTokEqual _ :
CHSTokString _ str:
toks) = return (Just str, toks)
parseOptLock (CHSTokLock _:toks ) = syntaxError toks
parseOptLock toks = return (Nothing, toks)
parseOptPrefix :: Bool -> [CHSToken] -> CST s (Maybe String, [CHSToken])
parseOptPrefix False (CHSTokPrefix _ :
CHSTokEqual _ :
CHSTokString _ str:
toks) = return (Just str, toks)
parseOptPrefix True (CHSTokWith _ :
CHSTokPrefix _ :
CHSTokEqual _ :
CHSTokString _ str:
toks) = return (Just str, toks)
parseOptPrefix _ (CHSTokWith _:toks) = syntaxError toks
parseOptPrefix _ (CHSTokPrefix _:toks) = syntaxError toks
parseOptPrefix _ toks = return (Nothing, toks)
parseOptAs :: Ident -> Bool -> [CHSToken] -> CST s (Maybe Ident, [CHSToken])
parseOptAs _ _ (CHSTokAs _:CHSTokIdent _ ide:toks) =
return (Just ide, toks)
parseOptAs ide upper (CHSTokAs _:CHSTokHat pos :toks) =
return (Just $ underscoreToCase ide upper pos, toks)
parseOptAs _ _ (CHSTokAs _ :toks) = syntaxError toks
parseOptAs _ _ toks =
return (Nothing, toks)
underscoreToCase :: Ident -> Bool -> Position -> Ident
underscoreToCase ide upper pos =
let lexeme = identToLexeme ide
ps = filter (not . null) . parts $ lexeme
in
onlyPosIdent pos . adjustHead . concat . map adjustCase $ ps
where
parts s = let (l, s') = break (== '_') s
in
l : case s' of
[] -> []
(_:s'') -> parts s''
adjustCase (c:cs) = toUpper c : map toLower cs
adjustHead "" = ""
adjustHead (c:cs) = if upper then toUpper c : cs else toLower c:cs
parsePath :: [CHSToken] -> CST s (CHSAPath, [CHSToken])
parsePath (CHSTokStar pos:toks) =
do
(path, toks') <- parsePath toks
return (CHSDeref path pos, toks')
parsePath (CHSTokIdent _ ide:toks) =
do
(pathWithHole, toks') <- parsePath' toks
return (pathWithHole (CHSRoot ide), toks')
parsePath toks = syntaxError toks
parsePath' :: [CHSToken] -> CST s (CHSAPath -> CHSAPath, [CHSToken])
parsePath' (CHSTokDot _:CHSTokIdent _ ide:toks) =
do
(pathWithHole, toks') <- parsePath' toks
return (pathWithHole . (\hole -> CHSRef hole ide), toks')
parsePath' (CHSTokDot _:toks) =
syntaxError toks
parsePath' (CHSTokArrow pos:CHSTokIdent _ ide:toks) =
do
(pathWithHole, toks') <- parsePath' toks
return (pathWithHole . (\hole -> CHSRef (CHSDeref hole pos) ide), toks')
parsePath' (CHSTokArrow _:toks) =
syntaxError toks
parsePath' toks =
do
toks' <- parseEndHook toks
return (id, toks')
parseTrans :: [CHSToken] -> CST s (CHSTrans, [CHSToken])
parseTrans (CHSTokLBrace _:toks) =
do
(_2Case, toks' ) <- parse_2Case toks
case toks' of
(CHSTokRBrace _:toks'') -> return (CHSTrans _2Case [], toks'')
_ ->
do
(transs, toks'') <- if _2Case
then parseTranss toks'
else parseTranss (CHSTokComma nopos:toks')
return (CHSTrans _2Case transs, toks'')
where
parse_2Case (CHSTok_2Case _:toks) = return (True, toks)
parse_2Case toks = return (False, toks)
parseTranss (CHSTokRBrace _:toks) = return ([], toks)
parseTranss (CHSTokComma _:toks) = do
(assoc, toks' ) <- parseAssoc toks
(trans, toks'') <- parseTranss toks'
return (assoc:trans, toks'')
parseTranss toks = syntaxError toks
parseAssoc (CHSTokIdent _ ide1:CHSTokAs _:CHSTokIdent _ ide2:toks) =
return ((ide1, ide2), toks)
parseAssoc (CHSTokIdent _ ide1:CHSTokAs _:toks ) =
syntaxError toks
parseAssoc (CHSTokIdent _ ide1:toks ) =
syntaxError toks
parseAssoc toks =
syntaxError toks
parseTrans toks = syntaxError toks
parseDerive :: [CHSToken] -> CST s ([Ident], [CHSToken])
parseDerive (CHSTokDerive _ :CHSTokLParen _:CHSTokRParen _:toks) =
return ([], toks)
parseDerive (CHSTokDerive _ :CHSTokLParen _:toks) =
parseCommaIdent (CHSTokComma nopos:toks)
where
parseCommaIdent :: [CHSToken] -> CST s ([Ident], [CHSToken])
parseCommaIdent (CHSTokComma _:CHSTokIdent _ ide:toks) =
do
(ids, tok') <- parseCommaIdent toks
return (ide:ids, tok')
parseCommaIdent (CHSTokRParen _ :toks) =
return ([], toks)
parseDerive toks = return ([],toks)
parseIdent :: [CHSToken] -> CST s (Ident, [CHSToken])
parseIdent (CHSTokIdent _ ide:toks) = return (ide, toks)
parseIdent toks = syntaxError toks
parseEndHook :: [CHSToken] -> CST s ([CHSToken])
parseEndHook (CHSTokEndHook _:toks) = return toks
parseEndHook toks = syntaxError toks
syntaxError :: [CHSToken] -> CST s a
syntaxError [] = errorEOF
syntaxError (tok:_) = errorIllegal tok
errorIllegal :: CHSToken -> CST s a
errorIllegal tok = do
raiseError (posOf tok)
["Syntax error!",
"The phrase `" ++ show tok ++ "' is not allowed \
\here."]
raiseSyntaxError
errorEOF :: CST s a
errorEOF = do
raiseError nopos
["Premature end of file!",
"The .chs file ends in the middle of a binding hook."]
raiseSyntaxError
errorCHINotFound :: String -> CST s a
errorCHINotFound ide = do
raiseError nopos
["Unknown .chi file!",
"Cannot find the .chi file for `" ++ ide ++ "'."]
raiseSyntaxError
errorCHICorrupt :: String -> CST s a
errorCHICorrupt ide = do
raiseError nopos
["Corrupt .chi file!",
"The file `" ++ ide ++ ".chi' is corrupt."]
raiseSyntaxError
errorCHIVersion :: String -> String -> String -> CST s a
errorCHIVersion ide chiVersion myVersion = do
raiseError nopos
["Wrong version of .chi file!",
"The file `" ++ ide ++ ".chi' is version "
++ chiVersion ++ ", but mine is " ++ myVersion ++ "."]
raiseSyntaxError