c2hs-0.17.1: src/C2HS/CHS.hs
{-# LANGUAGE StandaloneDeriving #-}
-- C->Haskell Compiler: CHS file abstraction
--
-- Author : Manuel M T Chakravarty
-- Created: 16 August 99
--
-- Copyright (c) [1999..2005] 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
-- | `alignof' ident
-- | `enum' idalias trans [`with' prefix] [`add' prefix] [deriving]
-- | `enum` `define` idalias [deriving]
-- | `call' [`pure'] [`unsafe'] idalias
-- | `fun' [`pure'] [`unsafe'] idalias parms
-- | `get' [`struct'] apath
-- | `set' [`struct'] apath
-- | `offsetof` apath
-- | `pointer' ['*'] idalias ptrkind ['nocode']
-- | `class' [ident `=>'] ident ident
-- ctxt -> [`lib' `=' string] [prefix]
-- idalias -> ident [`as' (ident | `^')]
-- prefix -> `prefix' `=' string [`add' `prefix' `=' string]
-- deriving -> `deriving' `(' ident_1 `,' ... `,' ident_n `)'
-- parms -> [verbhs `=>'] `{' parm_1 `,' ... `,' parm_n `}' `->' parm
-- parm -> [ident_or_quot_1 [`*' | `-']] verbhs [`&'] [ident_or_quot_2 [`*'] [`-']]
-- ident_or_quot -> ident | quoths
-- apath -> ident
-- | `*' apath
-- | apath `.' ident
-- | apath `->' ident
-- trans -> `{' alias_1 `,' ... `,' alias_n `}'
-- alias -> `underscoreToCase' | `upcaseFirstLetter'
-- | `downcaseFirstLetter'
-- | ident `as' ident
-- ptrkind -> [`foreign' | `stable'] ['newtype' | '->' ident]
--
-- If `underscoreToCase', `upcaseFirstLetter', or `downcaseFirstLetter'
-- occurs in a translation table, it must be the first entry, or if two of
-- them occur the first two entries.
--
-- 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 C2HS.CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSTrans(..),
CHSChangeCase(..), CHSParm(..), CHSMarsh, CHSArg(..), CHSAccess(..),
CHSAPath(..), CHSPtrType(..),
loadCHS, dumpCHS, hssuffix, chssuffix, loadCHI, dumpCHI, chisuffix,
showCHSParm, apathToIdent)
where
-- standard libraries
import Data.Char (isSpace, toUpper, toLower)
import Data.List (intersperse)
import Control.Monad (when)
import System.FilePath ((<.>), (</>))
-- Language.C
import Language.C.Data.Ident
import Language.C.Data.Position
import Data.Errors (interr)
-- C->Haskell
import C2HS.State (CST, getSwitch, chiPathSB, catchExc, throwExc, raiseError,
fatal, errorsPresent, showErrors, Traces(..), putTraceStr)
import qualified System.CIO as CIO
import C2HS.Version (version)
-- friends
import C2HS.CHS.Lexer (CHSToken(..), lexCHS, keywordToIdent)
-- CHS abstract syntax
-- -------------------
-- | representation of a CHS module
--
data CHSModule = CHSModule [CHSFrag]
deriving instance Show CHSModule
deriving instance Show CHSFrag
deriving instance Show CHSHook
deriving instance Show CHSAccess
deriving instance Show CHSParm
deriving instance Show CHSTrans
deriving instance Show CHSArg
deriving instance Show CHSChangeCase
-- | a CHS code fragament
--
-- * '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
Position
| CHSCPP String -- pre-processor directive
Position
Bool
| CHSLine Position -- line pragma
| CHSC String -- C code
Position
| CHSCond [(Ident, -- C variable repr. condition
[CHSFrag])] -- then/elif branches
(Maybe [CHSFrag]) -- else branch
instance Pos CHSFrag where
posOf (CHSVerb _ pos ) = pos
posOf (CHSHook _ pos ) = pos
posOf (CHSCPP _ pos _) = pos
posOf (CHSLine pos ) = pos
posOf (CHSC _ pos ) = pos
posOf (CHSCond alts _ ) = case alts of
(_, frag:_):_ -> posOf frag
_ -> nopos
-- | a CHS binding hook
--
data CHSHook = CHSImport Bool -- qualified?
Ident -- module name
String -- content of .chi file
Position
| CHSContext (Maybe String) -- library name
(Maybe String) -- prefix
(Maybe String) -- replacement prefix
Position
| CHSType Ident -- C type
Position
| CHSSizeof Ident -- C type
Position
| CHSAlignof Ident -- C type
Position
| CHSEnum Ident -- C enumeration type
(Maybe Ident) -- Haskell name
CHSTrans -- translation table
(Maybe String) -- local prefix
(Maybe String) -- local replacement prefix
[Ident] -- instance requests from user
Position
| CHSEnumDefine Ident -- Haskell name
CHSTrans -- translation table
[Ident] -- instance requests from user
Position
| CHSCall Bool -- is a pure function?
Bool -- is unsafe?
CHSAPath -- C function
(Maybe Ident) -- Haskell name
Position
| CHSFun Bool -- is a pure function?
Bool -- is unsafe?
CHSAPath -- 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
| CHSOffsetof 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
Bool -- emit type decl?
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 (CHSAlignof _ pos) = pos
posOf (CHSEnum _ _ _ _ _ _ pos) = pos
posOf (CHSEnumDefine _ _ _ pos) = pos
posOf (CHSCall _ _ _ _ pos) = pos
posOf (CHSFun _ _ _ _ _ _ _ pos) = pos
posOf (CHSField _ _ pos) = pos
posOf (CHSOffsetof _ 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 orpref1 _) == (CHSContext olib2 opref2 orpref2 _) =
olib1 == olib2 && opref1 == opref2 && orpref1 == orpref2
(CHSType ide1 _) == (CHSType ide2 _) =
ide1 == ide2
(CHSSizeof ide1 _) == (CHSSizeof ide2 _) =
ide1 == ide2
(CHSAlignof ide1 _) == (CHSAlignof ide2 _) =
ide1 == ide2
(CHSEnum ide1 oalias1 _ _ _ _ _) == (CHSEnum ide2 oalias2 _ _ _ _ _) =
oalias1 == oalias2 && ide1 == ide2
(CHSEnumDefine ide1 _ _ _) == (CHSEnumDefine ide2 _ _ _) =
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
(CHSOffsetof path1 _) == (CHSOffsetof path2 _) =
path1 == path2
(CHSPointer _ ide1 oalias1 _ _ _ _ _)
== (CHSPointer _ ide2 oalias2 _ _ _ _ _) =
ide1 == ide2 && oalias1 == oalias2
(CHSClass _ ide1 _ _) == (CHSClass _ ide2 _ _) =
ide1 == ide2
_ == _ = False
-- | translation table
--
data CHSTrans = CHSTrans Bool -- underscore to case?
CHSChangeCase -- upcase or downcase?
[(Ident, Ident)] -- alias list
data CHSChangeCase = CHSSameCase
| CHSUpCase
| CHSDownCase
deriving Eq
-- | marshaller consists of a function name or verbatim Haskell code
-- and flag indicating whether it has to be executed in the IO monad
--
type CHSMarsh = Maybe (Either Ident String, CHSArg)
-- | marshalling descriptor for function hooks
--
data CHSParm = CHSParm CHSMarsh -- "in" marshaller
String -- Haskell type
Bool -- C repr: two values?
CHSMarsh -- "out" marshaller
Position
-- | kinds of arguments in function hooks
--
data CHSArg = CHSValArg -- plain value argument
| CHSIOArg -- reference argument
| CHSVoidArg -- no argument
| CHSIOVoidArg -- drops argument, but in monad
deriving (Eq)
-- | structure member access types
--
data CHSAccess = CHSSet -- set structure field
| CHSGet -- get structure field
deriving (Eq)
-- | structure access path
--
data CHSAPath = CHSRoot Bool Ident
-- root of access path with flag indicating presence
-- of "struct" keyword
| CHSDeref CHSAPath Position -- dereferencing
| CHSRef CHSAPath Ident -- member referencing
deriving (Eq,Show)
instance Pos CHSAPath where
posOf (CHSRoot _ ide) = posOf ide
posOf (CHSDeref _ pos) = pos
posOf (CHSRef _ ide) = posOf ide
-- | pointer options
--
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 _ _ = []
-- load and dump a CHS file
-- ------------------------
hssuffix, chssuffix :: String
hssuffix = "hs"
chssuffix = "chs"
-- | load a CHS module
--
-- * the file suffix is automagically appended
--
-- * 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
let fullname = fname <.> chssuffix
-- read file
--
traceInfoRead fullname
contents <- CIO.readFile fullname
-- parse
--
traceInfoParse
mod' <- parseCHSModule (initPos fullname) 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
--
-- * 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)")
CIO.writeFile (fname <.> suffix) (contents version kind)
where
contents version' kind =
"-- 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 fragments) pureHaskell =
showFrags pureHaskell Emit fragments []
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
(fname,line) = (posFile pos, posRow pos)
generated = isBuiltinPos pos
emitNow = state == Emit ||
(state == Wait && not (null s) && head s == '\n')
nextState = if generated then Wait else NoLine
in
(if emitNow then
showString ("\n{-# LINE " ++ show (line `max` 0) ++ " " ++
show fname ++ " #-}\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 _ nl : frags) =
(if nl then showChar '\n' else id)
. 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 _ _ : _ ) =
interr "showCHSFrag: Cannot print `CHSCond'!"
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 oreplprefix _) =
showString "context "
. (case olib of
Nothing -> showString ""
Just lib -> showString "lib = " . showString lib . showString " ")
. showPrefix oprefix False
. showReplacementPrefix oreplprefix
showCHSHook (CHSType ide _) =
showString "type "
. showCHSIdent ide
showCHSHook (CHSSizeof ide _) =
showString "sizeof "
. showCHSIdent ide
showCHSHook (CHSAlignof ide _) =
showString "alignof "
. showCHSIdent ide
showCHSHook (CHSEnum ide oalias trans oprefix oreplprefix derive _) =
showString "enum "
. showIdAlias ide oalias
. showCHSTrans trans
. showPrefix oprefix True
. showReplacementPrefix oreplprefix
. if null derive then id else showString $
"deriving ("
++ concat (intersperse ", " (map identToString derive))
++ ") "
showCHSHook (CHSEnumDefine ide trans derive _) =
showString "enum define "
. showCHSIdent ide
. showCHSTrans trans
. if null derive then id else showString $
"deriving ("
++ concat (intersperse ", " (map identToString derive))
++ ") "
showCHSHook (CHSCall isPure isUns ide oalias _) =
showString "call "
. (if isPure then showString "pure " else id)
. (if isUns then showString "unsafe " else id)
. showApAlias ide oalias
showCHSHook (CHSFun isPure isUns ide oalias octxt parms parm _) =
showString "fun "
. (if isPure then showString "pure " else id)
. (if isUns then showString "unsafe " else id)
. showApAlias 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 (CHSOffsetof path _) =
showString "offsetof "
. showCHSAPath path
showCHSHook (CHSPointer star ide oalias ptrType isNewtype oRefType emit _) =
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 "")
. (case emit of
True -> showString ""
False -> showString " nocode")
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
showReplacementPrefix :: Maybe String -> ShowS
showReplacementPrefix Nothing = showString ""
showReplacementPrefix (Just prefix) = showString "add prefix = "
. showString prefix
. showString " "
showIdAlias :: Ident -> Maybe Ident -> ShowS
showIdAlias ide oalias =
showCHSIdent ide
. (case oalias of
Nothing -> id
Just ide' -> showString " as " . showCHSIdent ide')
showApAlias :: CHSAPath -> Maybe Ident -> ShowS
showApAlias apath oalias =
showCHSAPath apath
. (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 (body, argKind)) = showMarshBody body
. (case argKind of
CHSValArg -> id
CHSIOArg -> showString "*"
CHSVoidArg -> showString "-"
CHSIOVoidArg -> showString "*-")
--
showMarshBody (Left ide) = showCHSIdent ide
showMarshBody (Right str) = showChar '|' . showString str . showChar '|'
--
showHsVerb str = showChar '`' . showString str . showChar '\''
showCHSTrans :: CHSTrans -> ShowS
showCHSTrans (CHSTrans _2Case chgCase assocs) =
showString "{"
. (if _2Case then showString ("underscoreToCase" ++ maybeComma) else id)
. showCHSChangeCase chgCase
. foldr (.) id (intersperse (showString ", ") (map showAssoc assocs))
. showString "}"
where
maybeComma = if null assocs then "" else ", "
--
showAssoc (ide1, ide2) =
showCHSIdent ide1
. showString " as "
. showCHSIdent ide2
showCHSChangeCase :: CHSChangeCase -> ShowS
showCHSChangeCase CHSSameCase = id
showCHSChangeCase CHSUpCase = showString "upcaseFirstLetter"
showCHSChangeCase CHSDownCase = showString "downcaseFirstLetter"
showCHSAPath :: CHSAPath -> ShowS
showCHSAPath (CHSRoot True ide) =
showString "struct "
. showCHSIdent ide
showCHSAPath (CHSRoot False 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 . identToString
-- load and dump a CHI file
-- ------------------------
chisuffix :: String
chisuffix = "chi"
versionPrefix :: String
versionPrefix = "C->Haskell Interface Version "
-- | load a CHI file
--
-- * 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 <- CIO.readFile 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
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 <- CIO.doesFileExist 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
--
-- * the correct suffix will automagically be appended
--
dumpCHI :: String -> String -> CST s ()
dumpCHI fname contents =
do
CIO.writeFile (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 tokens = do
parseFrags0 tokens
`ifError` contFrags tokens
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 nl:toks) = do
frags <- parseFrags toks
return $ CHSCPP s pos nl : frags
parseFrags0 (CHSTokLine pos :toks) = do
frags <- parseFrags toks
return $ CHSLine pos : frags
parseFrags0 (CHSTokC pos s:toks) = parseC pos s toks
parseFrags0 (CHSTokHook hkpos:
CHSTokImport pos :toks) = parseImport hkpos pos toks
parseFrags0 (CHSTokHook hkpos:
CHSTokContext pos :toks) = parseContext hkpos pos toks
parseFrags0 (CHSTokHook hkpos:
CHSTokType pos :toks) = parseType hkpos pos toks
parseFrags0 (CHSTokHook hkpos:
CHSTokSizeof pos :toks) = parseSizeof hkpos pos toks
parseFrags0 (CHSTokHook hkpos:
CHSTokAlignof pos :toks) = parseAlignof hkpos pos toks
parseFrags0 (CHSTokHook hkpos:
CHSTokEnum pos :toks) = parseEnum hkpos pos toks
parseFrags0 (CHSTokHook hkpos:
CHSTokCall pos :toks) = parseCall hkpos pos toks
parseFrags0 (CHSTokHook hkpos:
CHSTokFun pos :toks) = parseFun hkpos pos toks
parseFrags0 (CHSTokHook hkpos:
CHSTokGet pos :toks) = parseField hkpos pos CHSGet toks
parseFrags0 (CHSTokHook hkpos:
CHSTokSet pos :toks) = parseField hkpos pos CHSSet toks
parseFrags0 (CHSTokHook hkpos:
CHSTokOffsetof pos :toks) = parseOffsetof hkpos pos toks
parseFrags0 (CHSTokHook hkpos:
CHSTokClass pos :toks) = parseClass hkpos pos toks
parseFrags0 (CHSTokHook hkpos:
CHSTokPointer pos :toks) = parsePointer hkpos 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 -> Position -> [CHSToken] -> CST s [CHSFrag]
parseImport hkpos 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
chi <- loadCHI . moduleNameToFileName . identToString $ modid
toks'2 <- parseEndHook toks'
frags <- parseFrags toks'2
return $ CHSHook (CHSImport qual modid chi pos) hkpos : 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 :: Ident -> [CHSToken] -> (Ident, [CHSToken])
rebuildModuleId ide (CHSTokDot _ : CHSTokIdent _ ide' : toks) =
let catIdent ide'3 ide'4 = internalIdentAt (posOf ide'3)
--FIXME: unpleasant hack
(identToString ide'3 ++ '.' : identToString ide'4)
in rebuildModuleId (catIdent ide ide') toks
rebuildModuleId ide toks = (ide, toks)
moduleNameToFileName :: String -> FilePath
moduleNameToFileName = map dotToSlash
where dotToSlash '.' = '/'
dotToSlash c = c
parseContext :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]
parseContext hkpos pos toks = do
(olib , toks2) <- parseOptLib toks
(opref , toks3) <- parseOptPrefix False toks2
(oreppref, toks4) <- parseOptReplPrefix toks3
toks5 <- parseEndHook toks4
frags <- parseFrags toks5
let frag = CHSContext olib opref oreppref pos
return $ CHSHook frag hkpos : frags
parseType :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]
parseType hkpos pos (CHSTokIdent _ ide:toks) =
do
toks' <- parseEndHook toks
frags <- parseFrags toks'
return $ CHSHook (CHSType ide pos) hkpos : frags
parseType _ _ toks = syntaxError toks
parseSizeof :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]
parseSizeof hkpos pos (CHSTokIdent _ ide:toks) =
do
toks' <- parseEndHook toks
frags <- parseFrags toks'
return $ CHSHook (CHSSizeof ide pos) hkpos : frags
parseSizeof _ _ toks = syntaxError toks
parseAlignof :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]
parseAlignof hkpos pos (CHSTokIdent _ ide:toks) =
do
toks' <- parseEndHook toks
frags <- parseFrags toks'
return $ CHSHook (CHSAlignof ide pos) hkpos : frags
parseAlignof _ _ toks = syntaxError toks
parseEnum :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]
-- {#enum define hsid {alias_1,...,alias_n} [deriving (clid_1,...,clid_n)] #}
parseEnum hkpos pos (CHSTokIdent _ def: CHSTokIdent _ hsid: toks)
| identToString def == "define" =
do
(trans , toks') <- parseTrans toks
(derive, toks'') <- parseDerive toks'
toks''' <- parseEndHook toks''
frags <- parseFrags toks'''
return $ CHSHook (CHSEnumDefine hsid trans derive pos) hkpos : frags
-- {#enum cid [as hsid] {alias_1,...,alias_n} [with prefix = pref] [deriving (clid_1,...,clid_n)] #}
parseEnum hkpos pos (CHSTokIdent _ ide:toks) =
do
(oalias, toks2) <- parseOptAs ide True toks
(trans, toks3) <- parseTrans toks2
(oprefix, toks4) <- parseOptPrefix True toks3
(oreplprefix, toks5) <- parseOptReplPrefix toks4
(derive, toks6) <- parseDerive toks5
toks7 <- parseEndHook toks6
frags <- parseFrags toks7
return $ CHSHook (CHSEnum ide (norm oalias) trans
oprefix oreplprefix derive pos) hkpos : frags
where
norm Nothing = Nothing
norm (Just ide') | ide == ide' = Nothing
| otherwise = Just ide'
parseEnum _ _ toks = syntaxError toks
parseCall :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]
parseCall hkpos pos toks =
do
(isPure , toks' ) <- parseIsPure toks
(isUnsafe, toks'' ) <- parseIsUnsafe toks'
(apath , toks''' ) <- parsePath toks''
(oalias , toks'''') <- parseOptAs (apathToIdent apath) False toks'''
toks''''' <- parseEndHook toks''''
frags <- parseFrags toks'''''
return $
CHSHook (CHSCall isPure isUnsafe apath oalias pos) hkpos : frags
parseFun :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]
parseFun hkpos pos toks =
do
(isPure , toks' ) <- parseIsPure toks
(isUnsafe, toks'2) <- parseIsUnsafe toks'
(apath , toks'3) <- parsePath toks'2
(oalias , toks'4) <- parseOptAs (apathToIdent apath) False toks'3
(octxt , toks'5) <- parseOptContext toks'4
(parms , toks'6) <- parseParms toks'5
(parm , toks'7) <- parseParm toks'6
toks'8 <- parseEndHook toks'7
frags <- parseFrags toks'8
return $
CHSHook
(CHSFun isPure isUnsafe apath oalias octxt parms parm pos) hkpos :
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'2 ) <- parseParm toks'
(parms, toks'3) <- parseParms' toks'2
return (parm:parms, toks'3)
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)
apathToIdent :: CHSAPath -> Ident
apathToIdent (CHSRoot _ ide) =
let lowerFirst (c:cs) = toLower c : cs
in internalIdentAt (posOf ide) (lowerFirst $ identToString ide)
apathToIdent (CHSDeref apath _) =
let ide = apathToIdent apath
in internalIdentAt (posOf ide) (identToString ide ++ "_")
apathToIdent (CHSRef apath ide') =
let ide = apathToIdent apath
upperFirst (c:cs) = toLower c : cs
sel = upperFirst $ identToString ide'
in internalIdentAt (posOf ide) (identToString ide ++ sel)
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 (CHSMarsh, [CHSToken])
parseOptMarsh (CHSTokIdent _ ide:toks') =
do
(marshType, toks'2) <- parseOptMarshType toks'
return (Just (Left ide, marshType), toks'2)
parseOptMarsh (CHSTokHSQuot _ str:toks') =
do
(marshType, toks'2) <- parseOptMarshType toks'
return (Just (Right str, marshType), toks'2)
parseOptMarsh toks' =
return (Nothing, toks')
parseOptMarshType (CHSTokStar _ :CHSTokMinus _:toks') =
return (CHSIOVoidArg , toks')
parseOptMarshType (CHSTokStar _ :toks') =
return (CHSIOArg , toks')
parseOptMarshType (CHSTokMinus _:toks') =
return (CHSVoidArg, toks')
parseOptMarshType toks' =
return (CHSValArg, toks')
parseField :: Position -> Position -> CHSAccess -> [CHSToken] -> CST s [CHSFrag]
parseField hkpos pos access toks =
do
(path, toks') <- parsePath toks
toks'' <- parseEndHook toks'
frags <- parseFrags toks''
return $ CHSHook (CHSField access path pos) hkpos : frags
parseOffsetof :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]
parseOffsetof hkpos pos toks =
do
(path, toks') <- parsePath toks
toks'' <- parseEndHook toks'
frags <- parseFrags toks''
return $ CHSHook (CHSOffsetof path pos) hkpos : frags
parsePointer :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]
parsePointer hkpos 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)
let
(emit, toks'5) =
case toks'4 of
CHSTokNocode _ :toks'' -> (False, toks'' )
_ -> (True , toks'4 )
toks'6 <- parseEndHook toks'5
frags <- parseFrags toks'6
return $
CHSHook
(CHSPointer
isStar ide (norm ide oalias) ptrType isNewtype oRefType emit pos) hkpos
: 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 _ Nothing = Nothing
norm ide (Just ide') | ide == ide' = Nothing
| otherwise = Just ide'
parseClass :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]
parseClass hkpos pos (CHSTokIdent _ sclassIde:
CHSTokDArrow _ :
CHSTokIdent _ classIde :
CHSTokIdent _ typeIde :
toks) =
do
toks' <- parseEndHook toks
frags <- parseFrags toks'
return $ CHSHook (CHSClass (Just sclassIde)
classIde typeIde pos) hkpos : frags
parseClass hkpos pos (CHSTokIdent _ classIde :
CHSTokIdent _ typeIde :
toks) =
do
toks' <- parseEndHook toks
frags <- parseFrags toks'
return $ CHSHook (CHSClass Nothing classIde typeIde pos) hkpos : 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)
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)
parseOptReplPrefix :: [CHSToken] -> CST s (Maybe String, [CHSToken])
parseOptReplPrefix (CHSTokAdd _ :
CHSTokPrefix _ :
CHSTokEqual _ :
CHSTokString _ str:
toks) = return (Just str, toks)
parseOptReplPrefix (CHSTokAdd _:toks) = syntaxError toks
parseOptReplPrefix (CHSTokPrefix _:toks) = syntaxError toks
parseOptReplPrefix 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 = identToString ide
ps = filter (not . null) . parts $ lexeme
in
internalIdentAt pos . adjustHead . concat . map adjustCase $ ps
where
parts s = let (l, s') = break (== '_') s
in
l : case s' of
[] -> []
(_:s'') -> parts s''
--
adjustCase "" = ""
adjustCase (c:cs) = toUpper c : 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 (CHSTokLParen _pos: toks) =
do
(inner_path, toks_rest) <- parsePath toks
toks_rest' <- case toks_rest of
(CHSTokRParen _pos' : ts) -> return ts
_ -> syntaxError toks_rest
(pathWithHole, toks') <- parsePath' toks_rest'
return (pathWithHole inner_path, toks')
parsePath (CHSTokStar pos:toks) =
do
(path, toks') <- parsePath toks
return (CHSDeref path pos, toks')
parsePath (CHSTokStruct _pos:tok:toks) =
case keywordToIdent tok of
(CHSTokIdent _ ide) ->
do
(pathWithHole, toks') <- parsePath' toks
return (pathWithHole (CHSRoot True ide), toks')
_ -> syntaxError (tok:toks)
parsePath (tok:toks) =
case keywordToIdent tok of
(CHSTokIdent _ ide) ->
do
(pathWithHole, toks') <- parsePath' toks
return (pathWithHole (CHSRoot False ide), toks')
_ -> syntaxError (tok:toks)
parsePath toks = syntaxError toks
-- | @s->m@ is represented by @(*s).m@ in the tree
--
parsePath' :: [CHSToken] -> CST s (CHSAPath -> CHSAPath, [CHSToken])
parsePath' tokens@(CHSTokDot _:desig:toks) =
do
ide <- case keywordToIdent desig of CHSTokIdent _ i -> return i; _ -> syntaxError tokens
(pathWithHole, toks') <- parsePath' toks
return (pathWithHole . (\hole -> CHSRef hole ide), toks')
parsePath' tokens@(CHSTokArrow pos:desig:toks) =
do
ide <- case keywordToIdent desig of CHSTokIdent _ i -> return i; _ -> syntaxError tokens
(pathWithHole, toks') <- parsePath' toks
return (pathWithHole . (\hole -> CHSRef (CHSDeref hole pos) ide), toks')
parsePath' toks =
return (id,toks)
parseTrans :: [CHSToken] -> CST s (CHSTrans, [CHSToken])
parseTrans (CHSTokLBrace _:toks) =
do
(_2Case, chgCase, toks' ) <- parse_2CaseAndChange toks
case toks' of
(CHSTokRBrace _:toks'2) -> return (CHSTrans _2Case chgCase [], toks'2)
_ ->
do
-- if there was no `underscoreToCase', we add a comma token to meet
-- the invariant of `parseTranss'
--
(transs, toks'2) <- if (_2Case || chgCase /= CHSSameCase)
then parseTranss toks'
else parseTranss (CHSTokComma nopos:toks')
return (CHSTrans _2Case chgCase transs, toks'2)
where
parse_2CaseAndChange (CHSTok_2Case _:CHSTokComma _:CHSTokUpper _:toks') =
return (True, CHSUpCase, toks')
parse_2CaseAndChange (CHSTok_2Case _:CHSTokComma _:CHSTokDown _ :toks') =
return (True, CHSDownCase, toks')
parse_2CaseAndChange (CHSTok_2Case _ :toks') =
return (True, CHSSameCase, toks')
parse_2CaseAndChange (CHSTokUpper _:CHSTokComma _:CHSTok_2Case _:toks') =
return (True, CHSUpCase, toks')
parse_2CaseAndChange (CHSTokUpper _ :toks') =
return (False, CHSUpCase, toks')
parse_2CaseAndChange (CHSTokDown _:CHSTokComma _:CHSTok_2Case _:toks') =
return (True, CHSDownCase, toks')
parse_2CaseAndChange (CHSTokDown _ :toks') =
return (False, CHSDownCase, toks')
parse_2CaseAndChange toks' =
return (False, CHSSameCase, toks')
--
parseTranss (CHSTokRBrace _:toks') = return ([], toks')
parseTranss (CHSTokComma _:toks') = do
(assoc, toks'2 ) <- parseAssoc toks'
(trans, toks'3) <- parseTranss toks'2
return (assoc:trans, toks'3)
parseTranss toks' = syntaxError toks'
--
parseAssoc (CHSTokIdent _ ide1:CHSTokAs _:CHSTokIdent _ ide2:toks') =
return ((ide1, ide2), toks')
parseAssoc (CHSTokIdent _ _ :CHSTokAs _:toks' ) =
syntaxError toks'
parseAssoc (CHSTokIdent _ _ :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)
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
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