-- C->Haskell Compiler: CHS file abstraction
--
-- Author : Manuel M T Chakravarty
-- Created: 16 August 99
--
-- Version $Revision: 1.3 $ from $Date: 2005/01/23 15:44:36 $
--
-- Copyright (c) [1999..2004] Manuel M T Chakravarty
--
-- This file is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2 of the License, or
-- (at your option) any later version.
--
-- This file is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
--
--- DESCRIPTION ---------------------------------------------------------------
--
-- Main file for reading CHS files.
--
-- Import hooks & .chi files
-- -------------------------
--
-- Reading of `.chi' files is interleaved with parsing. More precisely,
-- whenever the parser comes across an import hook, it immediately reads the
-- `.chi' file and inserts its contents into the abstract representation of
-- the hook. The parser checks the version of the `.chi' file, but does not
-- otherwise attempt to interpret its contents. This is only done during
-- generation of the binding module. The first line of a .chi file has the
-- form
--
-- C->Haskell Interface Version <version>
--
-- where <version> is the three component version number `Version.version'.
-- C->Haskell will only accept files whose version number match its own in
-- the first two components (ie, major and minor version). In other words,
-- it must be guaranteed that the format of .chi files is not altered between
-- versions that differ only in their patchlevel. All remaining lines of the
-- file are version dependent and contain a dump of state information that
-- the binding file generator needs to rescue across modules.
--
--- DOCU ----------------------------------------------------------------------
--
-- language: Haskell 98
--
-- The following binding hooks are recognised:
--
-- hook -> `{#' inner `#}'
-- inner -> `import' ['qualified'] ident
-- | `context' ctxt
-- | `type' ident
-- | `sizeof' ident
-- | `enum' idalias trans [`with' prefix] [deriving]
-- | `call' [`pure'] [`unsafe'] [`nolock'] idalias
-- | `fun' [`pure'] [`unsafe'] [`nolock'] idalias parms
-- | `get' apath
-- | `set' apath
-- | `pointer' ['*'] idalias ptrkind
-- | `class' [ident `=>'] ident ident
-- ctxt -> [`lib' `=' string] [prefix] [lock]
-- idalias -> ident [`as' (ident | `^')]
-- prefix -> `prefix' `=' string
-- lock -> `lock' `=' string
-- deriving -> `deriving' `(' ident_1 `,' ... `,' ident_n `)'
-- parms -> [verbhs `=>'] `{' parm_1 `,' ... `,' parm_n `}' `->' parm
-- parm -> [ident_1 [`*' | `-']] verbhs [`&'] [ident_2 [`*' | `-']]
-- apath -> ident
-- | `*' apath
-- | apath `.' ident
-- | apath `->' ident
-- trans -> `{' alias_1 `,' ... `,' alias_n `}'
-- alias -> `underscoreToCase'
-- | ident `as' ident
-- ptrkind -> [`foreign' | `stable' ] ['newtype' | '->' ident]
--
-- If `underscoreToCase' occurs in a translation table, it must be the first
-- entry.
--
-- Remark: Optional Haskell names are normalised during structure tree
-- construction, ie, associations that associated a name with itself
-- are removed. (They don't carry semantic content, and make some
-- tests more complicated.)
--
--- TODO ----------------------------------------------------------------------
--
module CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSTrans(..), CHSParm(..),
CHSArg(..), CHSAccess(..), CHSAPath(..), CHSPtrType(..),
skipToLangPragma, hasCPP,
loadCHS, dumpCHS, hssuffix, chssuffix, loadAllCHI, loadCHI, dumpCHI,
chisuffix, showCHSParm)
where
-- standard libraries
import Data.Char (isSpace, toUpper, toLower)
import Data.List (intersperse)
import Control.Monad (when, unless)
-- Compiler Toolkit
import Position (Position(..), Pos(posOf), nopos, isBuiltinPos)
import Errors (interr)
import Idents (Ident, identToLexeme, onlyPosIdent)
-- C->Haskell
import C2HSState (CST, nop, doesFileExistCIO, readFileCIO, writeFileCIO, getId,
getSwitch, chiPathSB, catchExc, throwExc, raiseError,
fatal, errorsPresent, showErrors, Traces(..), putTraceStr)
-- friends
import CHSLexer (CHSToken(..), lexCHS)
-- CHS abstract syntax
-- -------------------
-- representation of a CHS module (EXPORTED)
--
data CHSModule = CHSModule [CHSFrag]
-- a CHS code fragament (EXPORTED)
--
-- * `CHSVerb' fragments are present throughout the compilation and finally
-- they are the only type of fragment (describing the generated Haskell
-- code)
--
-- * `CHSHook' are binding hooks, which are being replaced by Haskell code by
-- `GenBind.expandHooks'
--
-- * `CHSCPP' and `CHSC' are fragements of C code that are being removed when
-- generating the custom C header in `GenHeader.genHeader'
--
-- * `CHSCond' are strutured conditionals that are being generated by
-- `GenHeader.genHeader' from conditional CPP directives (`CHSCPP')
--
data CHSFrag = CHSVerb String -- Haskell code
Position
| CHSHook CHSHook -- binding hook
| CHSCPP String -- pre-processor directive
Position
| CHSLine Position -- line pragma
| CHSC String -- C code
Position
| CHSCond [(Ident, -- C variable repr. condition
[CHSFrag])] -- then/elif branches
(Maybe [CHSFrag]) -- else branch
| CHSLang [String] -- GHC language pragma
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
-- a CHS binding hook (EXPORTED)
--
data CHSHook = CHSImport Bool -- qualified?
Ident -- module name
String -- content of .chi file
Position
| CHSContext (Maybe String) -- library name
(Maybe String) -- prefix
(Maybe String) -- lock function
Position
| CHSType Ident -- C type
Position
| CHSSizeof Ident -- C type
Position
| CHSEnum Ident -- C enumeration type
(Maybe Ident) -- Haskell name
CHSTrans -- translation table
(Maybe String) -- local prefix
[Ident] -- instance requests from user
Position
| CHSCall Bool -- is a pure function?
Bool -- is unsafe?
Bool -- is without lock?
Ident -- C function
(Maybe Ident) -- Haskell name
Position
| CHSFun Bool -- is a pure function?
Bool -- is unsafe?
Bool -- is without lock?
Ident -- C function
(Maybe Ident) -- Haskell name
(Maybe String) -- type context
[CHSParm] -- argument marshalling
CHSParm -- result marshalling
Position
| CHSField CHSAccess -- access type
CHSAPath -- access path
Position
| CHSPointer Bool -- explicit '*' in hook
Ident -- C pointer name
(Maybe Ident) -- Haskell name
CHSPtrType -- Ptr, ForeignPtr or StablePtr
Bool -- create new type?
(Maybe Ident) -- Haskell type pointed to
Position
| CHSClass (Maybe Ident) -- superclass
Ident -- class name
Ident -- name of pointer type
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
-- two hooks are equal if they have the same Haskell name and reference the
-- same C object
--
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
-- translation table (EXPORTED)
--
data CHSTrans = CHSTrans Bool -- underscore to case?
[(Ident, Ident)] -- alias list
-- marshalling descriptor for function hooks (EXPORTED)
--
-- * a marshaller consists of a function name and flag indicating whether it
-- has to be executed in the IO monad
--
data CHSParm = CHSParm (Maybe (Ident, CHSArg)) -- "in" marshaller
String -- Haskell type
Bool -- C repr: two values?
(Maybe (Ident, CHSArg)) -- "out" marshaller
Position
-- kinds of arguments in function hooks (EXPORTED)
--
data CHSArg = CHSValArg -- plain value argument
| CHSIOArg -- reference argument
| CHSVoidArg -- no argument
deriving (Eq)
-- structure member access types (EXPORTED)
--
data CHSAccess = CHSSet -- set structure field
| CHSGet -- get structure field
deriving (Eq)
-- structure access path (EXPORTED)
--
data CHSAPath = CHSRoot Ident -- root of access path
| CHSDeref CHSAPath Position -- dereferencing
| CHSRef CHSAPath Ident -- member referencing
deriving (Eq)
-- pointer options (EXPORTED)
--
data CHSPtrType = CHSPtr -- standard Ptr from Haskell
| CHSForeignPtr -- a pointer with a finalizer
| CHSStablePtr -- a pointer into Haskell land
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 _ _ = []
-- return a modified module description that starts off with a LANGUAGE pragma
-- if it contains a LANGUAGE pragma at all
skipToLangPragma :: CHSModule -> Maybe CHSModule
skipToLangPragma (CHSModule frags) = hLP frags
where
hLP all@(CHSLang exts _:_) = Just (CHSModule all)
hLP (x:xs) = hLP xs
hLP [] = Nothing
-- test if the language pragma contains the CPP option
hasCPP :: CHSModule -> Bool
hasCPP (CHSModule (CHSLang exts _:_)) = "CPP" `elem` exts
hasCPP _ = False
-- load and dump a CHS file
-- ------------------------
hssuffix, chssuffix :: String
hssuffix = ".hs"
chssuffix = ".chs"
-- parse a CHS module (EXPORTED)
--
-- * in case of a syntactical or lexical error, a fatal error is raised;
-- warnings are returned together with the module
--
loadCHS :: FilePath -> CST s (CHSModule, String)
loadCHS fname = do
-- parse
--
traceInfoRead fname
contents <- readFileCIO fname
traceInfoParse
mod <- parseCHSModule (Position fname 1 1) contents
-- check for errors and finalize
--
errs <- errorsPresent
if errs
then do
traceInfoErr
errmsgs <- showErrors
fatal ("CHS module contains \
\errors:\n\n" ++ errmsgs) -- fatal error
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")
-- given a file name (no suffix) and a CHS module, the module is printed
-- into that file (EXPORTED)
--
-- * the module can be flagged as being pure Haskell
--
-- * the correct suffix will automagically be appended
--
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
-- to keep track of the current state of the line emission automaton
--
data LineState = Emit -- emit LINE pragma if next frag is Haskell
| Wait -- emit LINE pragma after the next '\n'
| NoLine -- no pragma needed
deriving (Eq)
-- convert a CHS module into a string
--
-- * if the second argument is `True', all fragments must contain Haskell code
--
showCHSModule :: CHSModule -> Bool -> String
showCHSModule (CHSModule frags) pureHaskell =
showFrags pureHaskell Emit frags []
where
-- the second argument indicates whether the next fragment (if it is
-- Haskell code) should be preceded by a LINE pragma; in particular
-- generated fragments and those following them need to be prefixed with a
-- LINE pragma
--
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
-- . showChar '\n'
. 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
-- load and dump a CHI file
-- ------------------------
chisuffix :: String
chisuffix = ".chi"
versionPrefix :: String
versionPrefix = "C->Haskell Interface Version "
-- replace all import names with the content of the CHI file
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')
-- load a CHI file (EXPORTED)
--
-- * the file suffix is automagically appended
--
-- * any error raises a syntax exception (see below)
--
-- * the version of the .chi file is checked against the version of the current
-- executable; they must match in the major and minor version
--
loadCHI :: FilePath -> CST s String
loadCHI fname = do
-- search for .chi files
--
paths <- getSwitch chiPathSB
let fullnames = [path ++ '/':fname ++ chisuffix |
path <- paths]
fullname <- findFirst fullnames
(fatal $ fname++chisuffix++" not found in:\n"++
unlines paths)
-- read file
--
traceInfoRead fullname
contents <- readFileCIO fullname
-- parse
--
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)
-- finalize
--
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
-- given a file name (no suffix) and a CHI file, the information is printed
-- into that file (EXPORTED)
--
-- * the correct suffix will automagically be appended
--
dumpCHI :: String -> String -> CST s ()
dumpCHI fname contents =
do
(version, _, _) <- getId
writeFileCIO (fname ++ chisuffix) $
versionPrefix ++ version ++ "\n" ++ contents
-- extract major and minor number from a version string
--
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)
-- parsing a CHS token stream
-- --------------------------
syntaxExc :: String
syntaxExc = "syntax"
-- alternative action in case of a syntax exception
--
ifError :: CST s a -> CST s a -> CST s a
ifError action handler = action `catchExc` (syntaxExc, const handler)
-- raise syntax error exception
--
raiseSyntaxError :: CST s a
raiseSyntaxError = throwExc syntaxExc "syntax error"
-- parse a complete module
--
-- * errors are entered into the compiler state
--
parseCHSModule :: Position -> String -> CST s CHSModule
parseCHSModule pos cs = do
toks <- lexCHS cs pos
frags <- parseFrags toks
return (CHSModule frags)
-- parsing of code fragments
--
-- * in case of an error, all tokens that are neither Haskell nor control
-- tokens are skipped; afterwards parsing continues
--
-- * when encountering inline-C code we scan forward over all inline-C and
-- control tokens to avoid turning the control tokens within a sequence of
-- inline-C into Haskell fragments
--
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
--
-- skip to next Haskell or control token
--
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
-- Qualified module names do not get lexed as a single token so we need to
-- reconstruct it from a sequence of identifer and dot tokens.
--
rebuildModuleId ide (CHSTokDot _ : CHSTokIdent _ ide' : toks) =
let catIdent ide ide' = onlyPosIdent (posOf ide) --FIXME: unpleasent hack
(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
-- gives better error messages
parseParms' toks = syntaxError toks
parseIsPure :: [CHSToken] -> CST s (Bool, [CHSToken])
parseIsPure (CHSTokPure _:toks) = return (True , toks)
parseIsPure (CHSTokFun _:toks) = return (True , toks) -- backwards compat.
parseIsPure toks = return (False, toks)
-- FIXME: eventually, remove `fun'; it's currently deprecated
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)
-- first argument is the identifier that is to be used when `^' is given and
-- the second indicates whether the first character has to be upper case
--
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)
-- convert C style identifier to Haskell style identifier
--
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
-- this is disambiguated and left factored
--
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
-- `s->m' is represented by `(*s).m' in the tree
--
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
-- if there was no `underscoreToCase', we add a comma token to meet
-- the invariant of `parseTranss'
--
(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