--  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